C=======================================================================
C  SG_PHENOL, Subroutine
C
C  Determines phenological stage for sorghum
C-----------------------------------------------------------------------
C  Revision history
C
C  12/31/1996 GH  Deleted phenology statements.
C  02/07/1993 PWW Header revision and minor changes
C  02/07/1993 PWW Added switch block, code cleanup
C  02/07/1993 PWW Modified TT calculations to reduce line #'s
C  07/31/2002 WDB Converted to modular format
C  12/14/2005 CHP Added phenology revisions from P.S.Traore
C                 Added alternate cultivar coefficients for Traore method
C  02/07/2007 JWW Added P9 calculation
C  01/15/2008 GH  Include GDDE for P9 calculation
C  01/16/2008 GH  Rename DJTI to P2 and move to cultivar file
C  01/16/2008 GH  Add cultivar coefficient PANTH
C  06/01/2007 GH  Add P-model (unfinished)
C  01/06/2014 MA  Change to couple the P model
C-----------------------------------------------------------------------
C  INPUT  : YRDOY
C
C  LOCAL  : I, L,L0,XANC,TEMPCN,TEMPCX,XS,TDIF,TCOR,
C           TTMP,YDL,DEC,DLV,CHGDL,SWSD,PDTT,RATEIN,PFLOWR,PSKER,
C           YIELDB,TWILEN,BARFAC,ABSTRES
C
C  OUTPUT : STGDOY
C-----------------------------------------------------------------------
C  Called : SG_CERES
C
C  Calls  : SG_PHASEI SG_COLD
C-----------------------------------------------------------------------
C
C                         DEFINITIONS
C
C  STGDOY :
C  YRDOY  :
C  NOUTDO :
C=======================================================================

      SUBROUTINE SG_PHENOL (DYNAMIC,
     & APTNUP,BIOMAS,BIOMS2,CSD1, CSD2,
     & CNSD1, CNSD2, CTYPE, CUMDEP, DLAYR, DTT,
     & EMAT, G1, G2, GDDE, GNUP, GPP, GPSM, GRAINN, GRNWT, ICSDUR,
     & IDETO, IDUR1, IPRINT, ISDATE, ISTAGE, ISWNIT, ISWWAT,
     & LAI, LEAFNO, LL, MAXLAI, MDATE, NOUTDO, NLAYR,
     & P1, P2O, P2R, P3, P4, P5, P9, PANTH, PANWT, PGRNWT, PHINT,
     & PBASE, PSAT, PFLOWR,
     & PLTPOP, ROPT, RTDEP, SDEPTH, SI1, SI2, SI3,
     & SI4, SIND, SKERWT, SNOW, SRAD, STGDOY,STMWT, STOVER, STOVN,
     & SUMDTT, SW, TANC, TBASE, TEMPCR, TMAX, TMIN,
     & TOPT,TOTNUP, TPSM, YIELD, YRDOY,XGNP, XSTAGE,
C      Variables passed through PHENOL to phasei but not used in phenol
     & AGEFAC, BIOMS1, CUMDTT, CUMPH, GROLF,
     & GRORT, GROSTM, LFWT, LWMIN, MGROLF, MGROPAN, MGROSTM,
     & MLFWT, MPANWT, MSTMWT, NSTRES, PAF,
     & PGC, PLA, PLAN, PLAO, PLATO, PLAY, PLAMX, PTF, RANC,
     & RLV, ROOTN, RTWT, RWU, SEEDRV, SENLA, SLAN,
     & STOVWT, SUMRTR, SWMAX, SWMIN, TCARBO, TCNP, TDUR, TGROLF,
     & TGROPAN, TGROSTM, TILN, TLFWT, TLNO, TMNC,
     & TPANWT, TSIZE, TSTMWT, VANC, VMNC,
     & XNTI,SWFAC,TURFAC,DGET,SWCG,P2,
     & DAYL, TWILEN, CANWAA, CANNAA,CUMP4,
     & SeedFrac, VegFrac)

      USE ModuleDefs
      IMPLICIT  NONE
      SAVE
C -----------------------------------------------------------------------
C VARIABLES ONLY USED IN PHASEI. THEY ARE PASSED THROUGH PHENOL TO PHASEI
C------------------------------------------------------------------------
      REAL AGEFAC
      REAL BIOMS1
      REAL CUMDTT
      REAL CUMPH
      REAL DGET
      REAL GROLF
      REAL GRORT
      REAL GROSTM
      REAL LFWT
      REAL LWMIN
      REAL MGROLF
      REAL MGROPAN
      REAL MGROSTM
      REAL MLFWT
      REAL MPANWT
      REAL MSTMWT
      REAL NSTRES
      REAL PAF
      REAL PGC
      REAL PLA
      REAL PLAN
      REAL PLAO
      REAL PLATO
      REAL PLAY
      REAL PLAMX
      REAL PTF
      REAL RANC
      REAL RLV(NL)
      REAL ROOTN
      REAL RTWT
      REAL RWU(NL)
      REAL SEEDRV
      REAL SENLA
      REAL SLAN
      REAL STOVWT
      REAL SUMRTR
      REAL SWCG
      REAL SWFAC
      REAL SWMAX
      REAL SWMIN
      REAL TCARBO
      REAL TCNP
      REAL TDUR
      REAL TGROLF
      REAL TGROPAN
      REAL TGROSTM
      REAL TILN
      REAL TLFWT
      REAL TLNO
      REAL TMNC
      REAL TPANWT
      REAL TSIZE
      REAL TSTMWT
      REAL TURFAC
      REAL VANC
      REAL VMNC
      REAL XNTI
C------------------------------------------------------------------------
C   VARIABLES IN OLD COMMON BLOCKS
C------------------------------------------------------------------------

      REAL APTNUP
      REAL BIOMAS
      REAL BIOMS2
      REAL CANNAA
      REAL CANWAA
      REAL CSD1
      REAL CSD2
      REAL CNSD1
      REAL CNSD2
      INTEGER CTYPE
      REAL CUMDEP
C-GH  REAL DJTI
      REAL P2, CUMP2, CUMP4, PANTH
      REAL DLAYR(NL)
      REAL DTT
      REAL EMAT
      REAL G1
      REAL G2
      REAL GDDE
      REAL GNUP
      REAL GPP
      REAL GPSM
      REAL GRAINN
      REAL GRNWT
      INTEGER ICSDUR
      CHARACTER*1 IDETO
      INTEGER IDUR1
      INTEGER IPRINT
      INTEGER ISDATE
      INTEGER ISTAGE
      CHARACTER*1 ISWNIT
      CHARACTER*1 ISWWAT
      REAL LAI
      INTEGER LEAFNO
      REAL LL(NL)
      REAL MAXLAI
      INTEGER MDATE
      INTEGER NOUTDO
      INTEGER NLAYR
      REAL P1
      REAL P2O
      REAL P2R
      REAL P3
      REAL P4
      REAL P5
      REAL P9
      REAL PANWT
      REAL PGRNWT
      REAL PHINT
      REAL PLTPOP
      REAL ROPT
      REAL RTDEP
      REAL SDEPTH
      REAL SI1(6)
      REAL SI2(6)
      REAL SI3(6)
      REAL SI4(6)
      REAL SIND
      REAL SKERWT
      REAL SNOW
      REAL SRAD
      REAL STMWT
      REAL STOVER
      REAL STOVN
      REAL SUMDTT
      REAL SW(NL)
      REAL TANC
      REAL TBASE
      REAL TEMPCR
      REAL TMAX
      REAL TMIN
      REAL TOPT
      REAL TOTNUP
      REAL TPSM
      REAL YIELD
      REAL XGNP
      REAL XSTAGE

C------------------------------------------------------------------------
C     LOCAL VARIABLES
C------------------------------------------------------------------------
      INTEGER   STGDOY(20),YRDOY,I, L,L0
      REAL      XANC,TEMPCN,TEMPCX,XS,
     +          SWSD,PDTT,RATEIN,PFLOWR,
     +          YIELDB,TWILEN
      REAL      DAYL,ACOEF,TNSOIL,TDSOIL,TMSOIL
      REAL      TH,DOPT

!     Variables needed to send messages to WARNING.OUT
      CHARACTER*78 MESSAGE(10)

!     Variables added for sorghum methods PST/CHP
      REAL PBASE, PSAT
!     Added for P model
      REAL SeedFrac, VegFrac
      REAL SUMDTT_2, SUMDTT_3

      INTEGER DYNAMIC
!----------------------------------------------------------------------
!         DYNAMIC = RUNINIT OR DYNAMIC = SEASINIT
! ---------------------------------------------------------------------
      IF (DYNAMIC.EQ.RUNINIT.OR.DYNAMIC.EQ.SEASINIT) THEN
      SeedFrac = 0.0
      VegFrac  = 0.0
      SUMDTT_2 = 0.0
      SUMDTT_3 = 0.0

!----------------------------------------------------------------------
!         DYNAMIC = RATE OR INTEGRATE
! ---------------------------------------------------------------------

      ELSE

C--------------------------------------------------------------------
C                         MAIN CODE
C--------------------------------------------------------------------
      XANC   = TANC*100.0
      APTNUP = STOVN*10.0*PLTPOP
      TOTNUP = APTNUP

      !--------------------------------------------------------------
      !Compute thermal time based on new method developed by J.T.R
      !at CYMMIT, 5/5/98.  TBASE, TOPT, and ROPT are read in from
      ! the species file, as is CTYPE (Cereal type).
      !--------------------------------------------------------------

      !Initially, set TEMPCN and TEMPCS to TMAX and TMIN

      TEMPCN = TMIN
      TEMPCX = TMAX
      XS     = SNOW
      XS     = AMIN1 (XS,15.0)

      !--------------------------------------------------------------
      ! Calculate crown temperature based on temperature and snow cover
      !--------------------------------------------------------------
      IF (TMIN .LT. 0.0) THEN
         TEMPCN = 2.0 + TMIN*(0.4+0.0018*(XS-15.0)**2)
      ENDIF
      IF (TMAX .LT. 0.0) THEN
         TEMPCX = 2.0 + TMAX*(0.4+0.0018*(XS-15.0)**2)
      ENDIF
      TEMPCR = (TEMPCX + TEMPCN)/2.0
      !
      ! DOPT, Devlopment optimum temperature, is set to TOPT during
      ! vegetative growth and to ROPT after anthesis
      !
      DOPT = TOPT
      IF ((ISTAGE .GT. 3) .AND. (ISTAGE .LE. 6)) THEN
         DOPT = ROPT
      ENDIF
      !
      ! Check basic temperature ranges and calculate DTT for
      ! develpment based on PC with JTR
      !
      IF (TMAX .LT. TBASE) THEN
         DTT = 0.0
       ELSEIF (TMIN .GT. DOPT) THEN
         !
         ! This statement replaces DTT = TOPT ...
         !    GoL and LAH, CIMMYT, 1999
         !
         DTT = DOPT - TBASE
         !
         ! Now, modify TEMPCN, TEMPCX based on soil conditions or snow
         ! If wheat and barley is before terminal spiklett stage
         ! Or if corn and sorghum are before 10 leaves
         !
       ELSEIF ((CTYPE .EQ. 1 .AND. LEAFNO .LE. 10) .OR.
     &         (CTYPE .EQ. 2 .AND. ISTAGE .LT. 2)) THEN
         !
         ! Check for snow  (should following be GT.0 or GT.15 ?).
         ! Based on snow cover, calculate DTT for the day
         !
         IF (XS .GT. 0.0) THEN
            !
            ! Snow on the ground
            !
            DTT    = (TEMPCN + TEMPCX)/2.0 - TBASE
          ELSE
            !
            ! No snow, compute soil temperature
            !
            ACOEF  = 0.01061 * SRAD + 0.5902
            TDSOIL = ACOEF * TMAX + (1.0 - ACOEF) * TMIN
            TNSOIL = 0.36354 * TMAX + 0.63646 * TMIN
            IF (TDSOIL .LT. TBASE) THEN
               DTT = 0.0
             ELSE
               IF (TNSOIL .LT. TBASE) THEN
                  TNSOIL = TBASE
               ENDIF
               IF (TDSOIL .GT. DOPT) THEN
                  TDSOIL = DOPT
               ENDIF

!     chp - import DAYL from Weather module instead
               TMSOIL = TDSOIL * (DAYL/24.) + TNSOIL * ((24.-DAYL)/24.)
               IF (TMSOIL .LT. TBASE) THEN
                  DTT = (TBASE+TDSOIL)/2.0 - TBASE
                ELSE
                  DTT = (TNSOIL+TDSOIL)/2.0 - TBASE
               ENDIF
               !
               ! Statement added ... GoL and LAH, CIMMYT, 1999
               !
               DTT = AMIN1 (DTT,DOPT-TBASE)
            ENDIF
         ENDIF
         !
         ! Now, compute DTT for when Tmax or Tmin out of range
         !
       ELSEIF (TMIN .LT. TBASE .OR. TMAX .GT. DOPT) THEN
          DTT = 0.0
          DO I = 1, 24
             TH = (TMAX+TMIN)/2. + (TMAX-TMIN)/2. * SIN(3.14/12.*I)
             IF (TH .LT. TBASE) THEN
                TH = TBASE
             ENDIF
             IF (TH .GT. DOPT) THEN
                TH = DOPT
             ENDIF
             DTT = DTT + (TH-TBASE)/24.0
          END DO
       ELSE
          DTT = (TMAX+TMIN)/2.0 - TBASE
      ENDIF

      SUMDTT  = SUMDTT  + DTT
      CUMDTT = CUMDTT + DTT
      CSD1   = CSD1 + 1.0 - SWFAC
      CSD2   = CSD2 + 1.0 - TURFAC
      CNSD1 = CNSD1 + 1.0-NSTRES
      CNSD2 = CNSD2 + 1.0-AGEFAC
      ICSDUR = ICSDUR + 1

