      SUBROUTINE DT_STATIS(Mode)

C***********************************************************************
C Initialization and output of run-statistics.                         *
C              MODE  = 1     initialization                            *
C                    = 2     output                                    *
C This version dated 23.01.94 is written by S. Roesler                 *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION fac , pp , pt , TINY3
      INTEGER i , irej1 , j , Mode
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (TINY3=1.0D-3)

C statistics
      INCLUDE 'inc/dtsta1'
C rejection counter
      INCLUDE 'inc/dtrejc'
C central particle production, impact parameter biasing
      INCLUDE 'inc/dtimpa'
C various options for treatment of partons (DTUNUC 1.x)
C (chain recombination, Cronin,..)
      INCLUDE 'inc/dtchai'
C nucleon-nucleon event-generator
      INCLUDE 'inc/dtmodl'
C flags for particle decays
      INCLUDE 'inc/dtfrpa'
C diquark-breaking mechanism
      INCLUDE 'inc/dtdiqb'

      DIMENSION pp(4) , pt(4)

      IF ( Mode.EQ.2 ) THEN

C output

C   statistics counter

         IF ( LPRi.GT.4 ) WRITE (LOUt,99010)
99010    FORMAT (/,/,1X,'STATIS:',20X,'statistics of the run',/,28X,
     &           '---------------------')

         IF ( LPRi.GT.4 ) WRITE (LOUt,99020) ICRequ , ICSamp ,
     &        DBLE(ICSamp)/DBLE(ICRequ)
99020    FORMAT (/,1X,'number of events requested / sampled',13X,I8,
     &           ' / ',I8,/,1X,'number of samp. evts per requested ',
     &           'event',11X,F9.1)
         IF ( ICDiff(1).NE.0 ) THEN

            IF ( LPRi.GT.4 ) WRITE (LOUt,99030) ICDiff
