c
************************************************************************
**  S U B R O U T I N E   EXTRA TIME SERIES                           **
************************************************************************
c
c         subroutine extsr
c
c     extra tsr output
      subroutine extsr(jday,dlt,elkt1,
     .   t2,cn,nac,xtsr,nxtsr,ixtsr,dlx,iex,xdist,elkt,
     .   acc,h,kt,kb,cprc,elbot)
c
                
      INCLUDE  'w2.inc'
      
      integer cn,xtsr
      real jday
      character acc*3,cprc*3
      dimension elkt1(imp),T2(KMP,IMP),CN(NCP),acc(ncp),numac(ncp),
     .  dlx(imp),xdist(imp),kprn(ncp)
      DIMENSION ixtsr(imp)   
      DIMENSION H(KMP),KB(IMP),CPRC(NCP)
c
c		find out which constituents are active
c
      icnt=1
      do i=1,ncp
          if(acc(i).eq.' ON')then
              numac(icnt)=i
              icnt=icnt+1
          end if
      end do  
c
c	calculate the distance upstream to each segment
c 
      if(iex.eq.0)then
          xmxd=0.0
          do i=1,nxtsr
              xdist(i)=0.0
              do j=1,ixtsr(i)
                  xdist(i)=xdist(i)+dlx(j)
              end do
              xmxd=max(xmxd,xdist(i))
          end do
          do i=1,nxtsr
              xdist(i)=xmxd-xdist(i)
          end do
c
c     write the header info
c
          write(xtsr,'(3i5,1x,f8.2)')nac,nxtsr,kmp,elbot
          write(xtsr,'(16i5)')(numac(i),i=1,nac)
          write(xtsr,'(16i5)')(ixtsr(i),i=1,nxtsr)
          write(xtsr,'(10f8.0)')(xdist(i),i=1,nxtsr)
          WRITE (xtsr,'(20(1x,i3))')(KB(ixtsr(i)),i=1,nxtsr)
          WRITE (xtsr,'(10F8.2)')  H
          
c	find out and print which constituents are printed

	  kpr=0
	  do jc=1,nac
	  	if(cprc(numac(jc)).eq.' ON')then
	  		kpr=kpr+1
	  		kprn(kpr)=numac(jc)
	  	end if
	  end do
          write(xtsr,'(20i4))')kpr,(kprn(i),i=1,kpr)
      end if
c
c     write this time step's info
c        
      write(xtsr,'(f7.3,1x,f8.3,1x,i4)')jday,elkt,kt

c	write the constituents

          DO JC=1,NAC
c            write(xtsr,*)' jc, numac(jc), cprc ',jc,numac(jc),
c     .            cprc(numac(jc))
            IF (CPRC(numac(jc)).EQ.' ON') THEN
               jac = numac(jc)
c              write(xtsr,*)' printing constituent ',numac(jc)
               DO J=1,nxtsr
                 I   = ixtsr(J)
                 NRS = KB(I)-KT+1
                 WRITE (xtsr,'(2I4/(8(1PE10.2E2)))') 
     .                       jac,NRS,(C2(K,I,jac),K=KT,KB(I))
               END DO
            END IF
          END DO

c	write the temperatures

	  DO J=1,nxtsr
	    I	= ixtsr(J)
	    NRS = KB(I)-KT+1
	    WRITE (xtsr,'(2I4/(8(1PE10.2E2)))')
     .              22,NRS,(T2(K,I),K=KT,KB(I))
	  END DO 
c
c	write elevations
c                                     
              write(xtsr,'('' elev   '',i8)')nxtsr
              write(xtsr,'(10f8.2)')(elkt1(i),i=1,nxtsr)
      end