C--------------------------------------------------------------------
C       Definition of Stages
C
C     7 - Sowing date
C     8 - Germination
C     9 - Emergence
C     1 - End juvenile
C     2 - Pannicle initiation
C     3 - End of flag leaf expansion
C     4 - Beginning of grain filling
C     5 - Grain fill
C     6 - Maturity
C--------------------------------------------------------------------

C--------------------------------------------------------------------
C         ISTAGE = 7: Determine when sowing date occurs
C--------------------------------------------------------------------
      IF (ISTAGE .EQ. 7) THEN
          STGDOY(ISTAGE) = YRDOY

          CALL SG_PHASEI (
     &    AGEFAC, BIOMAS, BIOMS1, BIOMS2, CNSD1, CNSD2,
     &    CSD2, CSD1, CUMDEP, CUMDTT, CUMPH, CUMP2, CUMP4, DLAYR,
     &    DTT, EMAT, G1, G2, GPP, GRAINN, GRNWT,
     &    GROLF, GRORT, GROSTM, ICSDUR, IDUR1,
     &    ISTAGE, ISWWAT,ISWNIT,LAI, LEAFNO, LFWT, LWMIN, MGROLF,
     &    MGROPAN,MGROSTM, MLFWT, MPANWT, MSTMWT, NLAYR,
     &    NSTRES, P3, P4, P9, PAF, PANWT, PGC, PHINT, PLA, PLAN, PLAO,
     &    PLATO, PLAY, PLAMX, PLTPOP, PTF, RANC, PANTH, PFLOWR,
     &    RLV, ROOTN, RTDEP, RTWT, RWU, SDEPTH, SEEDRV, SENLA,
     &    SIND, SLAN, STMWT, STOVN, STOVWT, SUMRTR, SWMAX,
     &    SWMIN, TANC, TCARBO, TCNP, TDUR, TGROLF, TGROPAN,
     &    TGROSTM, TILN, TLFWT, TLNO, TMNC, TPANWT,
     &    TPSM, TSIZE, TSTMWT, SUMDTT, VANC,
     &    VMNC, XNTI,P2O, P2R, TWILEN)

          IF (ISWWAT .EQ. 'N') RETURN

          CUMDEP         = 0.0
          DO L = 1, NLAYR
             CUMDEP = CUMDEP + DLAYR(L)
             IF (SDEPTH .LT. CUMDEP) GO TO 100       ! Was EXIT
          END DO

  100     CONTINUE                                   ! Sun Fix

          L0 = L
          RETURN

C--------------------------------------------------------------------
C      ISTAGE = 8: Determine Germination Date
C--------------------------------------------------------------------
       ELSEIF (ISTAGE .EQ. 8) THEN
          IF (ISWWAT .NE. 'N') THEN
             IF (SW(L0) .LE. LL(L0)) THEN
                 SWSD = (SW(L0)-LL(L0))*0.65 + (SW(L0+1)-LL(L0+1))*0.35
                 IF (SWSD .LT. SWCG) RETURN
             ENDIF
          ENDIF

          STGDOY(ISTAGE) = YRDOY
          IPRINT = 0

          CALL SG_PHASEI (
     &    AGEFAC, BIOMAS, BIOMS1, BIOMS2, CNSD1, CNSD2,
     &    CSD2, CSD1, CUMDEP, CUMDTT, CUMPH, CUMP2, CUMP4, DLAYR,
     &    DTT, EMAT, G1, G2, GPP, GRAINN, GRNWT,
     &    GROLF, GRORT, GROSTM, ICSDUR, IDUR1,
     &    ISTAGE, ISWWAT,ISWNIT,LAI, LEAFNO, LFWT, LWMIN, MGROLF,
     &    MGROPAN,MGROSTM, MLFWT, MPANWT, MSTMWT, NLAYR,
     &    NSTRES, P3, P4, P9, PAF, PANWT, PGC, PHINT, PLA, PLAN, PLAO,
     &    PLATO, PLAY, PLAMX, PLTPOP, PTF, RANC, PANTH, PFLOWR,
     &    RLV, ROOTN, RTDEP, RTWT, RWU, SDEPTH, SEEDRV, SENLA,
     &    SIND, SLAN, STMWT, STOVN, STOVWT, SUMRTR, SWMAX,
     &    SWMIN, TANC, TCARBO, TCNP, TDUR, TGROLF, TGROPAN,
     &    TGROSTM, TILN, TLFWT, TLNO, TMNC, TPANWT,
     &    TPSM, TSIZE, TSTMWT, SUMDTT, VANC,
     &    VMNC, XNTI,P2O, P2R, TWILEN)

!         JWW 2/7/07
          P9    = 50.0 +  6.0*SDEPTH
C-GH
          P9    = 50.0 +  GDDE * SDEPTH
          RETURN

C--------------------------------------------------------------------
C      ISTAGE = 9: Determine seedling emergence date
C--------------------------------------------------------------------
       ELSEIF (ISTAGE .EQ. 9) THEN
          RTDEP  = RTDEP + 0.15*DTT
          IDUR1  = IDUR1 + 1
          IF (SUMDTT .LT. P9) RETURN
          IF (P9 .GT. DGET) THEN
             ISTAGE = 6
             PLTPOP = 0.00
             GPP    = 1.0
             GRNWT  = 0.0

             WRITE(MESSAGE(1),1399)
             CALL WARNING(1, 'SGPHEN', MESSAGE)
             WRITE (     *,1399)
             IF (IDETO .EQ. 'Y') THEN
                WRITE (NOUTDO,1399)
             ENDIF
             MDATE = YRDOY
             RETURN
          ENDIF

          STGDOY(ISTAGE) = YRDOY

          CALL SG_PHASEI (
     &    AGEFAC, BIOMAS, BIOMS1, BIOMS2, CNSD1, CNSD2,
     &    CSD2, CSD1, CUMDEP, CUMDTT, CUMPH, CUMP2, CUMP4, DLAYR,
     &    DTT, EMAT, G1, G2, GPP, GRAINN, GRNWT,
     &    GROLF, GRORT, GROSTM, ICSDUR, IDUR1,
     &    ISTAGE, ISWWAT,ISWNIT,LAI, LEAFNO, LFWT, LWMIN, MGROLF,
     &    MGROPAN,MGROSTM, MLFWT, MPANWT, MSTMWT, NLAYR,
     &    NSTRES, P3, P4, P9, PAF, PANWT, PGC, PHINT, PLA, PLAN, PLAO,
     &    PLATO, PLAY, PLAMX, PLTPOP, PTF, RANC, PANTH, PFLOWR,
     &    RLV, ROOTN, RTDEP, RTWT, RWU, SDEPTH, SEEDRV, SENLA,
     &    SIND, SLAN, STMWT, STOVN, STOVWT, SUMRTR, SWMAX,
     &    SWMIN, TANC, TCARBO, TCNP, TDUR, TGROLF, TGROPAN,
     &    TGROSTM, TILN, TLFWT, TLNO, TMNC, TPANWT,
     &    TPSM, TSIZE, TSTMWT, SUMDTT, VANC,
     &    VMNC, XNTI,P2O, P2R, TWILEN)
          RETURN

C--------------------------------------------------------------------
C        ISTAGE = 1: Determine end of juvenile stage
C--------------------------------------------------------------------
       ELSEIF (ISTAGE .EQ. 1) THEN
          XSTAGE = 2. * SUMDTT / P1
          IDUR1  = IDUR1 + 1

C     For P model, we need to estimate the fraction of time completed
C     between emergence and tassel initiation, VegFrac.  Because stage 2
C     (end of juvenile stage to tassel initiation) completion is not
C     based on physiological time, but rather on daylight hours, we
C     will make the assumption that the physical duration of that phase
C     is 10 days at optimum temperature.

!  VegFrac = SUMDTT / (P1 + 10. * (DOPT - TBASE) + P3 + P4)
! MA 06-07jan2014, change to 20 days ( 10 is too few)
! VegFrac is now defined from emergence to beginning of grain filling
! VegFrac includes P1, P2 adapted according to P2R with should includes  PANTH( with P3)
         VegFrac = SUMDTT /(P1 +P2R + PANTH +P4)

        IF (SUMDTT .LT. P1) RETURN
        STGDOY(ISTAGE) = YRDOY

C -------------------------------------------------------------------
C         ISTAGE = 2: Determine date of panicle initiation
C-MA from end of juvenile to tassel inititiation (P2 adapted to PP)
C--------------------------------------------------------------------
       ELSEIF (ISTAGE .EQ. 2) THEN
          XSTAGE = 2.0 + SIND
          IDUR1  = IDUR1 + 1
          PDTT   = DTT
          IF (ISWWAT .EQ. 'N') THEN
             ICSDUR = ICSDUR + 1
             ENDIF
          IF (ICSDUR .EQ. 1) THEN
             PDTT = SUMDTT - P1
          ENDIF

!        Add option for using PBASE, PSAT.  If these parameters
!           are present (non-zero) then use alternate method.
         IF (PBASE < 1.E-2 .OR. PSAT < 1.E-2) THEN

C-GH-2008
C        Revised calculation of degree days to panicle initiation
C          Total degree days to panicle initiation is a function of
C          the basic degree days under optimum conditions and short
C          daylengths (P2) plus the delay due the number of hours
C          above the critical daylength (P2R * (TWILEN - P2O))
C          Panicle initation occurs when the total number of
C          degree days since the end of juvenile phase (CUMP2)
C          is greater than the minimum number of required
C          degree days (P2 + P2R * (TWILEN - P2O))
C
C          Original method
C
           IF (TWILEN > P2O) THEN
C-GH         RATEIN = 1. / (P2 +  P2R * (TWILEN - P2O))
             RATEIN = P2 +  P2R * (TWILEN - P2O)
           ELSE
C-GH         RATEIN = 1. / P2
             RATEIN = P2
           ENDIF
C-GH       SIND = SIND + RATEIN * PDTT
           CUMP2 = CUMP2 + PDTT
           SIND = AMAX1(SIND,CUMP2/RATEIN)

!         -----------------------------------------------------------
!        Threshold hyperbolic option
         ELSE     !
           IF (TWILEN > PSAT) THEN
             RATEIN = (TWILEN - PBASE) / (P1 *(PSAT - PBASE))
           ELSE
             RATEIN = 1. / P1
           ENDIF
           SIND = RATEIN * SUMDTT
         ENDIF

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

C-MA         IF (SUMDTT .GT. (P1 + 10. * (DOPT - TBASE))) THEN
C-MA              VegFrac = SUMDTT / (SUMDTT + P3 + P4)
C-MA           ELSE
C-MA              VegFrac = SUMDTT / (P1 + 10. * (DOPT - TBASE) + P3 + P4)
C-MA          ENDIF

         ! MA 06jan2014 !
          VegFrac = SUMDTT /(P1 + P2R+ PANTH +P4)

C-GH     IF (SIND .LT. 1.0) RETURN
         IF (CUMP2 .LT. RATEIN) RETURN

         IF (CUMP2 .LT. RATEIN) THEN
           RETURN
        ELSE
              STGDOY(ISTAGE) = YRDOY
              SUMDTT_2 = SUMDTT  ! SUMDTT_2 = p1 + adapted P2 without PANTH --MA
              VegFrac= max (VegFrac,SUMDTT_2/(SUMDTT_2+PANTH+P4))
        ENDIF

C--------------------------------------------------------------------
C         ISTAGE = 3: Determine end of flag leaf expansion
C                     [formerly end of leaf growth]
C-MA from tassel initiation to end of leaf growth (PANTH-P3)
C--------------------------------------------------------------------

          ELSEIF (ISTAGE .EQ. 3) THEN
          IDUR1 = IDUR1 + 1
C-GH      XSTAGE = 3.0 + 2.0*SUMDTT/P3
          XSTAGE = 3.0 + 2.0*SUMDTT/(PANTH - P3)
C-MA      VegFrac = (SUMDTT + SUMDTT_2) / (SUMDTT_2 + P3 + P4)
          VegFrac = max (VegFrac,(SUMDTT_2+ SUMDTT)/
     &              (SUMDTT_2 + PANTH+P4))
C-MA          SeedFrac = SUMDTT / (P3 + P4 + P5)

C-GH      IF (SUMDTT .LT. P3) THEN
          IF (SUMDTT .LT. (PANTH - P3)) THEN
            RETURN
          ELSE
            STGDOY(ISTAGE) = YRDOY
            MAXLAI = LAI
            SUMDTT_3 = SUMDTT_2 + SUMDTT ! SUMDDT_3 = P1 +P2 adapted + (PANTH -P3)
            VegFrac = max (VegFrac,SUMDTT_3 /
     &                       (SUMDTT_3 + P3+P4))
          ENDIF

C--------------------------------------------------------------------
C         ISTAGE = 4: Determine beginning grain filling
C                     [formerly end of panicle growth]
C-MA from end leaf growth to beginning of grain filling, including P3+P4
C--------------------------------------------------------------------
       ELSEIF (ISTAGE .EQ. 4) THEN