99030       FORMAT (/,1X,'diffractive events:    total   ',I8,/,49X,
     &              'low mass   high mass',/,24X,'single diffraction',
     &              7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
         END IF
         IF ( ICEntr.GT.0 ) THEN

            IF ( LPRi.GT.4 ) WRITE (LOUt,99040) DBLE(ICCpro)
     &           /DBLE(ICSamp) , DBLE(ICSamp)/DBLE(ICCpro)
99040       FORMAT (/,1X,'central production:',/,2X,'mean number',
     &              ' of sampled Glauber-events per event',9X,F9.1,/,2X,
     &              'fraction of production cross section',21X,F10.6)
         END IF

         IF ( LPRi.GT.4 ) WRITE (LOUt,99050) DBLE(ICDpr)/DBLE(ICSamp) ,
     &        DBLE(ICDta)/DBLE(ICSamp)
99050    FORMAT (/,54X,'proj.    targ.',/,1X,
     &           'average number of wounded',
     &           ' nucleons after x-sampling',2(4X,F6.2))

         IF ( MCGene.EQ.1 ) THEN

            IF ( LPRi.GT.4 ) WRITE (LOUt,99060) DBLE(ICRjss)
     &           /DBLE(ICSamp)
99060       FORMAT (/,1X,'mean number of sea-sea chain rejections per',
     &              ' event',3X,F9.1)
            IF ( ISIcha.EQ.1 ) THEN

               IF ( LPRi.GT.4 ) WRITE (LOUt,99070) DBLE(ICVv2s)
     &              /DBLE(ICSamp)
99070          FORMAT (/,1X,'Reggeon contribution:',/,1X,'mean number ',
     &                 'of single chains  per event',13X,F9.1)
            END IF

            IF ( LPRi.GT.4 ) WRITE (LOUt,99080)
99080       FORMAT (/,1X,'chain system statistics:  (per event)',/,23X,
     &              'mean number of chains      mean number of chains',
     &              /,23X,
     &              'sampled    hadronized      having mass of a reso.')

            IF ( LPRi.GT.4 ) WRITE (LOUt,99090)
     &           (DBLE(ICChai(1,j))/(2.0D0*DBLE(ICSamp)),
     &           DBLE(ICChai(2,j))/(2.0D0*DBLE(ICRequ)),DBLE(ICRes(j))
     &           /(2.0D0*DBLE(ICRequ)),j=1,8) , DBLE(ICChai(2,9))
     &           /MAX(DBLE(ICChai(1,9)),TINY3)
99090       FORMAT (1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
     &              1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
     &              1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
     &              1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
     &              1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
     &              1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
     &              1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
     &              1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
     &              1X,'fused chains      ',18X,F4.1,17X,F4.1,/)

            IF ( LPRi.GT.4 ) WRITE (LOUt,99100)
     &           (DBLE(IRCron(i))/MAX(DBLE(IRCron(1)),TINY3),i=2,3) ,
     &           DBLE(IRPt)/DBLE(ICRequ) ,
     &           (DBLE(IRRes(i))/DBLE(ICRequ),i=1,2) , DBLE(LOMres)
     &           /DBLE(ICRequ) , DBLE(LOBres)/DBLE(ICRequ) ,
     &           (DBLE(IRChki(i))/DBLE(ICRequ),i=1,2) ,
     &           (DBLE(IRDiff(i))/DBLE(ICRequ),i=1,2) , DBLE(IRHha)
     &           /DBLE(ICRequ) , DBLE(IRFrag)/DBLE(ICRequ) , DBLE(IREvt)
     &           /DBLE(ICRequ) , (DBLE(IRExci(i))/DBLE(ICRequ),i=1,2) ,
     &           IRExci(3)
99100       FORMAT (/,1X,'Rejection counter:  (NEVT = no. of events)',/,
     &              /,1X,'Cronin-effect (CRONIN)',15X,
     &              'IRCRON(2)/IRCRON(1) = ',F7.2,/,38X,
     &              'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
     &              'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',
     &              F7.2,/,1X,'Chain mass corr. for resonances (EVTRES)'
     &              ,2X,'IRRES(1) /NEVT = ',F7.2,/,33X,
     &              '(CH2RES)  IRRES(2) /','NEVT = ',F7.2,/,43X,
     &              'LOMRES   /NEVT = ',F7.2,/,43X,'LOBRES   /NEVT = ',
     &              F7.2,/,1X,'Kinem. corr. of',
     &              ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,
     &              /,43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',
     &              31X,'IRDIFF(1)/NEVT = ',F7.2,/,43X,
     &              'IRDIFF(2)/NEVT = ',F7.2,/,1X,'Total no. of rej.',
     &              ' in chain-systems treatment (GETCSY)',/,43X,
     &              'IRHHA    /NEVT = ',F7.2,/,1X,
     &              'Fragmentation (EVTFRA)',' (not yet used!)',4X,
     &              'IRFRAG   /NEVT = ',F7.2,/,1X,
     &              'Total no. of rej. in DPM-treatment of one event',
     &              ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
     &              'Treatment of final nucleon conf.',10X,
     &              'IREXCI(1)/NEVT = ',F7.2,/,43X,'IREXCI(2)/NEVT = ',
     &              F7.2,/,48X,'IREXCI(3) = ',I5,/)
         ELSE IF ( MCGene.EQ.2 ) THEN

            IF ( LPRi.GT.4 ) WRITE (LOUt,99110) ELOjet
99110       FORMAT (/,/,1X,'PHOJET-treatment of chain systems above  ',
     &              F4.1,' GeV')

            IF ( LPRi.GT.4 ) WRITE (LOUt,99120)
99120       FORMAT (/,1X,'1. chain system statistics - total numbers:',
     &              /,30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,
     &              's-d',5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')

            IF ( LPRi.GT.4 ) WRITE (LOUt,99130)
     &           ((ICEvtg(i,j),i=1,8),j=0,1) ,
     &           (INT(ICChai(2,i)/2.0D0),i=1,8) , (ICEvtg(i,2),i=1,8) ,
     &           (ICEvtg(i,29),i=1,8) , ((ICEvtg(i,j),i=1,8),j=3,7) ,
     &           ((ICEvtg(i,j),i=1,8),j=19,21) , (ICEvtg(i,8),i=1,8) ,
     &           ((ICEvtg(i,j),i=1,8),j=22,24) , (ICEvtg(i,9),i=1,8) ,
     &           ((ICEvtg(i,j),i=1,8),j=25,28) ,
     &           ((ICEvtg(i,j),i=1,8),j=10,18)
99130       FORMAT (/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,
     &              'low ac.',8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,
     &              /,/,' no-dif.',8I8,/,' el-sca.',8I8,/,' qel-sc.',
     &              8I8,/,' dbl-Po.',8I8,/,' diff-1 ',8I8,/,'  low   ',
     &              8I8,/,'  high  ',8I8,/,'  h-diff',8I8,/,' diff-2 ',
     &              8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,'  h-diff',
     &              8I8,/,' dbl-di.',8I8,/,'  lo-lo ',8I8,/,'  hi-hi ',
     &              8I8,/,'  lo-hi ',8I8,/,'  hi-lo ',8I8,/,' dir-ga.',
     &              8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
     &              ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
     &              ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)

            IF ( LPRi.GT.4 ) WRITE (LOUt,99140)
99140       FORMAT (/,1X,'2. chain system statistics -',
     &              ' mean numbers per evt:',/,30X,
     &              '---------------------',/,/,16X,'s-s',7X,'d-s',7X,
     &              's-d')

            IF ( LPRi.GT.4 ) WRITE (LOUt,99150)
     &           ((DBLE(ICEvtg(i,j))/DBLE(ICSamp),i=1,3),j=0,1) ,
     &           (DBLE(ICChai(2,i))/(2.0D0*DBLE(ICSamp)),i=1,3) ,
     &           ((DBLE(ICEvtg(i,j))/DBLE(ICSamp),i=1,3),j=2,18)
99150       FORMAT (/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',
     &              3E10.2,/,1X,'low ac.    ',3E10.2,/,/,1X,
     &              'PHOJET     ',3E10.2,/,/,' no-dif.    ',3E10.2,/,
     &              ' el-sca.    ',3E10.2,/,' qel-sc.    ',3E10.2,/,
     &              ' dbl-Po.    ',3E10.2,/,' diff-1     ',3E10.2,/,
     &              ' diff-2     ',3E10.2,/,' dbl-di.    ',3E10.2,/,
     &              ' dir-ga.    ',3E10.2,/,/,' dir-1      ',3E10.2,/,
     &              ' dir-2      ',3E10.2,/,' dbl-dir    ',3E10.2,/,
     &              ' s-Pom.     ',3E10.2,/,' h-Pom.     ',3E10.2,/,
     &              ' s-Reg.     ',3E10.2,/,' enh-trg    ',3E10.2,/,
     &              ' enh-log    ',3E10.2)

            IF ( LPRi.GT.4 ) WRITE (LOUt,99160)
99160       FORMAT (/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')

            IF ( LPRi.GT.4 ) WRITE (LOUt,99170)
     &           ((DBLE(ICEvtg(i,j))/DBLE(ICSamp),i=4,8),j=0,1) ,
     &           (DBLE(ICChai(2,i))/(2.0D0*DBLE(ICSamp)),i=4,8) ,
     &           ((DBLE(ICEvtg(i,j))/DBLE(ICSamp),i=4,8),j=2,18)
99170       FORMAT (/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',
     &              5E10.2,/,1X,'low ac.    ',5E10.2,/,/,1X,
     &              'PHOJET     ',5E10.2,/,/,' no-dif.    ',5E10.2,/,
     &              ' el-sca.    ',5E10.2,/,' qel-sc.    ',5E10.2,/,
     &              ' dbl-Po.    ',5E10.2,/,' diff-1     ',5E10.2,/,
     &              ' diff-2     ',5E10.2,/,' dbl-di.    ',5E10.2,/,
     &              ' dir-ga.    ',5E10.2,/,/,' dir-1      ',5E10.2,/,
     &              ' dir-2      ',5E10.2,/,' dbl-dir    ',5E10.2,/,
     &              ' s-Pom.     ',5E10.2,/,' h-Pom.     ',5E10.2,/,
     &              ' s-Reg.     ',5E10.2,/,' enh-trg    ',5E10.2,/,
     &              ' enh-log    ',5E10.2)

         END IF
         CALL DT_CHASTA(1)

         IF ( (PDBsea(1).GT.0.0D0) .OR. (PDBsea(2).GT.0.0D0) .OR.
     &        (PDBsea(3).GT.0.0D0) ) THEN

            IF ( LPRi.GT.4 ) WRITE (LOUt,*) 'YGS1S,YGS2S,YUS1S,YUS2S' ,
     &           DBRka(1,1) + DBRka(2,1) , DBRka(1,2) + DBRka(2,2) ,
     &           DBRka(1,3) + DBRka(2,3) , DBRka(1,4) + DBRka(2,4)

            IF ( LPRi.GT.4 ) WRITE (LOUt,*) 'YGS1R,YGS2R,YUS1R,YUS2R' ,
     &           DBRkr(1,1) + DBRkr(2,1) , DBRkr(1,2) + DBRkr(2,2) ,
     &           DBRkr(1,3) + DBRkr(2,3) , DBRkr(1,4) + DBRkr(2,4)

            IF ( LPRi.GT.4 ) WRITE (LOUt,*)
     &            'YGSA1S,YGSA2S,YUSA1S,YUSA2S' , DBRka(1,5)
     &           + DBRka(2,5) , DBRka(1,6) + DBRka(2,6) , DBRka(1,7)
     &           + DBRka(2,7) , DBRka(1,8) + DBRka(2,8)

            IF ( LPRi.GT.4 ) WRITE (LOUt,*)
     &            'YGSA1R,YGSA2R,YUSA1R,YUSA2R' , DBRkr(1,5)
     &           + DBRkr(2,5) , DBRkr(1,6) + DBRkr(2,6) , DBRkr(1,7)
     &           + DBRkr(2,7) , DBRkr(1,8) + DBRkr(2,8)

            IF ( LPRi.GT.4 ) WRITE (LOUt,*) 'YG31S,YG32S,YU31S,YU32S' ,
     &           DBRka(3,1) , DBRka(3,2) , DBRka(3,3) , DBRka(3,4)

            IF ( LPRi.GT.4 ) WRITE (LOUt,*) 'YG31R,YG32R,YU31R,YU32R' ,
     &           DBRkr(3,1) , DBRkr(3,2) , DBRkr(3,3) , DBRkr(3,4)

            IF ( LPRi.GT.4 ) WRITE (LOUt,*)
     &            'YG3A1S,YG3A2S,YU3A1S,YU3A2S' , DBRka(3,5) ,
     &           DBRka(3,6) , DBRka(3,7) , DBRka(3,8)

            IF ( LPRi.GT.4 ) WRITE (LOUt,*)
     &            'YG3A1R,YG3A2R,YU3A1R,YU3A2R' , DBRkr(3,5) ,
     &           DBRkr(3,6) , DBRkr(3,7) , DBRkr(3,8)
         END IF

         fac = 1.0D0

C        CALL PHO_PHIST(-2,SIGMAX)

         IF ( MCGene.EQ.2 ) CALL PHO_EVENT(-2,pp,pt,fac,irej1)

         CALL DT_XTIME
         GOTO 99999
      END IF

C initialization

C   initialize statistics counter
      ICRequ = 0
      ICSamp = 0
      ICCpro = 0
      ICDpr = 0
      ICDta = 0
      ICRjss = 0
      ICVv2s = 0
      DO i = 1 , 9
         ICRes(i) = 0
         ICChai(1,i) = 0
         ICChai(2,i) = 0
      END DO
C   initialize rejection counter
      IRPt = 0
      IRHha = 0
      LOMres = 0
      LOBres = 0
      IRFrag = 0
      IREvt = 0
      IRRes(1) = 0
      IRRes(2) = 0
      IRChki(1) = 0
      IRChki(2) = 0
      IRCron(1) = 0
      IRCron(2) = 0
      IRCron(3) = 0
      IRDiff(1) = 0
      IRDiff(2) = 0
      IRInc = 0
      DO i = 1 , 5
         ICDiff(i) = 0
      END DO
      DO i = 1 , 8
         DO j = 0 , 30
            ICEvtg(i,j) = 0
         END DO
      END DO

99999 END SUBROUTINE


      SUBROUTINE SPH_PROCESS_READ( NOUT, LERR, SIN, ROVER, RLOWER,
     &				   SPMAX, SPNO, SPXYZ, SPRAD, SPLAST,
     &				   SPSEC, SPCONN, SPEFFR, LCAPS,
     & 				   SAMPLE, CVECT, PERPVE, PERPVN,
     &				   CONNR, ENDRAD )
      IMPLICIT NONE

C ********************************************************************
C *                                                                  *
C * This software is an unpublished work containing confidential and *
C * proprietary information of Oliver Smart. Use, disclosure,    *
C * reproduction and transfer of this work without the express       *
C * written consent of Oliver Smart are prohibited. This notice  *
C * must be attached to all copies or extracts of the software.      *
C *                                                                  *
C * (c) 2000 Oliver Smart *
C *                                                                  *
C ********************************************************************
C
C Modification history:
C
C Date  Author          Modification
C prior O.S.S.		part of sphqpt program
C 11/00 O.S. Smart      Original version
C
C This s/r reads the .sph file for sph_process program

! arguments for routine
      ! output stream number - for error messages etc.
      ! return unchanged
      INTEGER                   NOUT
      ! error indicator - set true if problem
      LOGICAL                   LERR

      ! inputfilename stream number
      ! return unchanged
      INTEGER			SIN

      ! override radius?
      DOUBLE PRECISION		ROVER
      ! lower limit radius - any smaller than this and ignore on read
      DOUBLE PRECISION		RLOWER

      ! sphere centre storage arrays
      ! maximum number (return unchanged), actual number, co-ords and radius
      ! logical indicates whether the record is the last centre
      INTEGER                   SPMAX, SPNO
      DOUBLE PRECISION          SPXYZ( 3, SPMAX), SPRAD( SPMAX)
      LOGICAL                   SPLAST( SPMAX)
      ! capsule option needs to have the second centre
      ! n.b. SPRAD is the real capsule radius not the effective rad`
      DOUBLE PRECISION          SPSEC( 3, SPMAX)
      ! store whether point is product of connolly - pick up by -999 residue number
      LOGICAL			SPCONN( SPMAX)

      ! need effective radius for colouring connolly
      DOUBLE PRECISION		SPEFFR( SPMAX)

      ! logical vble capsules on
      LOGICAL			LCAPS

! vbles for forpeg option - hole channel vector etc.
      DOUBLE PRECISION		CVECT(3)
! unit vectors in plane normal to cvect
! needed to a number of routines - originally h2dmap but now conn
! and addend
! these are normal - first is east direction (x on plane)
!                    and second is north     (y on plane)
      DOUBLE PRECISION		PERPVE(3), PERPVN(3)
! a sampling distance - the distance between planes
      DOUBLE PRECISION		SAMPLE
! option CONN introduced 1/00 -
! CONNR(1) is the connolly surface probe radius (default 1.15Angs)
!          the option is turned off by setting this radius negative
! CONNR(2) is the grid size to be used in the calculation - default 1/2 probe
      DOUBLE PRECISION		CONNR(2)
! the radius at which an end is reached
      DOUBLE PRECISION		ENDRAD

C internals
      INTEGER			XCOUNT
      INTEGER			NIGN ! number of ignored records
      ! string for text records in hydra file
      CHARACTER*80              STRING
      INTEGER			IOREAD ! for read

C end of decs ******************

C have opened input and output files
C and got initial conditions start work

C no sphere centres to start with
      SPNO = 0
      NIGN = 0

C read in input file - do until EOF reached
10    CONTINUE
	READ( SIN, '(A)', END= 20) STRING
C do we have a LAST-REC-END record?
        IF (STRING(1:12).EQ.'LAST-REC-END') THEN
          SPLAST(SPNO)   = .TRUE.

        ELSEIF (STRING(1:6).EQ.'SAMPLE') THEN ! pick up for peg records
	  READ( STRING(7:18),'(F12.6)', IOSTAT=IOREAD) SAMPLE
	  IF (IOREAD.NE.0) THEN
	    LERR = .TRUE.
	    WRITE( NOUT, '(A)') 'Error trying to read SAMPLE record'
	    GOTO 55555
	  ENDIF

        ELSEIF (STRING(1:6).EQ.'CVECT ') THEN ! pick up for peg records
	  READ( STRING(7:42),'(3F12.6)', IOSTAT=IOREAD)CVECT
	  IF (IOREAD.NE.0) THEN
	    LERR = .TRUE.
	    WRITE( NOUT, '(A)') 'Error trying to read CVECT record'
	    GOTO 55555
	  ENDIF

        ELSEIF (STRING(1:6).EQ.'PERPVE') THEN ! pick up for peg records
	  READ( STRING(7:42),'(3F12.6)', IOSTAT=IOREAD)PERPVE
	  IF (IOREAD.NE.0) THEN
	    LERR = .TRUE.
	    WRITE( NOUT, '(A)') 'Error trying to read PERPVE record'
	    GOTO 55555
	  ENDIF

        ELSEIF (STRING(1:6).EQ.'PERPVN') THEN ! pick up for peg records
	  READ( STRING(7:42),'(3F12.6)', IOSTAT=IOREAD)PERPVN
	  IF (IOREAD.NE.0) THEN
	    LERR = .TRUE.
	    WRITE( NOUT, '(A)') 'Error trying to read PERPVN record'
	    GOTO 55555
	  ENDIF

        ELSEIF (STRING(1:6).EQ.'CONNR ') THEN ! pick up for peg records
	  READ( STRING(7:30),'(2F12.6)', IOSTAT=IOREAD)CONNR
	  IF (IOREAD.NE.0) THEN
	    LERR = .TRUE.
	    WRITE( NOUT, '(A)') 'Error trying to read CONNR record'
	    GOTO 55555
	  ENDIF

        ELSEIF (STRING(1:6).EQ.'ENDRAD ') THEN ! pick up for peg records
	  READ( STRING(7:18),'(2F12.6)', IOSTAT=IOREAD)ENDRAD
	  IF (IOREAD.NE.0) THEN
	    LERR = .TRUE.
	    WRITE( NOUT, '(A)') 'Error trying to read ENDRAD record'
	    GOTO 55555
	  ENDIF

        ENDIF

	IF (STRING(1:4).NE.'ATOM') GOTO 10

C 'atom' read do we have a qss record?
	IF ((STRING(11:22).EQ.'1  QSS SPH S') .OR.
     &      (STRING(11:22).EQ.'1  QC1 SPH S')      ) THEN
C qss record - one more sphere centre
	  SPNO = SPNO + 1
	  SPLAST(SPNO) = .FALSE.
	  SPCONN(SPNO) = .FALSE.
	  IF (SPNO.GT.SPMAX) THEN
	    WRITE( NOUT, '(A)')
     &' *** ERROR ***'//CHAR(7),
     &' Array bound for storage of sphere centres exceeded',
     &' Please increase SPMAX in sphqpt',
     &' Aborting!'//CHAR(7)
            LERR = .TRUE.
	    GOTO 55555
	  ENDIF
C read co-ords
	  READ( STRING(31:54),'(3F8.3)')
     &      (SPXYZ( XCOUNT, SPNO), XCOUNT= 1,3)
C read radius
	  READ( STRING(55:60),'(F6.2)') SPRAD( SPNO)
C ignore this record?
          IF (SPRAD(SPNO).LT.RLOWER) THEN
C get rid of it
            SPNO = SPNO - 1
	    NIGN = NIGN + 1
	    GOTO 10
	  ENDIF
C overide?
	  IF (ROVER.NE.0) SPRAD( SPNO) = ROVER
C for safety set the second centre equal to the first
C (this is not a capsule)
	  SPSEC(1,SPNO) = SPXYZ(1,SPNO)
	  SPSEC(2,SPNO) = SPXYZ(2,SPNO)
	  SPSEC(3,SPNO) = SPXYZ(3,SPNO)

! read effective radius from 61 to 66
	  READ( STRING(61:66),'(F6.2)') SPEFFR( SPNO)
	  ! deal with old .sph format that had zero in column
          IF (ABS(SPEFFR(SPNO)).LT.1E-06) SPEFFR(SPNO) = SPRAD(SPNO)

C connolly record
          IF (STRING(23:26).EQ.'-999') SPCONN(SPNO) = .TRUE.

	  IF (STRING(11:22).EQ.'1  QC1 SPH S') THEN
C we have a capsule record
C is this first
            IF (.NOT.LCAPS) THEN
              LCAPS = .TRUE.
              WRITE( NOUT, '(A)') '      (Have capsule records)'
            ENDIF

C so read second centre info
340         CONTINUE
	    READ( SIN, '(A)') STRING
   	    IF (STRING(1:4).NE.'ATOM') GOTO 340

C 'atom' read do we have a correct record
	    IF (STRING(11:22).EQ.'1  QC2 SPH S') THEN
C read second centre co-ords
	      READ( STRING(31:54),'(3F8.3)')
     &         (SPSEC( XCOUNT, SPNO), XCOUNT= 1,3)

	    ELSE
	      WRITE( NOUT, '(A)')
     &' *** ERROR ***'//CHAR(7),
     &' record read not "QC2 SPH S" atom',
     &' produced by SPHPDB option of hole',
     &' Aborting!'//CHAR(7)
              LERR = .TRUE.
	      GOTO 55555
	    ENDIF
	  ENDIF

C have read an unrecognized record
        ELSE
	  WRITE( NOUT, '(A)')
     &' *** ERROR ***'//CHAR(7),
     &' record read not "QSS SPH S" atom',
     &' produced by SPHPDB option of hole',
     &' Aborting!'//CHAR(7)
          LERR = .TRUE.
	  GOTO 55555
	ENDIF

C read next record
	GOTO 10

20    CONTINUE
C end of do until loop end of input file reached
C - close it
      CLOSE( SIN)

      WRITE( NOUT, '(A,I5,A)')
     &' (Have read ', SPNO, ' records)'
      IF (NIGN.NE.0) WRITE( NOUT, '(A,I5,A)')
     &' (ignored a further ', NIGN, ' as too small)'

55555 RETURN
      END


MODULE param
  INTEGER,PARAMETER :: LMAX=   12
  INTEGER           :: nato=    0
  INTEGER           :: ndif=    0
  INTEGER           :: nume=    0
  INTEGER           :: nmat=    0
  INTEGER,PARAMETER :: NRAD=  881
  ! LOMAX must be = LOMAX in LAPW1 otherwise conflict in INIT
  INTEGER,PARAMETER :: LOMAX=   3
  INTEGER,PARAMETER :: FLMAX=   3
  INTEGER,PARAMETER :: LMAX2=  14
  ! LMX (not LMAX!) must be = LMAX in LAPW1 otherwise conflict in INIT
  INTEGER           :: LABC =    0
  INTEGER           :: LABC2=    0
  INTEGER,PARAMETER :: LMX =  LMAX+1
  INTEGER,PARAMETER :: LMX2=  LMX*LMX
  INTEGER,PARAMETER :: MMAX= 2*LMAX+1
  INTEGER           :: nume2=    0
  INTEGER           :: num2=     0
  REAL*8,PARAMETER  :: CLIGHT=137.0359895D0
  INTEGER           :: nloat=0
  INTEGER           :: nsym=0
  !rschmid
  !  Extension of relativistic local orbitals.
  !rschmid
  INTEGER,PARAMETER :: HBLOCK = 32
  INTEGER,PARAMETER :: NSLMAX=  5
  CHARACTER*180     :: filename_V_sp(2), filename_V_vns(2)
END MODULE param

MODULE abcd
  COMPLEX*16,ALLOCATABLE  :: abcdlm(:,:,:,:)
CONTAINS
  SUBROUTINE allocate_abcd(labc2,nloat,nume)
    ALLOCATE(abcdlm(nloat,labc2,nume,2))
    abcdlm=(0.0d0,0.0d0)
  END SUBROUTINE allocate_abcd
  SUBROUTINE deallocate_abcd
    DEALLOCATE(abcdlm)
  END SUBROUTINE deallocate_abcd
END MODULE abcd

MODULE ams
  REAL*8,ALLOCATABLE          :: atom_mass(:)
CONTAINS
  SUBROUTINE init_ams
    REAL*8          :: a_m(103)
    ALLOCATE(atom_mass(103))
    DATA a_m /1.,4.,6.9,9.,10.8,12.,14.,16.,19.,20.2, &
         23.,24.3,27.,28.1,31.,32.,35.4,40.,39.1,40.,45., &
         47.9,50.9,52.,54.9,55.8,58.9,58.7,63.5,65.4,69.7, &
         72.6,74.9,79.,79.9,83.8,85.5,87.6,88.9,91.2,92.9, &
         95.9,98.,101.1,102.9,106.4,107.9,112.4,114.8, &
         118.7,121.8,127.6,126.9,131.3,132.9,137.3,138.9,140.1, &
         140.9,144.2,145.,150.4,152.,157.3,158.9,162.5, &
         164.9,167.3,168.9,173.,175.,178.5,180.9,183.8,186.2, &
         190.2,192.2,195.1,197.,200.6,204.4,207.2,209.,209., &
         210.,222.,223.,226.,227.,232.,231.,238.,237.,244.,243., &
         247.,247.,251.,252.,257.,258.,259.,262./
    atom_mass(1:103) = a_m(1:103)
  END SUBROUTINE init_ams
END MODULE ams

MODULE couples
  COMPLEX*16,ALLOCATABLE  ::couplo(:,:,:,:,:,:)
CONTAINS
  SUBROUTINE allocate_couplo(ndif,labc)
    ALLOCATE(couplo(ndif,labc,-labc:labc,-labc:labc,2,2))
  END SUBROUTINE allocate_couplo
END MODULE couples

MODULE hmsout
  INTEGER                :: neig
  REAL*8,ALLOCATABLE     :: en(:),vnorm(:,:)
  COMPLEX*16,ALLOCATABLE :: vect(:,:,:)
CONTAINS
  SUBROUTINE allocate_hmsout(nmat,nume2)
    ALLOCATE(en(nume2),vnorm(nume2,2))
    ALLOCATE(vect(nmat,nume2,2))
    en=0.0d0; vnorm=0.0d0
    vect=(0.0d0,0.0d0)
  END SUBROUTINE allocate_hmsout
  SUBROUTINE deallocate_hmsout
    DEALLOCATE(vect)
    DEALLOCATE(en)
    DEALLOCATE(vnorm)
  END SUBROUTINE deallocate_hmsout
END MODULE hmsout

MODULE orb
  INTEGER                :: nmod,nsp,natorb,nonso,iorbpot
  INTEGER,ALLOCATABLE    :: iat(:),iiat(:),ll(:)
  REAL*8                 :: Bext
  COMPLEX*16,ALLOCATABLE :: vv(:,:,:,:)
CONTAINS
  SUBROUTINE allocate_orb(ndif)
    ALLOCATE(iat(3*ndif),iiat(3*ndif),ll(3*ndif))
    ALLOCATE(vv(3*ndif,-3:3,-3:3,3))
  END SUBROUTINE allocate_orb
END MODULE orb

MODULE loabc
  REAL*8,ALLOCATABLE  :: alo(:,:,:,:),blo(:,:,:,:),clo(:,:,:,:)
  REAL*8,ALLOCATABLE  :: dplo(:,:,:,:),dpelo(:,:,:,:),elo(:,:,:,:)
  REAL*8,ALLOCATABLE  :: peilo(:,:,:,:),pelo(:,:,:,:)
  REAL*8,ALLOCATABLE  :: plo(:,:,:,:),pi12lo(:,:,:,:),pe12lo(:,:,:,:)

CONTAINS
  SUBROUTINE allocate_loabc(lomax,nloat,nato)
    ALLOCATE(alo(0:lomax,nloat,nato,2),blo(0:lomax,nloat,nato,2),clo(0:lomax,nloat,nato,2))
    ALLOCATE(dplo(0:lomax,nato,2,nloat),dpelo(0:lomax,nato,2,nloat) ) !elo(0:lomax,nloat,nato,2))
    ALLOCATE(peilo(0:lomax,nato,2,nloat),pelo(0:lomax,nato,2,nloat))
    ALLOCATE(plo(0:lomax,nato,2,nloat),pi12lo(0:lomax,nato,2,nloat),pe12lo(0:lomax,nato,2,nloat))
  END SUBROUTINE allocate_loabc
END MODULE loabc

MODULE loabcr
  real*8,ALLOCATABLE  :: alor(:,:,:), blor(:,:,:)
  real*8,ALLOCATABLE  :: clor(:,:,:), dplor(:,:,:)
  real*8,ALLOCATABLE  :: dpelor(:,:,:), elor(:,:,:)
  real*8,ALLOCATABLE  :: peilor(:,:,:), pelor(:,:,:)
  real*8,ALLOCATABLE  :: plor(:,:,:)
  real*8,ALLOCATABLE  :: pi2lor(:,:,:),pe2lor(:,:,:)
  real*8,ALLOCATABLE  :: elor2(:,:,:)

CONTAINS
  SUBROUTINE allocate_loabcr(lomax,nato)
    ALLOCATE(alor(0:lomax,nato,2), blor(0:lomax,nato,2))
    ALLOCATE(clor(0:lomax,nato,2), dplor(0:lomax,nato,2))
    ALLOCATE(dpelor(0:lomax,nato,2), elor(0:lomax,nato,2))
    ALLOCATE(peilor(0:lomax,nato,2), pelor(0:lomax,nato,2))
    ALLOCATE(plor(0:lomax,nato,2))
    ALLOCATE(pi2lor(0:lomax,nato,2),pe2lor(0:lomax,nato,2))
    ALLOCATE(elor2(0:lomax,nato,2))
  END SUBROUTINE allocate_loabcr
END MODULE loabcr

MODULE lolog
  INTEGER,ALLOCATABLE :: nlo(:),nlov(:),nlon(:),ilo(:,:),mrf(:,:)
  LOGICAL,ALLOCATABLE :: loor(:,:),lapw(:,:),lso(:)

CONTAINS
  SUBROUTINE allocate_lolog(nato,lomax,lmax)
    ALLOCATE(nlo(nato),nlov(nato),nlon(nato),ilo(0:lomax,nato),mrf(0:lmax,nato))
    ALLOCATE(loor(0:lomax,nato),lapw(0:lmax,nato),lso(nato))
    lso=.true.
  END SUBROUTINE allocate_lolog
END MODULE lolog

MODULE radovlp
  real*8,ALLOCATABLE :: ruu (:,:,:,:,:,:)

CONTAINS
  SUBROUTINE allocate_radovlp(lmax,nato,nrf)
    ALLOCATE(ruu  (0:lmax,nato,2,2,nrf,nrf))
  END SUBROUTINE allocate_radovlp
END MODULE radovlp

MODULE rlolog
  INTEGER              :: nnrlo
  integer,ALLOCATABLE  :: nrlo(:),nrlov(:),nrlon(:)
  logical,ALLOCATABLE  :: loorext(:,:)

CONTAINS
  SUBROUTINE allocate_rlolog(nato,lomax)
    ALLOCATE(nrlo(nato),nrlov(nato),nrlon(nato))
    ALLOCATE(loorext(0:lomax,nato))
  END SUBROUTINE allocate_rlolog
END MODULE rlolog

MODULE rpars
  INTEGER,allocatable :: extl(:,:),nlr(:)
  REAL*8,ALLOCATABLE  :: extei(:,:),extde(:,:)
  CHARACTER*4,allocatable  :: extem(:,:)

CONTAINS
  SUBROUTINE allocate_rpars(nato,lomax)
    ALLOCATE(extl(nato, lomax),nlr(nato))
    ALLOCATE(extei(nato, lomax),extde(nato, lomax))
    ALLOCATE(extem(nato, lomax))
  END SUBROUTINE allocate_rpars
END MODULE rpars

MODULE rotmat
  REAL*8,ALLOCATABLE       :: det(:),phase(:)
  CONTAINS
    SUBROUTINE allocate_rotmat(ndif)
      ALLOCATE(det(ndif),phase(ndif))
    END SUBROUTINE allocate_rotmat
END MODULE rotmat

MODULE vns
  LOGICAL,ALLOCATABLE   :: lvns(:)
  INTEGER,ALLOCATABLE   :: nvns(:),mvns(:,:)
  REAL*8,ALLOCATABLE    :: vaa(:,:,:),vab(:,:,:),vad(:,:,:),vbb(:,:,:),vbd(:,:,:),vdd(:,:,:)
CONTAINS
  SUBROUTINE allocate_vns(nato)
    ALLOCATE(lvns(nato),nvns(nato),mvns(5,nato))
    ALLOCATE(vaa(nato,5,2),vab(nato,5,2),vad(nato,5,2),vbb(nato,5,2),vbd(nato,5,2),vdd(nato,5,2))
    lvns=.FALSE.
  END SUBROUTINE allocate_vns
END MODULE vns

MODULE peic
  REAL*8,ALLOCATABLE    :: pei(:,:,:)
CONTAINS
  SUBROUTINE allocate_peic(lmax,nato)
    ALLOCATE(pei(1:lmax+1,nato,2))
  END SUBROUTINE allocate_peic
END MODULE peic

MODULE hexpt
  REAL*8,ALLOCATABLE    :: hexl(:,:,:,:)
CONTAINS
  SUBROUTINE allocate_hexpt(lomax,nato)
    ALLOCATE(hexl(0:lomax,nato,2,9))
    hexl = 0.d0
  END SUBROUTINE allocate_hexpt
END MODULE hexpt

!------------------------------------------------------
!------------------------------------------------------
!------------------------------------------------------
module meigve_mod
  complex*16,allocatable :: meigve(:,:,:)
end module meigve_mod

!------------------------------------------------------
!------------------------------------------------------
!------------------------------------------------------

module store_vec
  complex*16,allocatable ::  vec(:,:)
end module store_vec


      subroutine rchyr

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine writes the annual reach output to the .rch file

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name         |units        |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    i            |julian date  |current day of simulation
!!    id1          |julian date  |first day of simulation in current year
!!    ilog         |none         |streamflow print code
!!                               |0 print streamflow in reach
!!                               |1 print Log10 streamflow in reach
!!    ipdvar(:)    |none         |output variable codes for .rch file
!!    isproj       |none         |special project code:
!!                               |1 test rewind (run simulation twice)
!!    itotr        |none         |number of output variables printed (.rch)
!!    iyr          |year         |current year of simulation (eg 1980)
!!    mrcho        |none         |maximum number of variables written to
!!                               |reach output file (.rch)
!!    rch_dakm(:)  |km**2        |total drainage area contributing to flow at
!!                               |the outlet (pour point) of the reach in
!!                               |square kilometers
!!    rchdy(37,:)  |mg pst       |amount of pesticide stored in river bed
!!                               |sediments
!!    rchyro(1,:)  |m^3/s        |flow into reach during year
!!    rchyro(2,:)  |m^3/s        |flow out of reach during year
!!    rchyro(3,:)  |metric tons  |sediment transported into reach during year
!!    rchyro(4,:)  |metric tons  |sediment transported out of reach during year
!!    rchyro(5,:)  |mg/L         |sediment concentration in outflow during year
!!    rchyro(6,:)  |kg N         |organic N transported into reach during year
!!    rchyro(7,:)  |kg N         |organic N transported out of reach during
!!                               |year
!!    rchyro(8,:)  |kg P         |organic P transported into reach during year
!!    rchyro(9,:)  |kg P         |organic P transported out of reach during
!!                               |year
!!    rchyro(10,:) |m^3/s        |evaporation from reach during year
!!    rchyro(11,:) |m^3/s        |transmission losses from reach during year
!!    rchyro(12,:) |kg           |conservative metal #1 transported out of reach
!!                               |during year
!!    rchyro(13,:) |kg           |conservative metal #2 transported out of reach
!!                               |during year
!!    rchyro(14,:) |kg           |conservative metal #3 transported out of reach
!!                               |during year
!!    rchyro(15,:) |kg N         |nitrate transported into reach during year
!!    rchyro(16,:) |kg N         |nitrate transported out of reach during year
!!    rchyro(17,:) |kg P         |soluble P transported into reach during year
!!    rchyro(18,:) |kg P         |soluble P transported out of reach during
!!                               |year
!!    rchyro(19,:) |mg pst       |soluble pesticide transported into reach
!!                               |during year
!!    rchyro(20,:) |mg pst       |soluble pesticide transported out of reach
!!                               |during year
!!    rchyro(21,:) |mg pst       |sorbed pesticide transported into reach during
!!                               |year
!!    rchyro(22,:) |mg pst       |sorbed pesticide transported out of reach
!!                               |during year
!!    rchyro(23,:) |mg pst       |amount of pesticide lost through reactions in
!!                               |reach during year
!!    rchyro(24,:) |mg pst       |amount of pesticide lost through
!!                               |volatilization from reach during year
!!    rchyro(25,:) |mg pst       |amount of pesticide settling out of reach to
!!                               |bed sediment during year
!!    rchyro(26,:) |mg pst       |amount of pesticide resuspended from bed
!!                               |sediment to reach during year
!!    rchyro(27,:) |mg pst       |amount of pesticide diffusing from reach to
!!                               |bed sediment during year
!!    rchyro(28,:) |mg pst       |amount of pesticide in sediment layer lost
!!                               |through reactions during year
!!    rchyro(29,:) |mg pst       |amount of pesticide in sediment layer lost
!!                               |through burial during year
!!    rchyro(30,:) |kg chla      |chlorophyll-a transported into reach during
!!                               |year
!!    rchyro(31,:) |kg chla      |chlorophyll-a transported out of reach during
!!                               |year
!!    rchyro(32,:) |kg N         |ammonia transported into reach during year
!!    rchyro(33,:) |kg N         |ammonia transported out of reach during year
!!    rchyro(34,:) |kg N         |nitrite transported into reach during year
!!    rchyro(35,:) |kg N         |nitrite transported out of reach during year
!!    rchyro(36,:) |kg O2        |CBOD transported into reach during year
!!    rchyro(37,:) |kg O2        |CBOD transported out of reach during year
!!    rchyro(38,:) |kg O2        |dissolved oxygen transported into reach during
!!                               |year
!!    rchyro(39,:) |kg O2        |dissolved oxygen transported out of reach
!!                               |during year
!!    rchyro(40,:) |kg bact      |persistent bacteria transported out of reach
!!                               |during year
!!    rchyro(41,:) |kg bact      |less persistent bacteria transported out of
!!                               |reach during year
!!    subgis(:)    |none         |GIS code printed to output files(output.sub,.rch)
!!    subtot       |none         |number of subbasins in watershed
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    idlast      |none          |number of days simulated in year
!!    ii          |none          |counter
!!    j           |none          |(counter) reach number
!!    pdvar(:)    |varies        |array of default reach output values
!!    pdvr(:)     |varies        |array of custom reach output values
!!    srch_av(:)  |varies        |annual reach inflow/outflow
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Real, Log10

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j
      real, dimension (mrcho) :: pdvar, pdvr
      real, dimension (2) :: srch_av

      idlast = 0
      idlast = i - (id1 - 1)

      do j = 1, subtot

        !! calculate annual averages where applicable
        rchyro(1,j) = rchyro(1,j) / Real(idlast)
        rchyro(2,j) = rchyro(2,j) / Real(idlast)
        rchyro(5,j) = rchyro(5,j) / Real(idlast)
        rchyro(10,j) = rchyro(10,j) / Real(idlast)
        rchyro(11,j) = rchyro(11,j) / Real(idlast)

        !! take log10 of annual inflow/outflow for graphing
        srch_av = 0.
        srch_av(1) = rchyro(1,j)
        srch_av(2) = rchyro(2,j)
        if (ilog > 0) then
          if (srch_av(1) > 1.) then
            srch_av(1) = Log10(srch_av(1))
          else
            srch_av(1) = 0.
          end if
          if (srch_av(2) > 1.) then
            srch_av(2) = Log10(srch_av(2))
          else
            srch_av(2) = 0.
          end if
        end if

        pdvar = 0.
        pdvr = 0.

        !! assign yearly values
        pdvar(1) = srch_av(1)        !!flow in (m^3/s)
        pdvar(2) = srch_av(2)        !!flow out (m^3/s)
        pdvar(3) = rchyro(10,j)      !!evaporation (m^3/s)
        pdvar(4) = rchyro(11,j)      !!tloss (m^3/s)
        pdvar(5) = rchyro(3,j)       !!sed in (metric tons)
        pdvar(6) = rchyro(4,j)       !!sed out (met tons)
        pdvar(7) = rchyro(5,j)       !!sed conc (mg/L)
        pdvar(8) = rchyro(6,j)       !!orgN in (kg N)
        pdvar(9) = rchyro(7,j)       !!orgN out (kg N)
        pdvar(10) = rchyro(8,j)      !!orgP in (kg P)
        pdvar(11) = rchyro(9,j)      !!orgP out (kg P)
        pdvar(12) = rchyro(15,j)     !!NO3 in (kg N)
        pdvar(13) = rchyro(16,j)     !!NO3 out (kg N)
        pdvar(14) = rchyro(32,j)     !!NH4 in (kg)
        pdvar(15) = rchyro(33,j)     !!NH4 out (kg)
        pdvar(16) = rchyro(34,j)     !!NO2 in (kg)
        pdvar(17) = rchyro(35,j)     !!NO2 out (kg)
        pdvar(18) = rchyro(17,j)     !!solP in (kg P)
        pdvar(19) = rchyro(18,j)     !!solP out (kg P)
        pdvar(20) = rchyro(30,j)     !!algae in (kg)
        pdvar(21) = rchyro(31,j)     !!algae out (kg)
        pdvar(22) = rchyro(36,j)     !!CBOD in (kg)
        pdvar(23) = rchyro(37,j)     !!CBOD out (kg)
        pdvar(24) = rchyro(38,j)     !!dis O2 in (kg)
        pdvar(25) = rchyro(39,j)     !!dis O2 out (kg)
        pdvar(26) = rchyro(19,j)     !!solpst in (mg pst)
        pdvar(27) = rchyro(20,j)     !!solpst out (mg pst)
        pdvar(28) = rchyro(21,j)     !!srbpst in (mg pst)
        pdvar(29) = rchyro(22,j)     !!srbpst out (mg pst)
        pdvar(30) = rchyro(23,j)     !!reacted pst (mg pst)
        pdvar(31) = rchyro(24,j)     !!volatilized pst (mg)
        pdvar(32) = rchyro(25,j)     !!pst settling (mg pst)
        pdvar(33) = rchyro(26,j)     !!pst resuspension (mg)
        pdvar(34) = rchyro(27,j)     !!pst diffuse to sed mg
        pdvar(35) = rchyro(28,j)     !!react pst/sed (mg)
        pdvar(36) = rchyro(29,j)     !!pst bury (mg)
        pdvar(37) = rchdy(37,j)      !!pst in rivbed sed mg
        pdvar(38) = rchyro(40,j)     !!p bact out
        pdvar(39) = rchyro(41,j)     !!lessp bact out
        pdvar(40) = rchyro(12,j)     !!metal #1
        pdvar(41) = rchyro(13,j)     !!metal #2
        pdvar(42) = rchyro(14,j)     !!metal #3
 !! added for Total N (org N + no3 + no2 + nh4 outs) to output.rch gsm 10/17/2011
        pdvar(43) = rchyro(7,j)+ rchyro(16,j) + rchyro(35,j) +
     *   rchyro(33,j)                                                  !! Total N
 !! added for Total P (org P + sol p outs)to output.rch gsm 10/17/2011
        pdvar(44) = rchyro(9,j) + rchyro(18,j)                        !! Total P
 !! added NO3 Concentration to output.rch (for daily only) gsm 10/26/2011

         if (ipdvar(1) > 0) then
          do ii = 1, itotr
            pdvr(ii) = pdvar(ipdvar(ii))
          end do
          if (iscen == 1 .and. isproj == 0) then
          write (7,5000) j, subgis(j), iyr, rch_dakm(j),
     &                                    (pdvr(ii), ii = 1, itotr)
          else if (isproj == 1) then
          write (20,5000) j, subgis(j), iyr, rch_dakm(j),
     &                                    (pdvr(ii), ii = 1, itotr)
          else if (iscen == 1 .and. isproj == 2) then
          write (7,6000) j, subgis(j), iyr, rch_dakm(j),
     &                             (pdvr(ii), ii = 1, itotr), iyr
          endif
        else
     !!  increase to 44 in loops below from 42 gsm 10/17/2011
          if (iscen == 1 .and. isproj == 0) then
          write (7,5000) j, subgis(j), iyr, rch_dakm(j),
     &                                (pdvar(ii), ii = 1, 44)
          else if (isproj == 1) then
          write (20,5000) j, subgis(j), iyr, rch_dakm(j),
     &                                (pdvar(ii), ii = 1, 44)
          else if (iscen == 1 .and. isproj == 2) then
          write (7,6000) j, subgis(j), iyr, rch_dakm(j),
     &                             (pdvar(ii), ii = 1, 44), iyr

          endif
        end if
      end do

      return
 5000 format ('REACH ',i4,1x,i8,1x,i5,47e12.4)
 6000 format ('REACH ',i4,1x,i8,1x,i5,47e12.4,1x,i4)
      end


! (C) Copyright 2017-2020 Met Office
!
! this software is licensed under the terms of the apache licence version 2.0
! which can be obtained at http://www.apache.org/licenses/license-2.0.

!> The main Fortran module for implementing the rttov onedvar check

module ufo_rttovonedvarcheck_mod

use fckit_configuration_module, only: fckit_configuration
use fckit_log_module, only : fckit_log
use iso_c_binding
use kinds
use missing_values_mod
use obsspace_mod
use oops_variables_mod
use ufo_geovals_mod
use ufo_metoffice_bmatrixstatic_mod
use ufo_metoffice_rmatrixradiance_mod
use ufo_radiancerttov_mod
use ufo_rttovonedvarcheck_constants_mod
use ufo_rttovonedvarcheck_minimize_utils_mod
use ufo_rttovonedvarcheck_minimize_newton_mod
use ufo_rttovonedvarcheck_minimize_ml_mod
use ufo_rttovonedvarcheck_ob_mod
use ufo_rttovonedvarcheck_obs_mod
use ufo_rttovonedvarcheck_profindex_mod
use ufo_rttovonedvarcheck_rsubmatrix_mod
use ufo_rttovonedvarcheck_setup_mod
use ufo_rttovonedvarcheck_utils_mod
use ufo_vars_mod

implicit none
private
public :: ufo_rttovonedvarcheck_create
public :: ufo_rttovonedvarcheck_delete
public :: ufo_rttovonedvarcheck_apply

! ------------------------------------------------------------------------------
contains
! ------------------------------------------------------------------------------
!> Setup the main rttov onedvar object in Fortran
!!
!! \details Makes a call to the main setup routine.
!!
!! \author Met Office
!!
!! \date 09/06/2020: Created
!!
subroutine ufo_rttovonedvarcheck_create(self, obsspace, f_conf, channels, &
                                        onedvarflag, passflag)

  implicit none
  type(ufo_rttovonedvarcheck), intent(inout) :: self         !< rttovonedvarcheck main object
  type(c_ptr), value, intent(in)             :: obsspace     !< observation database pointer
  type(fckit_configuration), intent(in)      :: f_conf       !< yaml file contents
  integer(c_int), intent(in)                 :: channels(:)  !< all channels that can be used in 1D-Var
  integer(c_int), intent(in)                 :: onedvarflag  !< flag from qc flags
  integer(c_int), intent(in)                 :: passflag     !< pass flag from qc flags

  self % obsdb = obsspace
  self % onedvarflag = onedvarflag
  self % passflag = passflag

  call ufo_rttovonedvarcheck_setup(self, f_conf, channels) ! from init

end subroutine ufo_rttovonedvarcheck_create

! ------------------------------------------------------------------------------
!> Delete the main rttov onedvar object in Fortran
!!
!! \author Met Office
!!
!! \date 09/06/2020: Created
!!
subroutine ufo_rttovonedvarcheck_delete(self)

  implicit none
  type(ufo_rttovonedvarcheck), intent(inout) :: self !< rttovonedvarcheck main object

  if (allocated(self % retrieval_variables)) deallocate(self % retrieval_variables)
  if (allocated(self % channels))            deallocate(self % channels)

end subroutine ufo_rttovonedvarcheck_delete

! ------------------------------------------------------------------------------
!> The main routine that applys the rttov onedvar filter
!!
!! \details Heritage : Ops_SatRad_Do1DVar_RTTOV12.f90
!!
!! This routine is called from the c++ apply method.  The filter performs
!! a 1D-Var minimization using rttov
!!
!! \author Met Office
!!
!! \date 09/06/2020: Created
!!
subroutine ufo_rttovonedvarcheck_apply(self, f_conf, vars, hofxdiags_vars, geovals, apply)
  use ufo_utils_mod, only: cmp_strings

  implicit none
  type(ufo_rttovonedvarcheck), intent(inout) :: self     !< rttovonedvarcheck main object
  type(fckit_configuration), intent(in)      :: f_conf       !< yaml file contents
  type(oops_variables), intent(in)           :: vars     !< channels for 1D-Var
  type(oops_variables), intent(in)           :: hofxdiags_vars !< retrieval variables for 1D-Var
  type(ufo_geovals), intent(in)              :: geovals  !< model values at observation space
  logical, intent(in)                        :: apply(:) !< qc manager flags

  type(ufo_rttovonedvarcheck_obs)        :: obs             ! data for all observations read from db
  type(ufo_metoffice_bmatrixstatic)      :: full_bmatrix    ! full bmatrix read from file
  type(ufo_geovals)                      :: local_geovals   ! geoval for one observation
  type(ufo_rttovonedvarcheck_ob)         :: ob              ! observation data for a single observation
  type(ufo_rttovonedvarcheck_profindex)  :: prof_index      ! index for mapping geovals to 1d-var state profile
  type(ufo_rttovonedvarcheck_profindex)  :: local_profindex ! local copy of prof_index needed since the intro. of mwemiss
  type(ufo_metoffice_rmatrixradiance)    :: full_rmatrix    ! full r_matrix read from file
  type(ufo_rttovonedvarcheck_rsubmatrix) :: r_submatrix     ! r_submatrix object
  type(ufo_geovals)                      :: hofxdiags       ! hofxdiags containing jacobian
  type(ufo_geoval), pointer          :: geoval
  character(len=max_string)          :: sensor_id
  character(len=max_string)          :: var
  character(len=max_string)          :: varname
  character(len=max_string)          :: message
  integer                            :: jvar, ivar, jobs, band, ii ! counters
  integer                            :: nchans_used      ! counter for number of channels used for an ob
  integer                            :: jchans_used
  integer                            :: fileunit        ! unit number for reading in files
  integer                            :: apply_count
  integer                            :: nprofelements   ! number of elements in 1d-var state profile
  integer, allocatable               :: fields_in(:)
  real(kind_real)                    :: missing         ! missing value
  real(kind_real)                    :: t1, t2          ! timing
  real(kind_real), allocatable       :: b_matrix(:,:)   ! 1d-var profile b matrix
  real(kind_real), allocatable       :: b_inverse(:,:)  ! inverse for each 1d-var profile b matrix
  real(kind_real), allocatable       :: b_sigma(:)      ! b_matrix diagonal error
  real(kind_real), allocatable       :: max_error(:)    ! max_error = error(stdev) * factor
  logical                            :: file_exists     ! check if a file exists logical
  logical                            :: onedvar_success
  logical                            :: cloud_retrieval = .false.
  type(ufo_radiancerttov)            :: rttov_simobs
  integer(c_size_t), allocatable     :: ret_nlevs(:)

  ! ------------------------------------------
  ! 1. Setup
  ! ------------------------------------------
  missing = missing_value(missing)

  ! Setup rttov simobs
  call rttov_simobs % setup(f_conf, self % channels)

  ! Setup full B matrix object
  call full_bmatrix % setup(self % retrieval_variables, self % b_matrix_path, &
                            self % qtotal)

  ! Setup full R matrix object
  call full_rmatrix % setup(self % r_matrix_path)

  ! Check if cloud retrievals needed
  do ii = 1, size(self % retrieval_variables)
    if (cmp_strings(self % retrieval_variables(ii), "cloud_top_pressure")) then
      write(*,*) "Simple cloud is part of the state vector"
      cloud_retrieval = .true.
    end if
  end do

  ! Create profile index for mapping 1d-var profile to b-matrix
  call prof_index % setup(full_bmatrix, self % nlevels)

  ! sanity check on clw storage - only store to obs space
  ! if qtotal or ql is present in retrieval vector
  if (self % Store1DVarCLW) then
    if ((prof_index % qt(1) == 0) .and. (prof_index % ql(1) == 0)) then
      write(message,*) "Info: as qtotal or ql are not part of the state vector resetting Store1DVarCLW to false"
      self % Store1DVarCLW = .false.
    end if
  end if

  ! Read in observation data from obsspace
  ! geovals are only providing surface information
  call obs % setup(self, prof_index % nprofelements, geovals, vars)

  ! Initialize data arrays
  allocate(b_matrix(prof_index % nprofelements,prof_index % nprofelements))
  allocate(b_inverse(prof_index % nprofelements,prof_index % nprofelements))
  allocate(b_sigma(prof_index % nprofelements))
  allocate(ret_nlevs(hofxdiags_vars % nvars()))

  ! Decide on loop parameters - testing
  if (self % StartOb == 0) self % StartOb = 1
  if (self % FinishOb == 0) self % FinishOb = obs % iloc
  if (self % StartOb > self % FinishOb) then
    write(message,*) "start loop ",self % StartOb," is greater than finish loop ",self % FinishOb
    call abor1_ftn(message)
  end if

  ! Calculate hofxdiags levels for each variable
  call ufo_rttovonedvarcheck_hofxdiags_levels(hofxdiags_vars, self % nlevels, ret_nlevs)

  ! ------------------------------------------
  ! 2. Beginning main observation loop
  ! ------------------------------------------
  write(*,*) "Beginning loop over observations: ",trim(self%qcname)
  apply_count = 0
  obs_loop: do jobs = self % StartOb, self % FinishOb
    if (apply(jobs)) then

      obs % output_to_db(jobs) = .true.
      apply_count = apply_count + 1
      write(message, *) "starting obs number    ",jobs
      call fckit_log % debug(message)

      ! Needs copying for each ob since mwemiss introduced
      call local_profindex % copy(prof_index)
      !---------------------------------------------------
      ! 2.1 Setup Jb terms
      !---------------------------------------------------
      ! create one ob geovals from full obs geovals and check
      ! to make sure the values are within sensible bounds.
      call ufo_geovals_copy_one(local_geovals, geovals, jobs)
      call ufo_rttovonedvarcheck_check_geovals(self, local_geovals, &
              local_profindex, obs % surface_type(jobs))

      ! create b matrix arrays for this single observation location
      call full_bmatrix % reset( obs % lat(jobs), & ! in
                    b_matrix, b_inverse, b_sigma  ) ! out

      ! adjust b matrix based on tskin error and if mwemiss is in local_profindex
      ! check that we are over land
      call ufo_rttovonedvarcheck_adjust_bmatrix(local_profindex, & ! inout
           obs, jobs, self,                                      & ! in
           b_matrix, b_inverse, b_sigma)                           ! inout

      !---------------------------------------------------
      ! 2.2 Setup Jo terms
      !---------------------------------------------------
      ! Channel selection based on previous filters flags
      nchans_used = 0
      do jvar = 1, self%nchans
        if( obs % QCflags(jvar,jobs) == self % passflag ) then
          nchans_used = nchans_used + 1
        end if
      end do
      if (nchans_used == 0) then
        write(message, *) "No channels selected for observation number ", &
               jobs, " : skipping"
        call fckit_log % debug(message)
        cycle obs_loop
      end if

      ! setup ob data for this observation
      call ob % setup(nchans_used, self %  nlevels, local_profindex % nprofelements, self % nchans, self % Store1DVarCLW)

      ob % forward_mod_name = self % forward_mod_name
      ob % latitude = obs % lat(jobs)
      ob % longitude = obs % lon(jobs)
      ob % elevation = obs % elevation(jobs)
      ob % sensor_zenith_angle = obs % sat_zen(jobs)
      ob % sensor_azimuth_angle = obs % sat_azi(jobs)
      ob % solar_zenith_angle = obs % sol_zen(jobs)
      ob % solar_azimuth_angle = obs % sol_azi(jobs)
      ob % channels_all = self % channels
      ob % surface_type = obs % surface_type(jobs)
      ob % retrievecloud = cloud_retrieval
      ob % pcemis => obs % ir_pcemis
      ob % calc_emiss = obs % calc_emiss(jobs)
      ob % emiss(:) = obs % emiss(:, jobs)
      if(self % RTTOV_mwscattSwitch) ob % mwscatt = .true.
      if(self % RTTOV_usetotalice) ob % mwscatt_totalice = .true.

      ! Store background T in ob data space
      call ufo_geovals_get_var(local_geovals, var_ts, geoval)
      ob % background_T(:) = geoval%vals(:, 1) ! K

      ! Create ob vector and r matrix
      jchans_used = 0
      do jvar = 1, self%nchans
        if( obs % QCflags(jvar,jobs) == self % passflag ) then
          jchans_used = jchans_used + 1
          ob % yobs(jchans_used) = obs % yobs(jvar, jobs)
          ob % channels_used(jchans_used) = self % channels(jvar)
        end if
      end do
      call r_submatrix % setup(nchans_used, ob % channels_used, full_rmatrix=full_rmatrix)

      ! Setup hofxdiags for this retrieval
      call ufo_geovals_setup(hofxdiags, hofxdiags_vars, 1, hofxdiags_vars % nvars(), ret_nlevs)

      if (self % FullDiagnostics) then
        call ob % info()
        call r_submatrix % info()
        write(*, *) "Observations used = ",ob % yobs(:)
        write(*,*) "ob % emiss = ",ob % emiss
        write(*,*) "ob % calc_emiss = ",ob % calc_emiss
        write(*,*) "Channel selection = "
        write(*,'(15I5)') ob % channels_used
        write(*,*) "All Channels = "
        write(*,'(15I5)') ob % channels_all
      end if

      !---------------------------------------------------
      ! 2.3 Call minimization
      !---------------------------------------------------
      if (self % UseMLMinimization) then
        call ufo_rttovonedvarcheck_minimize_ml(self, ob, &
                                      r_submatrix, b_matrix, b_inverse, b_sigma, &
                                      local_geovals, hofxdiags, rttov_simobs, &
                                      local_profindex, onedvar_success)
      else
        call ufo_rttovonedvarcheck_minimize_newton(self, ob, &
                                      r_submatrix, b_matrix, b_inverse, b_sigma, &
                                      local_geovals, hofxdiags, rttov_simobs, &
                                      local_profindex, onedvar_success)
      end if

      obs % output_BT(:, jobs) = ob % output_BT(:)
      obs % background_BT(:, jobs) = ob % background_BT(:)
      obs % output_profile(:,jobs) = ob % output_profile(:)
      obs % emiss(:, jobs) = ob % emiss(:)
      obs % final_cost(jobs) = ob % final_cost
      obs % LWP(jobs) = ob % LWP
      if (self % store1dvarclw) obs % CLW(:,jobs) = ob % CLW(:)
      obs % niter(jobs) = ob % niter

      ! Set QCflags based on output from minimization
      if (.NOT. onedvar_success) then
        do jvar = 1, self%nchans
          if( obs % QCflags(jvar,jobs) == 0 ) then
            obs % QCflags(jvar,jobs) = self % onedvarflag
          end if
        end do
      end if

      ! Check the BTs are within a factor of the error
      if (self % RetrievedErrorFactor > 0.0 .and. any(obs % QCflags(:,jobs) == 0)) then
        allocate(max_error(size(ob % channels_used)))
        call r_submatrix % multiply_factor_by_stdev(self % RetrievedErrorFactor, max_error)
        if (any(abs(ob % final_bt_diff(:)) > max_error(:))) then
          do jvar = 1, self % nchans
            if( obs % QCflags(jvar,jobs) == 0 ) then
              obs % QCflags(jvar,jobs) = self % onedvarflag
            end if
          end do
        end if
        deallocate(max_error)
      end if

      ! Tidy up memory specific to a single observation
      call ufo_geovals_delete(local_geovals)
      call ufo_geovals_delete(hofxdiags)
      call ob % delete()
      call r_submatrix % delete()

    else
      call fckit_log % debug("Final 1Dvar cost, apply = F")

    endif
  end do obs_loop

  !---------------------------------------------------
  ! 3.0 Return variables and tidy up
  !---------------------------------------------------

  write(message, *) "Total number of observations = ", obs % iloc
  call fckit_log % info(message)
  write(message, *) "Number tested by 1dvar = ", apply_count
  call fckit_log % info(message)

  ! Put qcflags and output variables into observation space
  call obs % output(self % obsdb, prof_index, vars, self % nchans)

  ! Tidy up memory used for all observations
  call full_bmatrix % delete()
  call full_rmatrix % delete()
  call obs % delete()
  if (allocated(b_matrix))  deallocate(b_matrix)
  if (allocated(b_inverse)) deallocate(b_inverse)
  if (allocated(b_sigma))   deallocate(b_sigma)
  if (allocated(ret_nlevs)) deallocate(ret_nlevs)
  call rttov_simobs % delete()

end subroutine ufo_rttovonedvarcheck_apply

end module ufo_rttovonedvarcheck_mod


module da_setup_structures

   !---------------------------------------------------------------------------
   ! Purpose: Sets up various structures.
   !---------------------------------------------------------------------------

   use da_wavelet, only: lf,namw,nb,nij,ws
   use module_domain, only : xb_type, ep_type, domain

   use da_define_structures, only : xbx_type,be_subtype, be_type, y_type, j_type, &
      iv_type,da_allocate_background_errors,da_allocate_observations, &
      multi_level_type,each_level_type, da_allocate_observations_rain
   use da_define_structures, only : da_allocate_obs_info, da_allocate_y, da_allocate_y_radar, &
      da_allocate_y_rain
   use da_wrf_interfaces, only : wrf_debug, &
      wrf_dm_bcast_string, wrf_dm_bcast_integer, wrf_dm_bcast_real
   use da_control, only : trace_use,vert_evalue,stdout,rootproc, myproc, &
      analysis_date,coarse_ix,coarse_ds,map_projection,coarse_jy, c2,dsm,phic, &
      pole, cone_factor, start_x,base_pres,ptop,psi1,start_y, base_lapse,base_temp,truelat2_3dv, &
      truelat1_3dv,xlonc,t0,num_fft_factors,pi,print_detail_spectral, global, print_detail_obs, &
      use_radar_rf, use_radar_rhv, use_radar_rqv, &
      num_ob_indexes,kts, kte, time_window_max, time_window_min, &
      max_fgat_time, num_fgat_time, dt_cloud_model, &
      use_ssmiretrievalobs,use_radarobs,use_ssmitbobs,use_qscatobs, num_procs, use_rainobs, &
      num_pseudo, missing, ob_format, ob_format_bufr,ob_format_ascii, ob_format_madis, ob_format_gpsro, &
      use_airepobs, use_tamdarobs, test_dm_exact, use_amsuaobs, use_amsubobs, &
      use_airsobs, use_bogusobs, sfc_assi_options, use_eos_amsuaobs, &
      use_filtered_rad, use_gpsrefobs, use_hirs2obs, &
      use_hsbobs,use_hirs3obs, use_gpspwobs, use_gpsztdobs, use_metarobs, use_msuobs, &
      use_kma1dvar,use_pilotobs, use_polaramvobs, use_rad, crtm_cloud, use_soundobs,use_mtgirsobs, &
      use_ssmt1obs,use_ssmt2obs, use_shipsobs, use_satemobs, use_synopobs, &
      use_radar_rv,use_profilerobs, use_obsgts, use_geoamvobs, use_buoyobs, &
      jb_factor, je_factor, alphacv_method,its,ite,jts,jte,cv_size_domain_jb, cv_size_domain_jl, &
      cv_size_domain_je, cv_size_domain,ensdim_alpha, alpha_vertloc_opt, alpha_hydrometeors, &
      lat_stats_option,alpha_std_dev,sigma_alpha,alpha_corr_scale, &
      len_scaling1, len_scaling2, len_scaling3, len_scaling4, len_scaling5,&
      len_scaling6, len_scaling7, len_scaling8, len_scaling9, &
      len_scaling10, len_scaling11, &
      max_vert_var1, max_vert_var2, max_vert_var3, max_vert_var4, max_vert_var5, &
      max_vert_var6, max_vert_var7, max_vert_var8, max_vert_var9, max_vert_var10,&
      max_vert_var11, max_vert_var_alpha, &
      print_detail_be, test_statistics, do_normalize, use_rf, &
      var_scaling1, var_scaling2, var_scaling3, var_scaling4, &
      var_scaling5, var_scaling6, var_scaling7, var_scaling8, &
      var_scaling9, var_scaling10, var_scaling11,&
      vert_corr,max_vert_var5,power_truncation,alpha_truncation, &
      print_detail_regression,gas_constant, use_airsretobs, &
      filename_len, use_ssmisobs, gravity, t_triple, use_hirs4obs, use_mhsobs, &
      use_mwtsobs, use_mwhsobs, use_mwhs2obs, use_atmsobs, &
      vert_corr_2, alphacv_method_xa, vert_evalue_global, &
      vert_evalue_local, obs_names, thin_conv, thin_conv_ascii, &
      sound, sonde_sfc, mtgirs, tamdar, tamdar_sfc, synop, profiler, gpsref, gpspw, polaramv, geoamv, ships, metar, &
      satem, radar, ssmi_rv, ssmi_tb, ssmt1, ssmt2, airsr, pilot, airep, rain, &
      bogus, buoy, qscat, radiance, pseudo, trace_use_dull, kts,kte, &
      use_simulated_rad, use_pseudo_rad, pseudo_rad_platid, pseudo_rad_satid, &
      pseudo_rad_senid, rtminit_nsensor, rtminit_platform, rtminit_satid, &
      rtminit_sensor, thinning, qc_rad, var4d, &
      num_pseudo,pseudo_x, pseudo_y, pseudo_z, pseudo_var,pseudo_val, pseudo_err, pseudo_time, &
      fg_format, fg_format_wrf_arw_regional,fg_format_wrf_nmm_regional, &
      fg_format_wrf_arw_global, fg_format_kma_global, deg_to_rad, rad_to_deg, &
      sonde_sfc, missing_data, missing_r, qc_good, thin_mesh_conv, time_slots, ifgat_ana, &
      cv_options, cloud_cv_options, cv_size, as1, as2, as3, as4, as5, print_detail_be, &
      ids,ide,jds,jde,kds,kde, ims,ime,jms,jme,kms,kme, &
      its,ite,jts,jte,kts,kte, ips,ipe,jps,jpe,kps,kpe, root, comm, ierr, &
      fmt_info, fmt_srfc, fmt_each, unit_end, max_ext_its, &
      psi_chi_factor, psi_t_factor, psi_ps_factor, psi_rh_factor, &
      chi_u_t_factor, chi_u_ps_factor,chi_u_rh_factor, t_u_rh_factor, ps_u_rh_factor, &
      interpolate_stats, be_eta, thin_rainobs, fgat_rain_flags, use_iasiobs, &
      use_seviriobs, jds_int, jde_int, anal_type_hybrid_dual_res, use_amsr2obs, nrange, use_4denvar, &
      use_goesimgobs, use_ahiobs
   use da_control, only: rden_bin, use_lsac
   use da_control, only: use_cv_w
   use da_control, only: pseudo_tpw, pseudo_ztd, pseudo_ref, pseudo_uvtpq, pseudo_elv, anal_type_qcobs
   use da_control, only: use_gpsephobs, gpseph_loadbalance, gpseph
   use da_control, only: ep_format

   use da_obs, only : da_fill_obs_structures, da_store_obs_grid_info, da_store_obs_grid_info_rad, &
                      da_fill_obs_structures_rain, da_fill_obs_structures_radar, da_set_obs_missing,da_set_3d_obs_missing
   use da_obs_io, only : da_read_obs_bufr,da_read_obs_radar, &
      da_scan_obs_radar,da_scan_obs_ascii,da_read_obs_ascii, &
      da_read_obs_bufrgpsro, da_scan_obs_rain, da_read_obs_rain, &
      da_read_obs_lsac, da_scan_obs_lsac, da_read_obs_bufrgpsro_eph
   use da_par_util1, only : da_proc_sum_real, da_proc_sum_int, da_proc_sum_ints
   use da_par_util, only : da_patch_to_global
   use da_lapack, only : dsyev
#if defined(RTTOV) || defined(CRTM)
   use da_radiance, only : da_setup_radiance_structures
#endif
   use da_reporting, only : da_error, message, da_warning, da_message
   use da_recursive_filter, only : da_calculate_rf_factors
   use da_spectral, only : da_initialize_h,da_calc_power_spectrum
   use da_ssmi, only : da_read_obs_ssmi,da_scan_obs_ssmi
   use da_tools_serial, only : da_get_unit, da_free_unit, da_array_print, da_find_fft_factors, &
      da_find_fft_trig_funcs
   use da_tools, only: da_get_time_slots, da_1d_eigendecomposition, da_eof_decomposition
   use da_tracing, only : da_trace_entry, da_trace_exit
   use da_vtox_transforms, only : da_check_eof_decomposition
   use da_rfz_cv3, only : da_rfz0
   use da_rf_cv3, only : RFDPAR1, RFDPAR2, RFDPARV
   use module_radiance, only : init_constants_derived
   use gsi_thinning, only : r999,r360,rlat_min,rlat_max,rlon_min,rlon_max, &
                            dlat_grid,dlon_grid,thinning_grid_conv,thinning_grid, &
                            make3grids, makegrids, destroygrids, destroygrids_conv, cleangrids_conv
#ifdef DM_PARALLEL
!  use mpi, only : mpi_min, mpi_max
   use da_par_util, only : true_mpi_real
#endif

   implicit none

#ifdef DM_PARALLEL
   include 'mpif.h'
#endif

contains

#include "da_get_vertical_truncation.inc"
#include "da_interpolate_regcoeff.inc"
#include "da_rescale_background_errors.inc"
#include "da_scale_background_errors.inc"
#include "da_scale_background_errors_cv3.inc"
#include "da_setup_background_errors.inc"
#include "da_setup_be_global.inc"
#include "da_setup_be_ncep_gfs.inc"
#include "da_setup_be_regional.inc"
#include "da_setup_be_nmm_regional.inc"
#include "da_setup_cv.inc"
#include "da_chgvres.inc"
#include "da_setup_flow_predictors.inc"
#include "da_setup_flow_predictors_para_read_opt1.inc"
#include "da_setup_flow_predictors_ep_format2.inc"
#include "da_setup_flow_predictors_ep_format3.inc"
#include "da_setup_obs_structures.inc"
#include "da_setup_obs_structures_ascii.inc"
#include "da_setup_obs_structures_bufr.inc"
#include "da_setup_obs_structures_madis.inc"
#include "da_setup_obs_structures_rain.inc"
#include "da_setup_obs_structures_radar.inc"
#include "da_setup_pseudo_obs.inc"
#include "da_setup_obs_interp_wts.inc"
#include "da_setup_runconstants.inc"
#include "da_cloud_model.inc"
#include "da_lcl.inc"
#include "da_cumulus.inc"
#include "da_qfrmrh.inc"
#include "da_write_increments.inc"
#include "da_write_increments_for_wrf_nmm_regional.inc"
#include "da_write_kma_increments.inc"
#include "da_get_bins_info.inc"
#include "da_truncate_spectra.inc"
#include "da_chg_be_Vres.inc"
#include "da_gen_eigen.inc"
#include "da_eigen_to_covmatrix.inc"
#include "da_get_alpha_vertloc.inc"

end module da_setup_structures