C--------------------------------------------------------------------
C                     Determine beginning anthesis
C                     No ISTAGE
C--------------------------------------------------------------------
C-GH      PFLOWR = 2.5*PHINT+30.0
          IF (TWILEN .GT. P2O) THEN
            PFLOWR = P3 +  P2R * (TWILEN - P2O)
          ELSE
            PFLOWR = P3
          ENDIF

          XSTAGE = 5.0 + SUMDTT/PFLOWR
          IF (SUMDTT .LE. PFLOWR) THEN
             IDUR1 = IDUR1 + 1
          ENDIF

          IF (SUMDTT .GE. PFLOWR .AND. IPRINT .EQ. 0) THEN
             STGDOY(16)     = YRDOY
             CANNAA = STOVN*PLTPOP
             CANWAA = BIOMAS
             BIOMS2 = BIOMAS/PLTPOP
             ISDATE = YRDOY
             IPRINT = 1
          ENDIF

          CUMP4 = CUMP4 + DTT

!      VegFrac = MAX(VegFrac,(SUMDTT + SUMDTT_2) /
!     & (SUMDTT_2 + (PANTH)+P4))
       VegFrac = max(VegFrac,(SUMDTT + SUMDTT_3)/(SUMDTT_3+ PFLOWR+P4))
C-MA           SeedFrac = (SUMDTT + P3) / (P3 + P4 + P5)

          IF (SUMDTT .LT. (PFLOWR + P4)) THEN
            RETURN
          ELSE
            STGDOY(ISTAGE) = YRDOY
            VegFrac = 1.0

            IF (GPP .LE. 0.0) THEN
              GPP   = 1.0
            ENDIF
          ENDIF
C--------------------------------------------------------------------
C        ISTAGE = 5: Determine end of effective grain filling period
C--------------------------------------------------------------------
       ELSEIF (ISTAGE .EQ. 5) THEN
	       CUMP4 = CUMP4 + DTT
             XSTAGE = 6.5 + 2.5*SUMDTT/P5
C-MA             SeedFrac = (SUMDTT + P3 + P4) / (P3 + P4 + P5)
             SeedFrac = SUMDTT / (P5)

             IF (SUMDTT .LT. P5) RETURN
             SeedFrac = 1.0

C--------------------------------------------------------------------
C       ISTAGE = 6: Determine physiological maturity
C--------------------------------------------------------------------
       ELSEIF (ISTAGE .EQ. 6) THEN
          IF (DTT    .LT. 2.0) RETURN
          IF (SUMDTT .LT. 2.0) RETURN
          STGDOY(ISTAGE) = YRDOY
          IPRINT         = 0
          MDATE          = YRDOY
          GRNWT  = PANWT  * 0.8
          GRAINN = GRAINN - 0.2  * PANWT*TANC
          STOVN  = STOVN  + 0.2  * PANWT*TANC
          APTNUP = STOVN  * 10.0 * PLTPOP
          YIELD  = GRNWT*10.0*PLTPOP

          IF (PLTPOP .NE. 0.0) THEN
             IF (GPP .LE. 0.0) THEN
                GPP = 1.0
                ENDIF
             SKERWT = GRNWT/GPP
             GPSM = GPP*PLTPOP
             STOVER  = BIOMAS*10.0-YIELD
             YIELDB  = YIELD/62.8
             PGRNWT = SKERWT*1000.0
             PGRNWT = GRNWT/GPP*1000.0
             IF (ISWNIT .EQ. 'N') THEN
                XGNP = 0.0
                GNUP = 0.0
              ELSE
                IF (GRNWT .GT. 0.0) THEN
                   XGNP = (GRAINN/GRNWT)*100.0
                   GNUP = GRAINN*PLTPOP*10.0
                ENDIF
             ENDIF

             TOTNUP      = GNUP + APTNUP
             SI1(ISTAGE) = 0.0
             SI2(ISTAGE) = 0.0
             SI3(ISTAGE) = 0.0
             SI4(ISTAGE) = 0.0
          ENDIF
      ENDIF       !End of main ISTAGE Logic

C--------------------------------------------------------------------
C     This code is run at the beginning of ISTAGE 1, 2, 3, 4, 5, 6
C
C     This code is NOT run for ISTAGE 7, 8, or 9 due to the RETURN
C     statements in the above sections of code for ISTAGE 7, 8, and 9
C--------------------------------------------------------------------

      IF (ISWWAT .NE. 'N'.AND.ISTAGE.GT.0) THEN
         SI1(ISTAGE) = CSD1  / ICSDUR
         SI2(ISTAGE) = CSD2  / ICSDUR
         SI3(ISTAGE) = CNSD1 / ICSDUR
         SI4(ISTAGE) = CNSD2 / ICSDUR
      ENDIF

      CALL SG_PHASEI (
     &    AGEFAC, BIOMAS, BIOMS1, BIOMS2, CNSD1, CNSD2,
     &    CSD2, CSD1, CUMDEP, CUMDTT, CUMPH, CUMP2, CUMP4, DLAYR,
     &    DTT, EMAT, G1, G2, GPP, GRAINN, GRNWT,
     &    GROLF, GRORT, GROSTM, ICSDUR, IDUR1,
     &    ISTAGE, ISWWAT,ISWNIT,LAI, LEAFNO, LFWT, LWMIN, MGROLF,
     &    MGROPAN,MGROSTM, MLFWT, MPANWT, MSTMWT, NLAYR,
     &    NSTRES, P3, P4, P9, PAF, PANWT, PGC, PHINT, PLA, PLAN, PLAO,
     &    PLATO, PLAY, PLAMX, PLTPOP, PTF, RANC, PANTH, PFLOWR,
     &    RLV, ROOTN, RTDEP, RTWT, RWU, SDEPTH, SEEDRV, SENLA,
     &    SIND, SLAN, STMWT, STOVN, STOVWT, SUMRTR, SWMAX,
     &    SWMIN, TANC, TCARBO, TCNP, TDUR, TGROLF, TGROPAN,
     &    TGROSTM, TILN, TLFWT, TLNO, TMNC, TPANWT,
     &    TPSM, TSIZE, TSTMWT, SUMDTT, VANC,
     &    VMNC, XNTI,P2O, P2R, TWILEN)

! ----------------------------------------------------------------------
!          ENDIF            ! End Dynamic Loop
! ----------------------------------------------------------------------

      ENDIF  ! End DYNAMIC STRUCTURE
      RETURN

C-----------------------------------------------------------------------
C     Format Strings
C-----------------------------------------------------------------------

1399  FORMAT (10X,'Seed ran out of metabolite due to deep planting')

      END SUBROUTINE SG_PHENOL


!! SFM 05/06/2013  Modifications from LW to facilitate using job names
!! SFM 07/19/2013  Modifications from ngniM.Grecu for convergence problem
!! SFM 08/09/2013  Eliminate IF2ADPROUT dependences; few extra diagnostics
!!
!microwave table freq 19.0 37. 10. 85
!TMIchannel freq  10.0, 19.0, 21, 37, 85! V,H
!npol 0 H, npol 1 V

SUBROUTINE init_random_seed(rseed1, rseed2)
  INTEGER :: rseed1, rseed2, n, clock
  INTEGER, DIMENSION(:), ALLOCATABLE :: seed

  CALL RANDOM_SEED(size = n)
  ALLOCATE(seed(n))

  if(rseed1.le.-1) then
    ! Don't set seed - what delivered code does.
  elseif(rseed1.eq.0) then
    CALL SYSTEM_CLOCK(COUNT=clock)
    seed = clock + 37 * (/ (i - 1, i = 1, n) /)
    CALL RANDOM_SEED(PUT = seed)
  else
    seed = rseed1 + 37 * (/ (i - 1, i = 1, n) /)
    if(rseed2.gt.0) then
      seed(2) = rseed2
    endif
    CALL RANDOM_SEED(PUT = seed)
  endif

  CALL RANDOM_SEED(GET = seed)
  rseed1 = seed(1)
  rseed2 = seed(2)
  DEALLOCATE(seed)
END SUBROUTINE init_random_seed

SUBROUTINE init_random_seed2()
  INTEGER :: i, n, clock
  INTEGER, DIMENSION(:), ALLOCATABLE :: seed

  CALL RANDOM_SEED(size = n)
  ALLOCATE(seed(n))

  CALL SYSTEM_CLOCK(COUNT=clock)

  seed = clock + 37 * (/ (i - 1, i = 1, n) /)
  CALL RANDOM_SEED(PUT = seed)

  DEALLOCATE(seed)
END SUBROUTINE init_random_seed2

subroutine mainfortpy()

  use iso_c_binding    !iso c binding statement
  use globalData
  use emissmod
  use nbinmod
  use missingMod
  use Tables_frac

  implicit none
  integer :: rseed1, rseed2, ifs
  real :: tbRgrid(14,49,9300)  ! resampled brightness temperatures on same grid
                              !   as 2adpr data; (channel/ray/scan)

  character(c_char) :: jobname(255), f1ctmi1(1000), f1ctmi2(1000), &
       f1ctmi3(1000), f2AKu(1000), f2aDPR(1000), f2AKuENV(1000), f2CMB(1000)
  character(c_char) :: fSNOW(1000), fSEAICE(1000)
  character(c_char) :: outcmb(1000) !iso c binding

  integer :: igmi1, igmi2, igmi3, i2AKu, i2ADPR, i2AKuENV, i2CMB, ialg
  integer :: iSNOW, iSEAICE
  integer :: i1ctmi, i1c21, i2a23
  real    :: mu
  integer :: nGMIS1, nGMIS2, nS1f, nS2f, nchunks
  character*3 :: ifdpr
  INTEGER*4 :: orbitNumber    ! retrieved orbit number
  integer :: ngmi1,ngmi2,ngmi3, j
  integer :: isnow1, iseaice1, ndpr1
  real    :: lastGood          !  SFM  04/16/2014   added for M.Grecu

  character*90 :: lut_file !SJM 7/9/2014

  character(16), parameter :: algorithmVersion = "2BCMB_20180919"
  integer    :: date(3)=(/0,0,0/), istat,    kk1, kk2
  integer(1) :: autosnow(9000,4500)                 !4km global grid

  INTEGER :: nscan_2akuenv, nray2akuenv, nbin2akuenv, nwater, nwind

  INTEGER*4     date_number      ! file date in format yyyymmdd
  INTEGER*4     month_get        ! computed file month
  INTEGER*4     st_1, st_2, st_3 ! status codes for 1CGMI files

  INTEGER*4     readgmi, readtmi         ! declare function
  INTEGER*4     readenv, readenvx          ! declare function
  INTEGER*4     readdprpflag, readdprpflagx     ! declare function
  INTEGER*4     readdprtpflag     ! declare function

  integer*4     i, ifract, idir
  real :: x1L, x2L

  rec=0

  mu=cos(52.8/180*3.14159)
  do i=1,7
     !call mie2(i-3.)
  enddo

  nmfreq=8
  nmu=5
  call init_random_seed(rseed1,rseed2)
  print *, 'Random Seeds : ',rseed1,rseed2
  print*, ialg

  call readtablesLiang2(nmu,nmfreq)         !This option reads in Liang's mu=2 table

  call makeHashTables()
  call cloud_init(nmfreq)
  call initWFlag(nmfreq)
  call init_nbin
  call init_missing_flags

  nmF=4
  if(.not.(allocated(ip))) &
       allocate(ip(nMF), iGMIChan(nMF), iSimF(nMF), iGMIf(nMF))

  nPrScanM = 300; ngates=nbin; ndPRrays=49;
  nGMIMax  = 3700; nGMIS1=9; nGMIS2=4; nGMIrays=221;
  gridData%dx=0.05

  nMemb=50
  ifdpr(1:1)='N'

  !call read_geodat(geoData%lsflag, geoData%sstdata)

  nS1f=9
  nS2f=4
  ngmi_total = 0

  call allocatecGMISpace(gMIData, nS1f, nS2f, nGMIrays, nGMIMax, nmfreq, nmemb)

  !call readwfract()

!-----------------------
  nBSize=300
  call allocateDPRSpace(dPRData, ngates, ndPRrays, nPRScanM)

  call param_set_BMCV(5)
  iStart=1

  iEnd=1
  dx=0

  tbRgrid=-99             ! set to default

  nchunks=int(ndpr/300)
  if(nchunks*300==ndpr) nchunks=nchunks-1
end subroutine mainfortpy

subroutine do_chunkpy(i,ialg, idir)
  use globalData
  implicit none

  integer :: i, ialg
  integer :: ifract, idir, j
  real :: x1L, x2L
  INTEGER*4     readenv, readenvx
  real :: dprrain(49,300)
  print*,'ichunk=', i, nMemb, istart
  ic=i*nBSize
  !jobnamec(1)='j'
  !jobnamec(2)='u'
  !jobnamec(3)='n'
  !jobnamec(4)='k'

end subroutine do_chunkpy

subroutine getzs(zku,zka,nx,ny,nz)
  use globalData
  real :: zku(nz,ny,nx),zka(nz,ny,nx)
  integer :: nx,ny,nz
  print*, nx, ny, nz
  print*, shape(dPRData%zku1c21)
  zku=dPRData%zku1c21
  zka=dPRData%zka1c21
end subroutine getzs


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine active  --  set the list of active atoms  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "active" sets the list of atoms that are used during
c     each potential energy function calculation
c
c
      subroutine active
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'usage.i'
      integer i,j,next
      integer nmobile,nfixed
      integer center,nsphere
      integer, allocatable :: mobile(:)
      integer, allocatable :: fixed(:)
      real*8 xcenter,ycenter,zcenter
      real*8 radius,radius2,dist2
      character*20 keyword
      character*120 record
      character*120 string
c
c
c     perform dynamic allocation of some pointer arrays
c
      if (associated(iuse))  deallocate (iuse)
      if (associated(use))  deallocate (use)
      allocate (iuse(n))
      allocate (use(0:n))
c
c     perform dynamic allocation of some local arrays
c
      allocate (mobile(n))
      allocate (fixed(n))
c
c     set defaults for the numbers and lists of active atoms
c
      nuse = n
      use(0) = .false.
      do i = 1, n
         use(i) = .true.
      end do
      nmobile = 0
      nfixed = 0
      do i = 1, n
         mobile(i) = 0
         fixed(i) = 0
      end do
      nsphere = 0
c
c     get any keywords containing active atom parameters
c
      do j = 1, nkey
         next = 1
         record = keyline(j)
         call gettext (record,keyword,next)
         call upcase (keyword)
         string = record(next:120)
c
c     get any lists of atoms whose coordinates are active
c
         if (keyword(1:7) .eq. 'ACTIVE ') then
            read (string,*,err=10,end=10)  (mobile(i),i=nmobile+1,n)
   10       continue
            do while (mobile(nmobile+1) .ne. 0)
               nmobile = nmobile + 1
               mobile(nmobile) = max(-n,min(n,mobile(nmobile)))
            end do
c
c     get any lists of atoms whose coordinates are inactive
c
         else if (keyword(1:9) .eq. 'INACTIVE ') then
            read (string,*,err=20,end=20)  (fixed(i),i=nfixed+1,n)
   20       continue
            do while (fixed(nfixed+1) .ne. 0)
               nfixed = nfixed + 1
               fixed(nfixed) = max(-n,min(n,fixed(nfixed)))
            end do
c
c     get the center and radius of the sphere of active atoms
c
         else if (keyword(1:7) .eq. 'SPHERE ') then
            center = 0
            xcenter = 0.0d0
            ycenter = 0.0d0
            zcenter = 0.0d0
            radius = 0.0d0
            read (string,*,err=30,end=30)  xcenter,ycenter,
     &                                     zcenter,radius
   30       continue
            if (radius .eq. 0.0d0) then
               read (string,*,err=60,end=60)  center,radius
               xcenter = x(center)
               ycenter = y(center)
               zcenter = z(center)
            end if
            nsphere = nsphere + 1
            if (nsphere .eq. 1) then
               nuse = 0
               do i = 1, n
                  use(i) = .false.
               end do
               if (verbose) then
                  write (iout,40)
   40             format (/,' Active Site Spheres used to',
     &                        ' Select Active Atoms :',
     &                     //,3x,'Atom Center',11x,'Coordinates',
     &                        12x,'Radius',6x,'# Active Atoms')
               end if
            end if
            radius2 = radius * radius
            do i = 1, n
               if (.not. use(i)) then
                  dist2 = (x(i)-xcenter)**2 + (y(i)-ycenter)**2
     &                            + (z(i)-zcenter)**2
                  if (dist2 .le. radius2) then
                     nuse = nuse + 1
                     use(i) = .true.
                  end if
               end if
            end do
            if (verbose) then
               write (iout,50)  center,xcenter,ycenter,
     &                          zcenter,radius,nuse
   50          format (2x,i8,6x,3f9.2,2x,f9.2,7x,i8)
            end if
   60       continue
         end if
      end do
c
c     set active atoms to those marked as not inactive
c
      i = 1
      do while (fixed(i) .ne. 0)
         if (fixed(i) .gt. 0) then
            j = fixed(i)
            if (use(j)) then
               use(fixed(i)) = .false.
               nuse = nuse - 1
            end if
            i = i + 1
         else
            do j = abs(fixed(i)), abs(fixed(i+1))
               if (use(j)) then
                  use(j) = .false.
                  nuse = nuse - 1
               end if
            end do
            i = i + 2
         end if
      end do
c
c     set active atoms to only those marked as active
c
      i = 1
      do while (mobile(i) .ne. 0)
         if (i .eq. 1) then
            nuse = 0
            do j = 1, n
               use(j) = .false.
            end do
         end if
         if (mobile(i) .gt. 0) then
            j = mobile(i)
            if (.not. use(j)) then
               use(j) = .true.
               nuse = nuse + 1
            end if
            i = i + 1
         else
            do j = abs(mobile(i)), abs(mobile(i+1))
               if (.not. use(j)) then
                  use(j) = .true.
                  nuse = nuse + 1
               end if
            end do
            i = i + 2
         end if
      end do
c
c     use logical array to set the list of active atoms
c
      j = 0
      do i = 1, n
         if (use(i)) then
            j = j + 1
            iuse(j) = i
         end if
      end do
c
c     output the final list of the active atoms
c
      if (debug .and. nuse.gt.0 .and. nuse.lt.n) then
         write (iout,70)
   70    format (/,' List of Active Atoms for Energy',
     &              ' Calculations :',/)
         write (iout,80)  (iuse(i),i=1,nuse)
   80    format (3x,10i7)
      end if
c
c     perform deallocation of some local arrays
c
      deallocate (mobile)
      deallocate (fixed)
      return
      end


!======================================================================!
SUBROUTINE ModFlux(Scale_UVW) !must be placed after NewUVW.f90 and before CalcPS.f90
    !----------------------------------------------------------------------!
    !   Modifies the fluxes
    !   in order to conserve mass inside CalcPS.f90, but not actually
    !   interferes in Ur,Vr,Wr and flux, flux_u directly
    !   The idea behind this is following: int_ right hand side of pressure
    !   equation (delta mass conservation eq.) must be 0.
    !   But between newUVW and CalcPS matrix constucted from
    !   fluxes (flux_u, Ur,Vr,Wr) is saved, so no interfering with those is
    !   allowed. Therefore only impression of real fluxes in calcPS.f90
    !  is modified
    !----------------------------------------------------------------------!
    !------------------------------[Modules]-------------------------------!
    USE allp_mod, only : outflow
    USE all_mod
    USE par_mod
    USE pro_mod
    !----------------------------------------------------------------------!
    IMPLICIT NONE
    !-------------------------------[Locals]-------------------------------!
    INTEGER :: m, s, c, c1, c2
    REAL    :: FL
    REAL    :: dMass, Urs, Vrs, Wrs, Flux_total(1:NC)
    REAL    :: Scale_UVW(Nmat) !why 256
    !--------------------------------[CVS]---------------------------------!
    !  $Id: ModOut.f90,v 1.14 2008/12/10 14:46:52 IUS\mhadziabdic Exp $
    !  $Source: /home/IUS/mhadziabdic/.CVSROOT/T-Rex/Process/ModOut.f90,v $
    !======================================================================!

    !do m=1,Nmat
    !  MassIn(m) = 0.0
    !  MASOUT(m) = 0.0
    !  do s=1,NS
    !    c1=SideC(1,s)
    !    c2=SideC(2,s)
    !    if(c2 < 0) then
    !      if(TypeBC(c2) == OUTFLOW) then !!b.c. on outflow
    !        Rho   % n(c2)   = Rho   % n(c1)
    !        Ur    % n(c2)   = Ur    % n(c1)
    !        Vr    % n(c2)   = Vr    % n(c1)
    !        Wr    % n(c2)   = Wr    % n(c1)
    !        Zmixr % n(c2)   = Zmixr % n(c1)
    !      ! renew flux at boundaries
    !      Urs  = f(s) * Ur  % n(c1) + (1.0-f(s)) * Ur  % n(c2)
    !      Vrs  = f(s) * Vr  % n(c1) + (1.0-f(s)) * Vr  % n(c2)
    !      Wrs  = f(s) * Wr  % n(c1) + (1.0-f(s)) * Wr  % n(c2)
    !      Flux(s) = ( Urs*Sx(s) + Vrs*Sy(s) + Wrs*Sz(s) )
    !      end if
    !      if(TypeBC(c2)  ==  INFLOW   .OR. &
    !        (TypeBC(c2)  ==  PRESSURE .AND. Flux(s) < 0.0) .OR. & ! acts like an inflow
    !        (TypeBC(c2)  ==  CONVECT  .AND. Flux(s) < 0.0) ) then ! acts like an inflow
    !         if(material(c1) == m) MassIn(m) = MassIn(m) + Flux(s)
    !      elseif(TypeBC(c2) == OUTFLOW) then !!b.c. on outflow) then
    !         if(material(c1) == m) MASOUT(m) = MASOUT(m) + Flux(s)
    !      end if
    !    end if
    !  end do
    !  call glosum(MASSIN(m))
    !  call glosum(MASOUT(m))  ! not checked
    !end do
    !dMass = 0.0
    !do m=1,Nmat
    !  do c=1,NC
    !      dMass = dMass + volume(c)/dt*(1.5*Rho % n(c) - 2.0*Rho % o(c) + 0.5*Rho % oo(c))
    !  end do
    !end do
    !call glosum(dMass)
    !do m=1,Nmat
    !  Scale_UVW(m) = -(MASSIN(m)+dMass)/(MASOUT(m)+TINY)
    !end do
    !
    !
    !
    !!! ---- apply b.c.
    !    do s=1, NS
    !      c1=SideC(1,s)
    !      c2=SideC(2,s)
    !      if(c2  < 0) then
    !        if(TypeBC(c2) == OUTFLOW) then
    !          Rho  % n(c2)    = Rho   % n(c1)
    !
    !          Ur    % n(c2)   = Ur     % n(c1)
    !          Vr    % n(c2)   = Vr     % n(c1)
    !          Wr    % n(c2)   = Wr     % n(c1)
    !          Zmixr % n(c2)   = Zmixr  % n(c1)
    !
    !          U     % n(c2)   = Ur     % n(c1) / Rho % n(c2)
    !          V     % n(c2)   = Vr     % n(c1) / Rho % n(c2)
    !          W     % n(c2)   = Wr     % n(c1) / Rho % n(c2)
    !          Zmix  % n(c2)   = Zmixr  % n(c1) / Rho % n(c2)
    !        end if
    !      end if
    !    end do

    !------------------------------------------!
    !     Calculate density change in domain   !
    !------------------------------------------!
    Flux_total = 0.0
    do m=1,Nmat
        do s=1,NS
            c1=SideC(1,s)
            c2=SideC(2,s)
            if(TypeBC(c2) == OUTFLOW) then !!b.c. on outflow
                Rho   % n(c2)   = Rho   % n(c1)
                Ur    % n(c2)   = Ur    % n(c1)
                Vr    % n(c2)   = Vr    % n(c1)
                Wr    % n(c2)   = Wr    % n(c1)
                Zmixr % n(c2)   = Zmixr % n(c1)

                U     % n(c2)   = Ur    % n(c1) / Rho % n(c2)
                V     % n(c2)   = Vr    % n(c1) / Rho % n(c2)
                W     % n(c2)   = Wr    % n(c1) / Rho % n(c2)
                Zmix  % n(c2)   = Zmixr % n(c1) / Rho % n(c2)

            end if
            Urs  = f(s) * Ur  % n(c1) + (1.0-f(s)) * Ur  % n(c2)
            Vrs  = f(s) * Vr  % n(c1) + (1.0-f(s)) * Vr  % n(c2)
            Wrs  = f(s) * Wr  % n(c1) + (1.0-f(s)) * Wr  % n(c2)

            Flux_total(c1) = Flux_total(c1) + ( Urs*Sx(s) + Vrs*Sy(s) + Wrs*Sz(s) )
            if(c2  > 0) Flux_total(c2) = Flux_total(c2) - ( Urs*Sx(s) + Vrs*Sy(s) + Wrs*Sz(s) )
        end do
    end do

    FL    = 0.0
    dMass = 0.0
    do m=1,Nmat
        do c=1,NC
            dMass = dMass + volume(c)/dt*(1.5*Rho % n(c) - 2.0*Rho % o(c) + 0.5*Rho % oo(c))

            FL    = FL + Flux_total(c)
        end do
    end do

    !call glosum(dMass)
    !call glosum(FL)

    do m=1,Nmat
        Scale_UVW(m) = - dMass / FL
    end do

    do m=1,Nmat
        if (this < 2) write(*,*) "dMass = ", dMass, " FL = ", FL , " Scale_UVW= ", Scale_UVW(m)
    end do

END SUBROUTINE ModFlux


module ObsWriterModule

  use ConstantsModule,    only: LENOBSNAME, LENOBSTYPE, &
                                LINELENGTH, DZERO, MAXCHARLEN, &
                                DHALF
  use ConstantsPHMFModule, only: FCINPUT, LENOBSNAMENEW
  use ConverterCommonModule, only: SupportPreproc
  use DnmDis3dModule,     only: Dis3dType
  use DnmDisBaseModule,   only: DisBaseType
  use FileListModule,     only: FileListType
  use FileTypeModule,     only: FileType
  use FileWriterModule,   only: FileWriterType
  use GLOBAL,             only: IUNIT, NLAY, NROW, NCOL, IOUT, DELC, DELR
  use InputOutputModule,  only: openfile, GetUnit
  use ListModule,         only: ListType
  use MultiLayerObs,      only: LayerObsType, MLObsType, ConstructLayerObs, &
                                ConstructMLObs, AddLayerObsToList, &
                                AddMLObsToList, GetLayerObsFromList, &
                                GetMLObsFromList
  use OBSBASMODULE,       only: ITS, nhed=>NH, MAXM, MOBS, IUHOBSV, IDRY, &
                                JDRY, IPRT, HOBDRY, NDER, MLAY, IOFF, &
                                JOFF, IHOBWET, TOFF, ROFF, COFF, &
                                otimehd=>OTIME, hobsname=>OBSNAM, &
                                irefspd, nlayer, PR
  use OBSCHDMODULE,       only: NQCH, NQCCH, NQTCH, NQOBCH, NQCLCH, &
                                otimech=>OTIME, qcellch=>QCELL
  use OBSDRNMODULE,       only: NQDR, NQCDR, NQTDR, NQOBDR, NQCLDR, &
                                otimedr=>OTIME, qcelldr=>QCELL, IUDROBSV
  use OBSGHBMODULE,       only: NQGB, NQCGB, NQTGB, NQOBGB, NQCLGB, &
                                otimegb=>OTIME, qcellgb=>QCELL, IUGBOBSV
  use OBSRIVMODULE,       only: NQRV, NQCRV, NQTRV, NQOBRV, NQCLRV, &
                                otimerv=>OTIME, qcellrv=>QCELL, IURVOBSV
  use PreprocModule,      only: PreprocType
  use SimModule,          only: store_error, store_note, store_warning, ustop
  use StressPeriodModule, only: StressPeriodType
  use UtilitiesModule,    only: get_extension
  use utl7module,         only: assign_ncharsizes_flow, build_obsname

  implicit none

  type, extends(FileWriterType) :: ObsWriterType
    character(len=6) :: Precis = 'double'
    integer          :: NumDigits = 7
    integer          :: IuObs = 0
    integer          :: IuMlPostObs = 0
    ! Model-level variables
    character(len=LINELENGTH) :: basename = ''
    type(FileListType), pointer :: Mf6Files => null()
    ! For PreHeadsMF capability
    double precision :: hdry
    character(len=MAXCHARLEN) :: DisFileName = ''
    ! PreHeadsMfFile is a PreHeadsMF input file to be generated by ObsWriter
    ! and can be run by invoking this%preproc%Run() or by running PreHeadsMF.
    character(len=MAXCHARLEN) :: PreHeadsMfFile = ''
    ! PhmfObsFileName goes into PreHeadsMF input as MFOBSFILE and is
    ! an EXTERNAL file referenced in the main head obs input file.
    character(len=MAXCHARLEN) :: PhmfObsFileName = ''
    ! PomfFileName goes into PreHeadsMF input as POSTOBSFILE; it
    ! can be used by PostObsMF after MF6 is run.
    character(len=MAXCHARLEN) :: PomfFileName = ''
    ! ObsOutputBasename goes into PreHeadsMF input as obs_output_base_name;
    ! it is used as the basis for names of various .csv and .bsv files.
    character(len=MAXCHARLEN) :: ObsOutputBasename = ''
    character(len=MAXCHARLEN) :: MlPostObsFileName = ''
    character(len=MAXCHARLEN) :: MfOutputCsvFileName = ''
    character(len=6) :: Source = ' '
    type(PreprocType) :: Preproc
    type(StressPeriodType), dimension(:), pointer :: StressPeriods => null()
    type(ListType) :: MLObsList
    double precision, dimension(:), pointer :: delc => null()
    double precision, dimension(:), pointer :: delr => null()
  contains
    ! Public procedures
    procedure, public :: InitializeObs
    procedure, public :: SetDisFileName
    procedure, public :: SetHdry
    procedure, public :: SetStressPeriods
    procedure, public :: WriteContinuous
    procedure, public :: WriteObsFile
    procedure, public :: write_ml_postobs_file
    ! Private procedures
    procedure, private :: calc_grid_coords
    procedure, private :: WriteObsOptions
    procedure, private :: write_preheadsmf_file
    procedure, private :: write_preheadsmf_options
    procedure, private :: write_ml_postobs_input_files
    procedure, private :: write_ml_postobs_options
    procedure, private :: write_ml_postobs_input
  end type ObsWriterType

contains

  subroutine InitializeObs(this, basename, modifier)
    implicit none
    ! dummy
    class(ObsWriterType), intent(inout) :: this
    character(len=*), intent(in) :: basename
    character(len=*), optional, intent(in) :: modifier
    ! local
    character(len=4) :: ftype
    character(len=LINELENGTH) :: fname
    !
    this%basename = basename
    this%PkgType = ''
    ftype = 'OBS6'
    fname = trim(basename)
    if (present(modifier)) then
      fname = trim(fname) // '.' // trim(modifier)
    endif
    fname = trim(fname) // '.obs'
    ! Invoke superclass initializer
    call this%FileWriterType%InitializeFile(fname, ftype)
    this%FileWriterType%fileobj%FCode = FCINPUT
    this%IuObs = this%FileWriterType%fileobj%IUnit
    !
    return
  end subroutine InitializeObs

  subroutine SetDisFileName(this, disfilename)
    ! dummy
    class(ObsWriterType) :: this
    character(len=*), intent(in) :: disfilename
    !
    this%DisFilename = disfilename
    !
    return
  end subroutine SetDisFileName

  subroutine SetHdry(this, hdry)
    ! dummy
    class(ObsWriterType) :: this
    double precision, intent(in) :: hdry
    !
    this%hdry  = hdry
    !
    return
  end subroutine SetHdry

  subroutine SetStressPeriods(this, StressPeriods)
    class(ObsWriterType) :: this
    type(StressPeriodType), dimension(:), pointer, intent(inout) :: StressPeriods
    !
    this%StressPeriods => StressPeriods
    !
    return
  end subroutine SetStressPeriods

  subroutine WriteObsFile(this, igrid)
    implicit none
    ! dummy
    class(ObsWriterType) :: this
    integer, intent(in)  :: igrid
    ! local
    integer :: iunew, iuob, iuobs
    logical :: needPreproc
    ! formats
    1 format()
    10 format(a,2x,a)
    20 format(2x,a,2x,a)
    !
    this%delc => DELC
    this%delr => DELR
    !
    select type(this)
    type is (ObsWriterType)
      ! Read the HOB input file here to know if Preproc (PreHeadsMF) needs to be activated.
      iuob = iunit(28)  ! HOB input unit
! probably incorrect      this%IuObs = iuob
      call OBS2BAS7AR(iuob, igrid, needPreproc)
      if (SupportPreproc .and. needPreproc) then
        this%Preproc%Active = .true.
        !
        ! Find lower left corner of grid and assign YoriginLL
        call this%Preproc%find_lower_left()
        !
        ! Write a PreHeadsMF input file.
        ! Ned todo: (1) Uncomment following line (that invokes write_preheadsmf_file) after 2016 GW workshop;
        !           (2) Finish code that writes preheadsmf (.phmf) file
        !               --it doesn't handle multilayer obs correctly now;
        !           (3) Write code to create/modify mf6 obs input file to include head obs for adjacent cells.
        !           (4) Maybe write code to create a batch file to run preheadsmf, mf6, and postobsmf.
        call this%write_preheadsmf_file()
      endif
    end select
    !
    call this%WriteObsOptions()
    !
    ! Write a single block if needed for PreHeadsMF
    if (this%Preproc%Active) then
      iunew = this%fileobj%IUnit
      write(iunew,1)
      write(iunew,10)'# Head observations that require interpolation'
      write(iunew,10)'BEGIN SINGLE FILEOUT', trim(this%ObsOutputBasename) // '.csv'
      write(iunew,20)'OPEN/CLOSE',trim(this%PhmfObsFileName)
      write(iunew,10)'END SINGLE'
    endif

    !
    ! Write continuous blocks
    iuobs = this%IuObs
    if (iuobs > 0) then
      call this%WriteContinuous(igrid)
    endif
    !
    return
  end subroutine WriteObsFile

  subroutine write_preheadsmf_file(this)
    ! Write a PreHeadsMF input file for head obs with ROFF or COFF not equal to zero.
    ! dummy
    class(ObsWriterType) :: this
    ! local
    integer :: i, iuphmf, irow, jcol, layer, k
    integer :: nlayobs ! # layers for current observation
    integer :: kmobs   ! Counter for multilayer observations
    double precision :: obstime, rof, cof, xgrid, ygrid, weight
    character(len=LENOBSNAMENEW) :: obsnamebase, obsnametemp
    type(LayerObsType), pointer :: layobs => null()
    type(MLObsType), pointer :: mlobs => null()
    ! formats
    1 format()
    5 format(a)
    10 format(a,2x,a)
    ! For grid coordinates field, allow for 100,000,000 cm plus sign
    20 format(2x,a,2x,g18.11,2(2x,f12.1),2x,i0)
    30 format(a,'_L',i0)
    !
    this%PhmfObsFileName = trim(this%basename) // '.phmf.obs'
    this%PomfFileName = trim(this%basename) // '.pomf'
    this%PreHeadsMfFile = trim(this%basename) // '.phmf'
    this%ObsOutputBasename = trim(this%basename) // '.proc.heds'
    call openfile(iuphmf, iout, this%PreHeadsMfFile, 'PHMF', filstat_opt='REPLACE')
    !
    ! Write options block
    call this%write_preheadsmf_options(iuphmf)
    !
    ! Write a SINGLE block for all obs with ROFF or COFF not equal to zero.
    write(iuphmf,1)
    write(iuphmf,10)'BEGIN SINGLE ', trim(this%ObsOutputBasename)
    !
    kmobs = 0
    do i=1,nhed
      rof = roff(i)
      cof = coff(i)
      layer = NDER(1,i)
      if (layer < 0) kmobs = kmobs + 1
      if (rof == DZERO .and. cof == DZERO) then
        ! No need for interpolation
        cycle
      endif
      ! Get X and Y grid coordinates
      irow = NDER(2,i)
      jcol = NDER(3,i)
      call this%calc_grid_coords(irow, jcol, rof, cof, xgrid, ygrid)
      obsnamebase = hobsname(i)
      obstime = otimehd(i)
      if (layer < 0) then
        nlayobs = -layer
        call ConstructMLObs(mlobs, obsnamebase)
        call AddMLObsToList(this%MLObsList, mlobs)
        do k=1,nlayobs
          layer = mlay(k,kmobs)
          weight = pr(k,kmobs)
          write(obsnametemp,30)trim(obsnamebase),layer
          write(iuphmf,20)trim(obsnametemp), obstime, xgrid, ygrid, layer
          call ConstructLayerObs(layobs, obsnametemp, layer, weight)
          call AddLayerObsToList(mlobs%LayerObsList,layobs)
        enddo
      else
        write(iuphmf,20)trim(obsnamebase), obstime, xgrid, ygrid, layer
      endif
    enddo
    !
    write(iuphmf,5)'END SINGLE'
    !
    ! Close the PreHeadsMF input file.
    close(iuphmf)
    !
    return
  end subroutine write_preheadsmf_file

  subroutine calc_grid_coords(this, irow, jcol, rof, cof, xgrid, ygrid)
    ! Calculate X and Y grid coordinates from row and column indices
    ! and roff and coff, relative to outside corner of cell at row 1,
    ! column 1.  This makes all Y values negative.
    ! dummy
    class(ObsWriterType) :: this
    integer, intent(in) :: irow, jcol
    double precision, intent(in) :: rof, cof
    double precision, intent(out) :: xgrid, ygrid
    ! local
    integer :: i, j
    !
    ! X direction (delr, jcol, and cof)
    xgrid = DZERO
    do j=1,jcol-1
      xgrid = xgrid + this%delr(j)
    enddo
    xgrid = xgrid + DHALF * this%delr(jcol)
    xgrid = xgrid + cof * this%delr(jcol)
    !
    ! Y direction (delc, irow, and rof)
    ygrid = DZERO
    do i=1,irow-1
      ygrid = ygrid - this%delc(i)
    enddo
    ygrid = ygrid - DHALF * this%delc(irow)
    ygrid = ygrid - rof * this%delc(irow)
    !
    return
  end subroutine calc_grid_coords

  subroutine write_preheadsmf_options(this, iuphmf)
    ! dummy
    class(ObsWriterType) :: this
    integer, intent(in) :: iuphmf
    ! formats
    10 format(a)
    15 format(2x,a)
    20 format(2x,a,2x,a)
    30 format(2x,a,2x,i0)
    40 format(2x,a,2x,g14.7)
    !
    write(iuphmf,10)'BEGIN OPTIONS'
    write(iuphmf,20)'DIS  FILEIN', trim(this%DisFileName)
    write(iuphmf,20)'MFOBSFILE  FILEOUT', trim(this%PhmfObsFileName)
    write(iuphmf,20)'POSTOBSFILE  FILEOUT', trim(this%PomfFileName)
!    write(iuphmf,20)'PRECISION', trim(this%Precis)
!need to write XORIGIN and YORIGIN with appropriate values for lower left corner of grid
    write(iuphmf,40)'XORIGIN', this%Preproc%XoriginLL
    !write(iuphmf,40)'YORIGIN', this%Preproc%dis%Yorigin
    write(iuphmf,40)'YORIGIN', this%Preproc%YoriginLL
    write(iuphmf,30)'DIGITS', this%NumDigits
    write(iuphmf,15)'VERBOSE'
    write(iuphmf,15)'OMITOPTIONS'
    write(iuphmf,10)'END OPTIONS'
    !
    return
  end subroutine write_preheadsmf_options

  subroutine WriteObsOptions(this)
    implicit none
    ! dummy
    class(ObsWriterType) :: this
    ! local
    integer :: iu
    ! formats
    20 format(2x,a,2x,a)
    30 format()
    40 format(2x,a)
    50 format(2x,a,2x,i0)
    60 format(a)
    !
    iu = this%fileobj%IUnit
    !write(iu,30)
    write(iu,60)'BEGIN Options'
    write(iu,40)'PRINT_INPUT'
    write(iu,50)'DIGITS',this%NumDigits
    !
    write(iu,60)'END Options'
    !
    return
  end subroutine WriteObsOptions

  subroutine WriteContinuous(this, igrid)
    implicit none
    ! dummy
    class(ObsWriterType) :: this
    integer, intent(in) :: igrid
    ! local
    integer :: i, ihed, iu, iuob, ml
    integer :: ilay, irow, icol
    integer :: mlayer
    integer :: ncharid, ncharlay
    double precision :: weight
    logical :: killonfailure, singlelayer, &
               colcentered, rowcentered
    character(len=LENOBSNAME) :: oname, onameml, onametemp
    character(len=LINELENGTH) :: outfilename
    character(len=LENOBSTYPE) :: otype
    character(len=*), parameter :: fmtaxi = '(a,1x,i0)'
!    character(len=*), parameter :: fmtxataxg3xi = &
!                                   '(2x,a,t30,a,2x,g15.8,3(2x,i0))'
    character(len=*), parameter :: fmtxata3xi = &
                                   '(2x,a,t30,a,3(2x,i0))'
    type(LayerObsType), pointer :: layobs => null()
    type(MLObsType), pointer :: mlobs => null()
    ! formats
    1 format()
    10 format(a,1x,a)
    !
    otype = 'HEAD'
    iu = this%fileobj%IUnit
    killonfailure = .false.
    iuob = iunit(28)  ! HOB input unit
    if (nhed<=0) return
    call assign_ncharsizes_hed(ncharid, ncharlay)
    outfilename = trim(this%basename) // '.hobs_out.csv'
    this%MfOutputCsvFileName = outfilename
    !
    write(iu,1)
    write(iu,10)'#','Head observations'
    write(iu,10)'BEGIN CONTINUOUS FILEOUT',trim(outfilename)
    !
    ihed = 0
    ml = 0
    headloop: do ihed=1,nhed
      ! Determine if observation is single-layer or multi-layer.
      if (nlayer(ihed) == 1) then
        ! observation is single-layer
        singlelayer = .true.
      else
        ! observation is multi-layer
        singlelayer = .false.
        ml = ml + 1
      endif
      !
      ! Determine if observation location is centered in cell or offcenter.
      if (this%Preproc%Active) then
        rowcentered = (roff(ihed) == DZERO)
        colcentered = (coff(ihed) == DZERO)
      else
        ! If heads preprocessor is not active, just treat obs location as
        ! being at cell center.
        rowcentered = .true.
        colcentered = .true.
      endif
      !
      ! Write lines to CONTINUOUS block only for centered observation location;
      ! PreHeadsMF will handle offset observations.
      if (rowcentered .and. colcentered) then
        ! Obs location is centered.
        ilay = NDER(1,ihed)
        irow = NDER(2,ihed)
        icol = NDER(3,ihed)
        !
        ! Check to see if this cell has already been handled/written.
        ! If so, skip it.
        if (ihed > 1) then
          do i=1,ihed-1
            if (ilay == nder(1,i) .and. irow == nder(2,i)   &
                .and. icol == nder(3,i)) then
              cycle headloop
            endif
          enddo
        endif
        !
        ! Assign observation name (or name base
        ! for multi-layer observation).
        oname = hobsname(ihed)
        if (singlelayer) then
          ! Obs is single-layer.
          ! No additional observation locations are needed.
          ! Go ahead and write line for one observation.
          write(iu,fmtxata3xi)trim(oname),trim(otype),ilay, &
                      irow,icol
        else
          ! Obs is multi-layer.
          ! Write obs line for each layer.
          call ConstructMLObs(mlobs, oname)
          call AddMLObsToList(this%MLObsList, mlobs)
          onametemp = trim(oname) // '_L'
          do i=1,nlayer(ihed)
            mlayer = MLAY(i,ml)
            weight = PR(i,ml)
            onameml = build_obsname(onametemp,mlayer,ncharlay)
            write(iu,fmtxata3xi)trim(onameml),trim(otype), &
                        mlayer,irow,icol
            call ConstructLayerObs(layobs, onameml, mlayer, weight)
            call AddLayerObsToList(mlobs%LayerObsList,layobs)
          enddo
        endif
      endif
    enddo headloop
    !
    write(iu,10)'END','CONTINUOUS'
    !
    return
  end subroutine WriteContinuous

  subroutine assign_ncharsizes_hed(ncharid, ncharlay)
    implicit none
    ! dummy
    integer, intent(inout) :: ncharid
    integer, intent(inout) :: ncharlay
    ! local
    integer :: lenmax=20
    character(len=LINELENGTH) :: msg_multilayer
    !
    ! Assign sizes for head observations
    if (mobs > 0) then
      ! At least one multi-layer head observation is defined.
      ! Assign ncharlay based on NLAY
      select case (nlay)
      case (1:9)
        ncharlay = 1
      case (10:99)
        ncharlay = 2
      case (100:999)
        ncharlay = 3
      case default
        ncharlay = 3
        msg_multilayer = 'NLAY is too large to support multi-layer ' &
                          // 'head observations for cells in layer > 999.'
        call store_warning(msg_multilayer)
      end select
      !
      ! Allow for leading "H", possible two characters used
      ! for offset indicator, and "_L" to lead layer number.
      ncharid = lenmax - 5 - ncharlay
    else
      ! No need to allow characters for layer number in obs names,
      ! but allow for leading "H" and possible two character used
      ! for offset indicator.
      ncharid = lenmax - 3
      ncharlay = 0
    endif
    !
    return
  end subroutine assign_ncharsizes_hed

  subroutine write_ml_postobs_file(this)
    ! Write all blocks of a multilayer PostObsMF input file
    ! dummy
    class(ObsWriterType) :: this
    ! local
    integer :: iu
    ! formats
    1 format()
    10 format(a,1x,a,1x,a)
    15 format(a,1x,a)
    20 format(2x,a)
    !
    this%MlPostObsFileName = trim(this%basename) // '.mlpo'
    this%IuMlPostObs = GetUnit()
    iu = this%IuMlPostObs
    call openfile(iu,0,this%MlPostObsFileName,'MLPO',filstat_opt='REPLACE')
    !
    ! Write Options block
    call this%write_ml_postobs_options()
    !
    ! Write Input_Files block
    call this%write_ml_postobs_input_files()
    !
    ! Write SINGLE block
    call this%write_ml_postobs_input()
    !
    return
  end subroutine write_ml_postobs_file

  subroutine write_ml_postobs_options(this)
    ! dummy
    class(ObsWriterType), intent(inout) :: this
    ! local
    integer :: iu
    ! formats
    10 format(a,1x,a)
    20 format(2x,a)
    30 format(2x,a,2x,a)
    40 format(2x,a,2x,i0)
    !
    iu = this%IuMlPostObs
    !
    ! Write BEGIN line
    write(iu,10)'BEGIN', 'OPTIONS'
    !
!    write(iu,30)'PRECISION', prec(this%Preproc%IPrecision)
    write(iu,40)'DIGITS', this%Preproc%Idigits
    !
    ! Write END line
    write(iu,10)'END', 'OPTIONS'
    !
    return
  end subroutine write_ml_postobs_options

  subroutine write_ml_postobs_input_files(this)
    ! dummy
    class(ObsWriterType), intent(inout) :: this
    ! local
    integer :: i, iu, n
    character(len=MAXCHARLEN) :: fname
    ! formats
    1 format()
    10 format(a,1x,a)
    20 format(2x,a,2x,a)
    !
    iu = this%IuMlPostObs
    write(iu,1)
    !
    ! Write BEGIN line
    write(iu,10)'BEGIN', 'INPUT_FILES'
    !
    fname = this%MfOutputCsvFileName
    write(iu,20)'SINGLE', trim(fname)
    n = size(this%Preproc%PostObsOutputCsvFiles)
    do i=1,n
      fname = this%Preproc%PostObsOutputCsvFiles(i)
      write(iu,20)'SINGLE', trim(fname)
    enddo
    !
    ! Write END line
    write(iu,10)'END', 'INPUT_FILES'
    !
    return
  end subroutine write_ml_postobs_input_files

  subroutine write_ml_postobs_input(this)
    ! dummy
    class(ObsWriterType) :: this
    ! local
    integer :: i, iu, j, nlayers, nobs
    character(len=MAXCHARLEN) :: fname
    type(MLObsType), pointer :: mlobs => null()
    type(LayerObsType), pointer :: layob => null()
    ! formats
    1 format()
    10 format(a,1x,a,1x,a)
    12 format(a,1x,a,1x,a,2x,'BINARY')
    15 format(a,1x,a)
    20 format(2x,a,2x,a)
    30 format(4x,a,2x,G14.7)
    !
    ! Write BEGIN line
    iu = this%IuMlPostObs
    write(iu,1)
    fname = trim(this%MlPostObsFileName) // '.post.csv'
    write(iu,10)'BEGIN', 'SINGLE FILEOUT', trim(fname)
    !
    ! Write observation information
    nobs = this%MLObsList%Count()
    do i=1,nobs
      mlobs => GetMLObsFromList(this%MLObsList, i)
      call mlobs%CheckWeightSum()
      ! Write NEW line
      write(iu,20)'NEW',trim(mlobs%mlobsname)
      ! Write source line for each layer
      nlayers = mlobs%LayerObsList%Count()
      do j=1,nlayers
        layob => GetLayerObsFromList(mlobs%LayerObsList, j)
        write(iu,30)trim(layob%lobsname), layob%weight
      enddo
    enddo
    !
    ! Write END line
    write(iu,15)'END','SINGLE'
    !
    return
  end subroutine write_ml_postobs_input

end module ObsWriterModule


module loadbal
!$$$  module documentation block
!
! module: loadbal          decompose ob priors and horizontal grid points
!                          to minimize load imbalance. Creates various
!                          arrays that define the decomposition.
!
! prgmmr: whitaker         org: esrl/psd               date: 2009-02-23
!
! abstract:
!
! Public Subroutines:
!  load_balance: set up decomposition (for ob priors and analysis grid points)
!   that minimizes load imbalance.
!   The decomposition uses "Graham's rule", which simply
!   stated, assigns each new work item to the task that currently has the
!   smallest load.
!  loadbal_cleanup: deallocate allocated arrays.
!
! Private Subroutines:
!  estimate_work_enkf1: estimate work needed to update each analysis grid
!   point (considering all the observations within the localization radius).
!  estimate_work_enkf2: estimate work needed to update each observation prior
!   (considering all the observations within the localization radius of each
!    observation).
! Public Variables (all defined by subroutine load_balance):
!  npts_min: (integer scalar) smallest number of grid points assigned to a task.
!  npts_max: (integer scalar) maximum number of grid points assigned to a task.
!  nobs_min: (integer scalar, serial enkf only) smallest number of observation priors assigned to a task.
!  nobs_max: (integer scalar, serial enkf only) maximum number of observation priors assigned to a task.
!  numproc: (integer scalar) total number of MPI tasks (from module mpisetup)
!  nobstot: (integer scalar) total number of obs to be assimilated (from module
!   enkf_obsmod).
!  numobsperproc(numproc): (serial enkf only) integer array containing # of ob priors
!   assigned to each task.
!  numptsperproc(numproc): integer array containing # of grid points assigned to
!   each task.
!  indxproc(numproc,npts_max): integer array with the indices (1,2,...npts) of
!   analysis grid points assigned to each task.
!  indxproc_obs(numproc,nobs_max): (serial enkf only) integer array with the indices
!   (1,2,...nobstot) of observation priors assigned to that task.
!  iprocob(nobstot): (serial enkf only) integer array containing the task number that has been
!   assigned to update each observation prior.
!  indxob_chunk(nobstot): (serial enkf only) integer array that maps the index of the ob priors
!   being assimilated (1,2,3...nobstot) to the index of the obs being
!   updated on that task (1,2,3,...numobsperproc(nproc)) - inverse of
!   indxproc_obs.
!  ensmean_obchunk(nobs_max): (serial enkf only) real array of ensemble mean observation priors
!   being updated on that task (use indxproc_obs to find
!   corresponding index in ensemble_ob).
!  obloc_chunk(3,nobs_max): (serial enkf only) real array of spherical cartesian coordinates
!   of ob priors being updated on this task.
!  grdloc_chunk(3,npts_max): real array of spherical cartesian coordinates
!   of analysis grid points being updated on this task.
!  lnp_chunk(npts_max,ndim): real array of log(pressures) of state variables
!   being updated on this task.
!  oblnp_chunk(nobs_max,ndim): (serial enkf only) real array of log(pressures) of ob priors
!   being updated on this task.
!  obtime_chunk(nobs_max): (serial enkf only) real array of ob times of ob priors
!   being updated on this task (expressed as an offset from the analysis time in
!   hours).
!  anal_obchunk_prior(nanals,nobs_max): (serial enkf only) real array of observation prior
!   ensemble perturbations to be updated on this task (not used in LETKF).
!  kdtree_grid: pointer to kd-tree structure used for nearest neighbor searches
!   for model grid points (only searches grid points assigned to this task).
!  kdtree_obs: pointer to kd-tree structure used for nearest neighbor searches
!   for observations (only searches ob locations assigned to this task).
!  kdtree_obs2: (LETKF only) pointer to kd-tree structure used for nearest neighbor searches
!   for observations (searches all observations)
!
!
! Modules Used: mpisetup, params, kinds, constants, enkf_obsmod, gridinfo,
!               kdtree_module, covlocal
!
! program history log:
!   2009-02-23  Initial version.
!   2011-06-21  Added the option of observation box selection for LETKF.
!   2015-07-25  Remove observation box selection (use kdtree instead).
!
! attributes:
!   language: f95
!
!$$$

use mpisetup
use params, only: ndim, datapath, nanals, simple_partition, letkf_flag,&
                  corrlengthnh, corrlengthsh, corrlengthtr, lupd_obspace_serial, fso_flag
use enkf_obsmod, only: nobstot, obloc, oblnp, ensmean_ob, obtime, anal_ob, corrlengthsq
use kinds, only: r_kind, i_kind, r_double, r_single
use kdtree2_module, only: kdtree2, kdtree2_create, kdtree2_destroy, &
                          kdtree2_result, kdtree2_r_nearest
use gridinfo, only: gridloc, logp, latsgrd, nlevs_pres, npts
use constants, only: zero, rad2deg, deg2rad

implicit none
private
public :: load_balance, loadbal_cleanup

real(r_single),public, allocatable, dimension(:,:) :: lnp_chunk
real(r_single),public, allocatable, dimension(:,:) :: anal_obchunk_prior
! arrays passed to kdtree2 routines need to be single
real(r_single),public, allocatable, dimension(:,:) :: obloc_chunk, grdloc_chunk
real(r_single),public, allocatable, dimension(:) :: oblnp_chunk, &
 obtime_chunk, ensmean_obchunk
integer(i_kind),public, allocatable, dimension(:) :: iprocob, indxob_chunk,&
                          numptsperproc, numobsperproc
integer(i_kind),public, allocatable, dimension(:,:) :: indxproc, indxproc_obs
integer(i_kind),public :: npts_min, npts_max, nobs_min, nobs_max
integer(8) totsize
! kd-tree structures.
type(kdtree2),public,pointer :: kdtree_obs, kdtree_grid, kdtree_obs2

contains

subroutine load_balance()
! set up decomposition (for analysis grid points, and ob priors in serial EnKF)
! that minimizes load imbalance.
! Uses "Graham's rule", which simply
! stated, assigns each new work item to the task that currently has the
! smallest load.
implicit none
integer(i_kind), allocatable, dimension(:) :: rtmp,numobs
!real(r_single), allocatable, dimension(:) :: buffer
integer(i_kind) np,i,n,nn,nob1,nob2,ierr
real(r_double) t1
logical test_loadbal

if (letkf_flag) then
   ! used for finding nearest obs to grid point in LETKF.
   ! results are sorted by distance.
   kdtree_obs2  => kdtree2_create(obloc,sort=.true.,rearrange=.true.)
endif

! partition state vector for using Grahams rule..
! ("When a new job arrives, allocate it to the server
! that currently has the smallest load")
allocate(numobs(npts))
allocate(numptsperproc(numproc))
allocate(rtmp(numproc))
t1 = mpi_wtime()
! assume work load proportional to number of 'nearby' obs
call estimate_work_enkf1(numobs) ! fill numobs array with number of obs per horiz point
! distribute the results of estimate_work to all processors.
call mpi_allreduce(mpi_in_place,numobs,npts,mpi_integer,mpi_sum,mpi_comm_world,ierr)
if (nproc == 0) print *,'time in estimate_work_enkf1 = ',mpi_wtime()-t1,' secs'
if (nproc == 0) print *,'min/max numobs',minval(numobs),maxval(numobs)
! loop over horizontal grid points on analysis grid.
t1 = mpi_wtime()
rtmp = 0
numptsperproc = 0
np = 0
test_loadbal = .false. ! simple partition for testing
do n=1,npts
   if (test_loadbal) then
       ! use simple partition (does not use estimated workload) for testing
       np = np + 1
       if (np > numproc) np = 1
   else
       np = minloc(rtmp,dim=1)
       ! np is processor with the fewest number of obs to process
       ! add this grid point to list for nmin
       rtmp(np) = rtmp(np)+numobs(n)
   endif
   numptsperproc(np) = numptsperproc(np)+1
end do
npts_max = maxval(numptsperproc)
npts_min = minval(numptsperproc)
allocate(indxproc(numproc,npts_max))
! indxproc(np,i) is i'th horiz grid index for processor np.
! there are numptsperpoc(np) i values for processor np
rtmp = 0
numptsperproc = 0
np = 0
do n=1,npts
   if (test_loadbal) then
       ! use simple partition (does not use estimated workload) for testing
       np = np + 1
       if (np > numproc) np = 1
   else
       np = minloc(rtmp,dim=1)
       rtmp(np) = rtmp(np)+numobs(n)
   endif
   numptsperproc(np) = numptsperproc(np)+1 ! recalculate
   indxproc(np,numptsperproc(np)) = n
end do
! print estimated workload for each task
if (nproc == 0) then
   do np=1,numproc
      rtmp(np) = 0
      do n=1,numptsperproc(np)
         rtmp(np) = rtmp(np) + numobs(indxproc(np,n))
      enddo
   enddo
   print *,'min/max estimated work ',&
    minval(rtmp),maxval(rtmp)
endif
deallocate(rtmp,numobs)
if (nproc == 0) then
    print *,'npts = ',npts
    print *,'min/max number of points per proc = ',npts_min,npts_max
    print *,'time to do model space decomp = ',mpi_wtime()-t1
end if
! setup arrays to hold subsets of grid information for each task.
allocate(grdloc_chunk(3,numptsperproc(nproc+1)))
allocate(lnp_chunk(numptsperproc(nproc+1),nlevs_pres))
do i=1,numptsperproc(nproc+1)
   grdloc_chunk(:,i) = gridloc(:,indxproc(nproc+1,i))
   do nn=1,nlevs_pres
      lnp_chunk(i,nn) = logp(indxproc(nproc+1,i),nn)
   end do
end do

! for serial filter, partition obs for observation space update.
if (.not. letkf_flag .or. lupd_obspace_serial) then
   allocate(numobsperproc(numproc))
   allocate(iprocob(nobstot))
   ! default is to partition obs simply, since
   ! speed up from using Graham's rule for observation process
   ! often does not justify cost of estimating workload in ob space.
   if (simple_partition) then
     ! just distribute obs without trying to estimate workload
     t1 = mpi_wtime()
     numobsperproc = 0
     np=0
     do n=1,nobstot
        np=np+1
        if(np > numproc)np = 1
        numobsperproc(np) = numobsperproc(np)+1
        iprocob(n) = np-1
     enddo
   else
     ! use graham's rule
     allocate(numobs(nobstot))
     t1 = mpi_wtime()
     ! assume workload is proportional to number of 'nearby obs' in ob space.
     call estimate_work_enkf2(numobs) ! fill numobs array with number of obs close to each ob
     ! distribute the results of estimate_work to all processors.
     call mpi_allreduce(mpi_in_place,numobs,nobstot,mpi_integer,mpi_sum,mpi_comm_world,ierr)
     if (nproc == 0) print *,'time in estimate_work_enkf2 = ',mpi_wtime()-t1,' secs'
     t1 = mpi_wtime()
     allocate(rtmp(numproc))
     rtmp = 0
     numobsperproc = 0
     np=0
     do n=1,nobstot
        np = minloc(rtmp,dim=1)
        ! np is processor with the fewest number of close obs to process
        rtmp(np) = rtmp(np)+numobs(n)
        numobsperproc(np) = numobsperproc(np)+1
        iprocob(n) = np-1
     enddo
     deallocate(rtmp,numobs)
   end if
   nobs_min = minval(numobsperproc)
   nobs_max = maxval(numobsperproc)
   allocate(indxproc_obs(numproc,nobs_max))
   numobsperproc = 0
   do n=1,nobstot
      np=iprocob(n)+1
      numobsperproc(np) = numobsperproc(np)+1 ! recalculate
      ! indxproc_obs(np,i) is i'th ob index for processor np.
      ! there are numobsperpoc(np) i values for processor np
      indxproc_obs(np,numobsperproc(np)) = n
   end do
   if (nproc == 0) then
       print *,'nobstot = ',nobstot
       print *,'min/max number of obs per proc = ',nobs_min,nobs_max
       print *,'time to do ob space decomp = ',mpi_wtime()-t1
   end if
   ! for serial enkf, send out observation priors to be updated on each processor.
   allocate(anal_obchunk_prior(nanals,nobs_max))
   if(nproc == 0) then
      print *,'sending out observation prior ensemble perts from root ...'
      totsize = nobstot
      totsize = totsize*nanals
      print *,'nobstot*nanals',totsize
      totsize = npts
      totsize = totsize*ndim
      print *,'npts*ndim',totsize
      t1 = mpi_wtime()
      ! send one big message to each task.
      do np=1,numproc-1
         do nob1=1,numobsperproc(np+1)
            nob2 = indxproc_obs(np+1,nob1)
            anal_obchunk_prior(1:nanals,nob1) = anal_ob(1:nanals,nob2)
         end do
         call mpi_send(anal_obchunk_prior,nobs_max*nanals,mpi_real4,np, &
              1,mpi_comm_world,ierr)
      end do
      ! anal_obchunk_prior on root (no send necessary)
      do nob1=1,numobsperproc(1)
         nob2 = indxproc_obs(1,nob1)
         anal_obchunk_prior(1:nanals,nob1) = anal_ob(1:nanals,nob2)
      end do
      ! now we don't need anal_ob anymore for serial EnKF.
      if (.not. lupd_obspace_serial) deallocate(anal_ob)
   else
      ! recv one large message on each task.
      call mpi_recv(anal_obchunk_prior,nobs_max*nanals,mpi_real4,0, &
           1,mpi_comm_world,mpi_status,ierr)
   end if
   call mpi_barrier(mpi_comm_world, ierr)
   if(nproc == 0) print *,'... took ',mpi_wtime()-t1,' secs'
   ! these arrays only needed for serial filter
   ! nob1 is the index of the obs to be processed on this rank
   ! nob2 maps nob1 to 1:nobstot array (nobx)
   allocate(obloc_chunk(3,numobsperproc(nproc+1)))
   allocate(oblnp_chunk(numobsperproc(nproc+1)))
   allocate(obtime_chunk(numobsperproc(nproc+1)))
   allocate(ensmean_obchunk(numobsperproc(nproc+1)))
   allocate(indxob_chunk(nobstot))
   indxob_chunk = -1
   do nob1=1,numobsperproc(nproc+1)
      nob2 = indxproc_obs(nproc+1,nob1)
      oblnp_chunk(nob1) = oblnp(nob2)
      obtime_chunk(nob1) = obtime(nob2)
      indxob_chunk(nob2) = nob1
      ensmean_obchunk(nob1) = ensmean_ob(nob2)
      obloc_chunk(:,nob1) = obloc(:,nob2)
   enddo
   ! set up kd-trees for serial filter to search only the subset
   ! of gridpoints, obs to be updated on this processor..
   if (.not. fso_flag .and. numptsperproc(nproc+1) >= 3 .and. .not. lupd_obspace_serial) then
      kdtree_grid => kdtree2_create(grdloc_chunk,sort=.false.,rearrange=.true.)
   endif
   if (numobsperproc(nproc+1) >= 3) then
      kdtree_obs  => kdtree2_create(obloc_chunk,sort=.false.,rearrange=.true.)
   end if
end if ! end if (.not. letkf_flag .or. lupd_obspace_serial)

end subroutine load_balance

subroutine estimate_work_enkf1(numobs)
! estimate work needed to update each analysis grid
! point (considering all the observations within the localization radius).
use covlocal, only:  latval

implicit none
integer(i_kind), dimension(:), intent(inout) :: numobs
real(r_single) :: deglat,corrlength,corrsq
type(kdtree2_result),dimension(:),allocatable :: sresults

integer nob,n1,n2,i,ideln

ideln = int(real(npts)/real(numproc))
n1 = 1 + nproc*ideln
n2 = (nproc+1)*ideln
if (nproc == numproc-1) n2 = npts
if (letkf_flag) allocate(sresults(nobstot))

! loop over 'good' obs.
numobs = 1 ! set min # of obs to 1, not 0 (so single ob test behaves)
!$omp parallel do  schedule(dynamic,1) private(nob,i,deglat,corrlength,sresults,corrsq)
obsloop: do i=n1,n2
    if (letkf_flag) then
       deglat = latsgrd(i)*rad2deg
       corrlength=latval(deglat,corrlengthnh,corrlengthtr,corrlengthsh)
       corrsq = corrlength**2
       call kdtree2_r_nearest(tp=kdtree_obs2,qv=gridloc(:,i),r2=corrsq,&
                              nfound=numobs(i),nalloc=nobstot,results=sresults)
    else
       do nob=1,nobstot
          if (sum((obloc(1:3,nob)-gridloc(1:3,i))**2,1) < corrlengthsq(nob)) &
          numobs(i) = numobs(i) + 1
       end do
    endif
end do obsloop
!$omp end parallel do
if (letkf_flag) deallocate(sresults)

end subroutine estimate_work_enkf1

subroutine estimate_work_enkf2(numobs)
! estimate work needed to update each observation prior
! (considering all the observations within the localization radius of each

implicit none
integer(i_kind), dimension(:), intent(inout) :: numobs

integer(i_kind)  nob,nob2,n1,n2,ideln

if (nobstot > numproc) then
   ideln = int(real(nobstot)/real(numproc))
   n1 = 1 + nproc*ideln
   n2 = (nproc+1)*ideln
   if (nproc == numproc-1) n2 = nobstot
else
   if(nproc < nobstot)then
     n1 = nproc+1
     n2 = n1
   else
     n1=1
     n2=0
   end if
end if

! loop over 'good' obs.
numobs = 0
!$omp parallel do  schedule(dynamic,1) private(nob,nob2)
obsloop: do nob2=n1,n2
    do nob=1,nobstot
    ! find number of obs close to this ob.
       if (sum((obloc(1:3,nob)-obloc(1:3,nob2))**2,1) < corrlengthsq(nob))&
       numobs(nob2) = numobs(nob2) + 1
    end do ! loop over obs on this processor
end do obsloop
!$omp end parallel do

end subroutine estimate_work_enkf2

subroutine loadbal_cleanup()
! deallocate module-level allocatable arrays
if (allocated(obloc_chunk)) deallocate(obloc_chunk)
if (allocated(grdloc_chunk)) deallocate(grdloc_chunk)
if (allocated(lnp_chunk)) deallocate(lnp_chunk)
if (allocated(oblnp_chunk)) deallocate(oblnp_chunk)
if (allocated(obtime_chunk)) deallocate(obtime_chunk)
if (allocated(ensmean_obchunk)) deallocate(ensmean_obchunk)
if (allocated(iprocob)) deallocate(iprocob)
if (allocated(indxob_chunk)) deallocate(indxob_chunk)
if (allocated(indxproc_obs)) deallocate(indxproc_obs)
if (allocated(numptsperproc)) deallocate(numptsperproc)
if (allocated(numobsperproc)) deallocate(numobsperproc)
if (allocated(indxproc)) deallocate(indxproc)
if (associated(kdtree_obs)) call kdtree2_destroy(kdtree_obs)
if (associated(kdtree_obs2)) call kdtree2_destroy(kdtree_obs2)
if (associated(kdtree_grid)) call kdtree2_destroy(kdtree_grid)
end subroutine loadbal_cleanup

end module loadbal


module Mod_OpticsDriver
    use typre
    use MPI
    use Mod_BroadCastBuffer
    use Mod_Listen
    use Mod_caseVariables
    use Mod_PhysicalProblemDriver
    use Mod_PhysicalProblem
    use Mod_DistributedContainer
    use Mod_DC_rp
    use Mod_DC_ip
    use Mod_InChannel
    use Mod_MasterVariables
    use Mod_Optics
   implicit none

   private

   public :: OpticsDriver, OpticsDriver_Const

   type, extends(DriverInterface) :: OpticsDriver

      type(OpticsProblem) :: Optics

      !Couplings
      type(InChannelGroupInfo) :: InNstincInfo
      type(InChannelGroupInfo) :: InTempeInfo

contains

      procedure :: Lev1Reapro             => optics_Lev1Reapro
      procedure :: Lev1ReaproMPI          => optics_Lev1ReaproMPI
      procedure :: SetOutChannels         => optics_SetOutChannels
      procedure :: SetInChannels          => optics_SetInChannels
      procedure :: UpdateChannels         => optics_UpdateChannels
      procedure :: Turnon                 => optics_Turnon
      procedure :: GetTimeStep            => optics_GetTimeStep
      procedure :: SetTimeStep            => optics_SetTimeStep
      procedure :: GetRefinementCriteria  => optics_GetRefinementCriteria
      procedure :: Refine                 => optics_Refine
      procedure :: Rebalance              => optics_Rebalance
      procedure :: Begste                 => optics_Begste
      procedure :: MeshProjections        => optics_MeshProjections
      procedure :: MeshAdvections         => optics_MeshAdvections
      procedure :: Doiter                 => optics_Doiter
      procedure :: Convergence            => optics_Convergence
      procedure :: Endste                 => optics_Endste
      procedure :: Output                 => optics_Output
      procedure :: Turnof                 => optics_Turnof
      procedure :: WriteTimes             => optics_WriteTimes

   end type OpticsDriver

   interface OpticsDriver_Const
      procedure constructor
   end interface

contains

   function constructor()
       class(OpticsDriver), pointer :: constructor

       allocate(constructor)
   end function constructor

    subroutine optics_Lev1Reapro(a,c)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c
      type(BroadCastBuffer) :: bb

      !Things that we want from outside
      if(a%Listener%words(1)=='EXTER') then
         !Velocity info
         if(a%Listener%words(2) == 'NSTIN') then
            call InChannelGroupInfoFromListener(a%Listener,a%InNstincInfo)
         endif
         !Temperature Info
         if(a%Listener%words(2) == 'TEMPE') then
            call InChannelGroupInfoFromListener(a%Listener,a%InTempeInfo)
         endif
       end if
   end subroutine

   subroutine optics_Lev1ReaproMPI(a,c,bb)
      class(OpticsDriver) :: a
      type(caseVariables) :: c
      type(BroadCastBuffer) :: bb

      call InChannelGroupInfoAddToBuffer(a%InNstincInfo,bb)
      call InChannelGroupInfoAddToBuffer(a%InTempeInfo,bb)
   end subroutine

   subroutine optics_SetOutChannels(a,task)
      class(OpticsDriver) :: a
      character(*) :: task

      class(DistributedContainer), pointer :: myDC => NULL()
      type(InChannel), pointer :: myInChannel => NULL()

      !-----------------------------------------------------------
      !First the OutChannels
      !No out channels
   end subroutine

   subroutine optics_SetInChannels(a)
      class(OpticsDriver) :: a

      integer(ip) :: kfl_dissi

      !--------------------------------------------------------
      !Secondly the InChannels

      !Nstinc info to channel list
      if (a%InNstincInfo%IsOn) then
         call a%AddToInChannelList('VELOC','VELOC','INTERPOLABLE',a%InNstincInfo)

         call a%AddToInChannelList('PRESS','PRESS','INTERPOLABLE',a%InNstincInfo)

         call a%AddToInChannelList('VISCOSITY','VISCOSITY','DO_NOT_INTERPOLATE',a%InNstincInfo)

         call a%Optics%GetDissipationModel(kfl_dissi)
         if (kfl_dissi == 1) then
            !NSDissipation
            call a%AddToInChannelList('NSTINC_DISSIPATION','DISSIPATION','INTERPOLABLE',a%InNstincInfo)
         endif

      endif

      !Tempe info to channel list
      if (a%InTempeInfo%IsOn) then
         call a%AddToInChannelList('TEMPE','TEMPE','INTERPOLABLE',a%InTempeInfo)

         call a%AddToInChannelList('DENSITY','DENSITY','DO_NOT_INTERPOLATE',a%InTempeInfo)

         call a%AddToInChannelList('SPECIFIC_HEAT','SPECIFIC_HEAT','DO_NOT_INTERPOLATE',a%InTempeInfo)

         call a%AddToInChannelList('THERMAL_CONDUCTIVITY','THERMAL_CONDUCTIVITY','DO_NOT_INTERPOLATE',a%InTempeInfo)

         call a%AddToInChannelList('TEMPE','TEMPE','INTERPOLABLE',a%InTempeInfo)

         call a%Optics%GetDissipationModel(kfl_dissi)
         if (kfl_dissi == 1) then
            !Dissipation
            call a%AddToInChannelList('TEMPE_DISSIPATION','DISSIPATION','INTERPOLABLE',a%InTempeInfo)

         endif

      endif

   end subroutine

   subroutine optics_UpdateChannels(a)
      implicit none
      class(OpticsDriver) :: a
      class(DistributedContainer), pointer :: myDC => NULL()

      real(rp), pointer :: veloc(:,:) => NULL(), press(:) => NULL(), tempe(:) => NULL()
      real(rp), pointer :: acden => NULL(), acvis => NULL(),actco => NULL(),acsph => NULL()
      real(rp), pointer :: veloc_dissipation(:) => NULL(), tempe_dissipation(:) => NULL()
      integer(ip) :: kfl_dissi

      if (a%InNstincInfo%IsOn) then
         call a%GetFromInChannelList('VELOC',myDC)
         call ExtractRP(myDC,veloc)
         call a%Optics%SetVelocityArray(veloc)

         call a%GetFromInChannelList('PRESS',myDC)
         call ExtractRP(myDC,press)
         call a%Optics%SetPressureArray(press)

         call a%GetFromInChannelList('VISCOSITY',myDC)
         call ExtractRP(myDC,acvis)
         call a%Optics%SetViscosity(acvis)

         call a%Optics%GetDissipationModel(kfl_dissi)
         if (kfl_dissi == 1) then
            call a%GetFromInChannelList('NSTINC_DISSIPATION',myDC)
            call ExtractRP(myDC,veloc_dissipation)
            if (.not. associated(veloc_dissipation)) call runend('OpticsDriver: nstincDissipation not found!')
            call a%Optics%SetNSDissipationArray(veloc_dissipation)
         endif
      endif

      if (a%InTempeInfo%IsOn) then
         call a%GetFromInChannelList('TEMPE',myDC)
         call ExtractRP(myDC,tempe)
         call a%Optics%SetTemperatureArray(tempe)

         call a%GetFromInChannelList('DENSITY',myDC)
         call ExtractRP(myDC,acden)
         call a%Optics%SetDensity(acden)

         call a%GetFromInChannelList('SPECIFIC_HEAT',myDC)
         call ExtractRP(myDC,acsph)
         call a%Optics%SetSpecificHeat(acsph)

         call a%GetFromInChannelList('THERMAL_CONDUCTIVITY',myDC)
         call ExtractRP(myDC,actco)
         call a%Optics%SetThermalConductivity(actco)

         call a%Optics%GetDissipationModel(kfl_dissi)
         if (kfl_dissi == 1) then
            call a%GetFromInChannelList('TEMPE_DISSIPATION',myDC)
            call ExtractRP(myDC,tempe_dissipation)
            if (.not. associated(tempe_dissipation)) call runend('OpticsDriver: tempeDissipation not found!')
            call a%Optics%SetTempeDissipationArray(tempe_dissipation)
         endif
      endif

   end subroutine

   subroutine optics_Turnon(a,c)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c

      !PhysicalProblem operations
      call physical_Turnon(a,c,a%Optics)
   end subroutine

   subroutine optics_GetTimeStep(a,c)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c

      !PhysicalProblem operations
      call physical_GetTimeStep(a,c,a%Optics)

   end subroutine optics_GetTimeStep

   subroutine optics_SetTimeStep(a,c)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c

      !PhysicalProblem operations
      call physical_SetTimeStep(a,c,a%Optics)

   end subroutine optics_SetTimeStep

   subroutine optics_GetRefinementCriteria(a,c)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c

      !PhysicalProblem operations
      call physical_GetRefinementCriteria(a,c,a%Optics)

   end subroutine optics_GetRefinementCriteria

   subroutine optics_Refine(a,c)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c

      !PhysicalProblem operations
      call physical_Refine(a,c,a%Optics)

   end subroutine optics_Refine

   subroutine optics_Rebalance(a,c)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c

      !PhysicalProblem operations
      call physical_Rebalance(a,c,a%Optics)

   end subroutine optics_Rebalance

   subroutine optics_Begste(a,c)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c

      !PhysicalProblem operations
      call physical_Begste(a,c,a%Optics)

   end subroutine optics_Begste

   subroutine optics_MeshProjections(a,c,itask)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c
      integer(ip)         :: itask

      !PhysicalProblem operations
      call physical_MeshProjections(a,c,a%Optics,itask)

   end subroutine optics_MeshProjections

   subroutine optics_MeshAdvections(a,c,itask)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c
      integer(ip)         :: itask

      !PhysicalProblem operations
      call physical_MeshAdvections(a,c,a%Optics,itask)

   end subroutine optics_MeshAdvections

   subroutine optics_Doiter(a,c)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c

      !PhysicalProblem operations
      call physical_Doiter(a,c,a%Optics)

   end subroutine optics_Doiter

   subroutine optics_Convergence(a,c,glres)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c
      real(rp)            :: glres

      !PhysicalProblem operations
      call physical_Convergence(a,c,a%Optics,glres)

   end subroutine optics_Convergence

   subroutine optics_Endste(a,c)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c

      !PhysicalProblem operations
      call physical_Endste(a,c,a%Optics)

   end subroutine optics_Endste

   subroutine optics_Output(a,c)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c

      !PhysicalProblem operations
      call physical_Output(a,c,a%Optics)

   end subroutine optics_Output

   subroutine optics_Turnof(a,c)
      implicit none
      class(OpticsDriver) :: a
      type(caseVariables) :: c

      !PhysicalProblem operations
      call physical_Turnof(a,c,a%Optics)

   end subroutine optics_Turnof

   subroutine optics_WriteTimes(a)
      implicit none
      class(OpticsDriver) :: a

      !PhysicalProblem operations
      call physical_WriteTimes(a,a%Optics)

   end subroutine optics_WriteTimes

end module