!***********************************************************************
!  POTENTIAL EVAPOTRANSPIRATION
!     File PET.for
!***********************************************************************
!  Includes modules:
!MEEVP Routine Description
!   A  PETASCE ASCE Standardized Reference Evapotranspiration Equation
!                for tall reference (alfalfa) with dual FAO-56 crop
!                coefficient
!   F  PETPEN  FAO Penman-Monteith (FAO-56) potential evapotranspiration,
!                with KC = 1.0
!   G  PETASCE ASCE Standardized Reference Evapotranspiration Equation
!                for short reference (grass) with dual FAO-56 crop
!                coefficient
!   R  PETPT   Calculates Priestly-Taylor potential evapotranspiration
!                (default method)
!   D  PETDYN  Dynamic Penman-Monteith, pot. evapotranspiration, with
!                dynamic input of LAI, crop height effects on Ra and Rs
!   P  PETPNO  FAO Penman (FAO-24) potential evapotranspiration
!   M  PETMEY  "Standard reference evaporation calculation for inland
!                south eastern Australia" By Wayne Meyer 1993

!  Also includes these subroutines:
!      PSE        Potential soil evaporation
!      FLOOD_EVAP Evaporation from water surface
C=======================================================================

C=======================================================================
C  YR_DOY, Subroutine, N.B. Pickering, 09/13/91
C  Converts YRDOY to YR and DOY.
C-----------------------------------------------------------------------
C  Input : YRDOY
C  Output: YR,DOY
C=======================================================================

      SUBROUTINE YR_DOY(YRDOY,YR,DOY)

      IMPLICIT NONE

      INTEGER DOY,YR,YRDOY

      YR  = INT(YRDOY / 1000)
      DOY = YRDOY - YR * 1000

      END SUBROUTINE YR_DOY

C=======================================================================

C=======================================================================
C  VPSLOP, Real Function, N.B. Pickering, 4/1/90
C  Calculates slope of saturated vapor pressure versus temperature curve
C  using Classius-Clapeyron equation (see Brutsaert, 1982 p. 41)
!-----------------------------------------------------------------------
!  Called by: ETSOLV, PETPEN, TRATIO
!  Calls:     VPSAT
!-----------------------------------------------------------------------
C  Input : T (C)
C  Output: VPSLOP
C=======================================================================

      REAL FUNCTION VPSLOP(T)

      IMPLICIT NONE

      REAL T,VPSAT

C     dEsat/dTempKel = MolWeightH2O * LatHeatH2O * Esat / (Rgas * TempKel^2)

      VPSLOP = 18.0 * (2501.0-2.373*T) * VPSAT(T) / (8.314*(T+273.0)**2)

      RETURN
      END FUNCTION VPSLOP
C=======================================================================

C=======================================================================
C  VPSAT, Real Function, N.B. Pickering, 4/1/90
C  Calculates saturated vapor pressure of air (Tetens, 1930).
!-----------------------------------------------------------------------
!  Called by: CANPET, HMET, VPSLOP, PETPEN
!  Calls:     None
!-----------------------------------------------------------------------
C  Input : T (C)
C  Output: VPSAT (Pa)
C=======================================================================

      REAL FUNCTION VPSAT(T)

      IMPLICIT NONE
      REAL T

      VPSAT = 610.78 * EXP(17.269*T/(T+237.30))

      RETURN
      END FUNCTION VPSAT
C=======================================================================
! VPSAT Variables
!-----------------------------------------------------------------------
! T     Air temperature (oC)
! VPSAT Saturated vapor pressure of air (Pa)
C=======================================================================

C=======================================================================
!     SUBROUTINE PET
!     Calls appropriate potential evapotranspiration routine

      SUBROUTINE PET(CONTROL,
     &      ET_ALB, XHLAI, MEEVP, WEATHER,  !Input for all
     &      EORATIO, !Needed by Penman-Monteith
     &      CANHT,   !Needed by dynamic Penman-Monteith
     &      EO)      !Output

      USE mini_ModuleDefs
      IMPLICIT NONE
      SAVE

      TYPE (WeatherType) WEATHER
      TYPE (ControlType) CONTROL
      CHARACTER*1 MEEVP
      INTEGER YRDOY, YEAR, DOY
      REAL CANHT, CLOUDS, EO, EORATIO, ET_ALB, SRAD, TAVG, TDEW
      REAL TMAX, TMIN, VAPR, WINDHT, WINDSP, XHLAI
      REAL WINDRUN, XLAT, XELEV

      CLOUDS = WEATHER % CLOUDS
      SRAD   = WEATHER % SRAD
      TAVG   = WEATHER % TAVG
      TDEW   = WEATHER % TDEW
      TMAX   = WEATHER % TMAX
      TMIN   = WEATHER % TMIN
      VAPR   = WEATHER % VAPR
      WINDHT = WEATHER % WINDHT
      WINDSP = WEATHER % WINDSP
      WINDRUN= WEATHER % WINDRUN
      XLAT   = WEATHER % XLAT
      XELEV  = WEATHER % XELEV

      YRDOY = CONTROL % YRDOY
      CALL YR_DOY(YRDOY, YEAR, DOY)

          SELECT CASE (MEEVP)
          !Penman-Monteith reference ET based on the ASCE Standardized
          !Reference Evapotranspiration Equation
          CASE ('A','G')
            CALL PETASCE(
     &        CANHT, DOY, ET_ALB, MEEVP, SRAD, TDEW,      !Input
     &        TMAX, TMIN, WINDHT, WINDRUN, XHLAI,         !Input
     &        XLAT, XELEV,                                !Input
     &        EO)                                         !Output

!         ------------------------
          !FAO Penman-Monteith (FAO-56) potential evapotranspiration,
!             with KC = 1.0
          CASE ('F')
            CALL PETPEN(
     &        CLOUDS, EORATIO, ET_ALB, SRAD, TAVG, TDEW,  !Input
     &        TMAX, TMIN, VAPR, WINDSP, WINDHT, XHLAI,    !Input
     &        EO)                                         !Output

!         ------------------------
          !Dynamic Penman-Monteith, pot. evapotranspiration, with
!             dynamic input of LAI, crop height effects on Ra and Rs
          CASE ('D')
            CALL PETDYN(
     &        CANHT, CLOUDS, ET_ALB, SRAD, TAVG, TDEW,    !Input
     &        TMAX, TMIN, WINDSP, XHLAI,                  !Input
     &        EO)                                         !Output
!         ------------------------
          !FAO Penman (FAO-24) potential evapotranspiration
          CASE ('P')
            CALL PETPNO(
     &        CLOUDS, ET_ALB, SRAD, TAVG, TDEW,           !Input
     &        TMAX, TMIN, WINDSP, XHLAI,                  !Input
     &        EO)                                         !Output
!         ------------------------
          !Penman - Meyer routine for estimation of Et in Southern NSW
          CASE ('M')
            CALL PETMEY(CONTROL,
     &        TAVG, WINDSP, SRAD, TDEW, XHLAI, ET_ALB,    !Input
     &        EO)                                         !Output
!         ------------------------
          !Observed Potential ET from Weather file (Future)
          !CASE ('O')
          !    EO = EOMEAS
!         ------------------------
          !Priestly-Taylor potential evapotranspiration
          CASE DEFAULT !Default - MEEVP = 'R'
            CALL PETPT(
     &        ET_ALB, SRAD, TMAX, TMIN, XHLAI,          !Input
     &        EO)                                       !Output
!         ------------------------
          END SELECT

      RETURN
      END SUBROUTINE PET

C=======================================================================

C=======================================================================
C  PETASCE, Subroutine, K. R. Thorp
C  Calculates reference evapotranspiration using the ASCE
C  Standardized Reference Evapotranspiration Equation.
C  Adjusts reference evapotranspiration to potential evapotranspiration
C  using dual crop coefficients.
C  DeJonge K. C., Thorp, K. R., 2017. Implementing standardized refernce
C  evapotranspiration and dual crop coefficient approach in the DSSAT
C  Cropping System Model. Transactions of the ASABE. 60(6):1965-1981.
!-----------------------------------------------------------------------
C  REVISION HISTORY
C  08/19/2013 KRT Added the ASCE Standardize Reference ET approach
C  01/26/2015 KRT Added the dual crop coefficient (Kc) approach
C  01/18/2018 KRT Merged ASCE dual Kc ET method into develop branch
!-----------------------------------------------------------------------
!  Called from:   PET
!  Calls:         None
C=======================================================================
      SUBROUTINE PETASCE(
     &        CANHT, DOY, MSALB, MEEVP, SRAD, TDEW,       !Input
     &        TMAX, TMIN, WINDHT, WINDRUN, XHLAI,         !Input
     &        XLAT, XELEV,                                !Input
     &        EO)                                         !Output
!-----------------------------------------------------------------------
      USE mini_ModuleDefs
      USE ModuleData
      IMPLICIT NONE
      SAVE
!-----------------------------------------------------------------------
!     INPUT VARIABLES:
      REAL CANHT, MSALB, SRAD, TDEW, TMAX, TMIN, WINDHT, WINDRUN
      REAL XHLAI, XLAT, XELEV
      INTEGER DOY
      CHARACTER*1 MEEVP
!-----------------------------------------------------------------------
!     OUTPUT VARIABLES:
      REAL EO
!-----------------------------------------------------------------------
!     LOCAL VARIABLES:
      REAL TAVG, PATM, PSYCON, UDELTA, EMAX, EMIN, ES, EA, FC, FEW, FW
      REAL ALBEDO, RNS, PIE, DR, LDELTA, WS, RA1, RA2, RA, RSO, RATIO
      REAL FCD, TK4, RNL, RN, G, WINDSP, WIND2m, Cn, Cd, KCMAX, RHMIN
      REAL WND, CHT
      REAL REFET, SKC, KCBMIN, KCBMAX, KCB, KE, KC
!-----------------------------------------------------------------------

!     ASCE Standardized Reference Evapotranspiration
!     Average temperature (ASCE Standard Eq. 2)
      TAVG = (TMAX + TMIN) / 2.0 !deg C

!     Atmospheric pressure (ASCE Standard Eq. 3)
      PATM = 101.3 * ((293.0 - 0.0065 * XELEV)/293.0) ** 5.26 !kPa

!     Psychrometric constant (ASCE Standard Eq. 4)
      PSYCON = 0.000665 * PATM !kPa/deg C

!     Slope of the saturation vapor pressure-temperature curve
!     (ASCE Standard Eq. 5)                                !kPa/degC
      UDELTA = 2503.0*EXP(17.27*TAVG/(TAVG+237.3))/(TAVG+237.3)**2.0

!     Saturation vapor pressure (ASCE Standard Eqs. 6 and 7)
      EMAX = 0.6108*EXP((17.27*TMAX)/(TMAX+237.3)) !kPa
      EMIN = 0.6108*EXP((17.27*TMIN)/(TMIN+237.3)) !kPa
      ES = (EMAX + EMIN) / 2.0                     !kPa

!     Actual vapor pressure (ASCE Standard Eq. 8)
      EA = 0.6108*EXP((17.27*TDEW)/(TDEW+237.3)) !kPa

!     RHmin (ASCE Standard Eq. 13, RHmin limits from FAO-56 Eq. 70)
      RHMIN = MAX(20.0, MIN(80.0, EA/EMAX*100.0))

!     Net shortwave radiation (ASCE Standard Eq. 16)
      IF (XHLAI .LE. 0.0) THEN
        ALBEDO = MSALB
      ELSE
        ALBEDO = 0.23
      ENDIF
      RNS = (1.0-ALBEDO)*SRAD !MJ/m2/d

!     Extraterrestrial radiation (ASCE Standard Eqs. 21,23,24,27)
      PIE = 3.14159265359
      DR = 1.0+0.033*COS(2.0*PIE/365.0*DOY) !Eq. 23
      LDELTA = 0.409*SIN(2.0*PIE/365.0*DOY-1.39) !Eq. 24
      WS = ACOS(-1.0*TAN(XLAT*PIE/180.0)*TAN(LDELTA)) !Eq. 27
      RA1 = WS*SIN(XLAT*PIE/180.0)*SIN(LDELTA) !Eq. 21
      RA2 = COS(XLAT*PIE/180.0)*COS(LDELTA)*SIN(WS) !Eq. 21
      RA = 24.0/PIE*4.92*DR*(RA1+RA2) !MJ/m2/d Eq. 21

!     Clear sky solar radiation (ASCE Standard Eq. 19)
      RSO = (0.75+2E-5*XELEV)*RA !MJ/m2/d

!     Net longwave radiation (ASCE Standard Eqs. 17 and 18)
      RATIO = SRAD/RSO
      IF (RATIO .LT. 0.3) THEN
        RATIO = 0.3
      ELSEIF (RATIO .GT. 1.0) THEN
        RATIO = 1.0
      END IF
      FCD = 1.35*RATIO-0.35 !Eq 18
      TK4 = ((TMAX+273.16)**4.0+(TMIN+273.16)**4.0)/2.0 !Eq. 17
      RNL = 4.901E-9*FCD*(0.34-0.14*SQRT(EA))*TK4 !MJ/m2/d Eq. 17

!     Net radiation (ASCE Standard Eq. 15)
      RN = RNS - RNL !MJ/m2/d

!     Soil heat flux (ASCE Standard Eq. 30)
      G = 0.0 !MJ/m2/d

!     Wind speed (ASCE Standard Eq. 33)
      WINDSP = WINDRUN * 1000.0 / 24.0 / 60.0 / 60.0 !m/s
      WIND2m = WINDSP * (4.87/LOG(67.8*WINDHT-5.42))

!     Aerodynamic roughness and surface resistance daily timestep constants
!     (ASCE Standard Table 1)
      SELECT CASE(MEEVP) !
        CASE('A') !Alfalfa reference
          Cn = 1600.0 !K mm s^3 Mg^-1 d^-1
          Cd = 0.38 !s m^-1
        CASE('G') !Grass reference
          Cn = 900.0 !K mm s^3 Mg^-1 d^-1
          Cd = 0.34 !s m^-1
      END SELECT

!     Standardized reference evapotranspiration (ASCE Standard Eq. 1)
      REFET =0.408*UDELTA*(RN-G)+PSYCON*(Cn/(TAVG+273.0))*WIND2m*(ES-EA)
      REFET = REFET/(UDELTA+PSYCON*(1.0+Cd*WIND2m)) !mm/d
      REFET = MAX(0.0001, REFET)

!     FAO-56 dual crop coefficient approach
!     Basal crop coefficient (Kcb)
!     Also similar to FAO-56 Eq. 97
!     KCB is zero when LAI is zero
      CALL GET('SPAM', 'SKC', SKC)
      CALL GET('SPAM', 'KCBMIN', KCBMIN)
      CALL GET('SPAM', 'KCBMAX', KCBMAX)
      IF (XHLAI .LE. 0.0) THEN
         KCB = 0.0
      ELSE
         !DeJonge et al. (2012) equation
         KCB = MAX(0.0,KCBMIN+(KCBMAX-KCBMIN)*(1.0-EXP(-1.0*SKC*XHLAI)))
      ENDIF

      !Maximum crop coefficient (Kcmax) (FAO-56 Eq. 72)
      WND = MAX(1.0,MIN(WIND2m,6.0))
      CHT = MAX(0.001,CANHT)
      SELECT CASE(MEEVP)
        CASE('A') !Alfalfa reference
            KCMAX = MAX(1.0,KCB+0.05)
        CASE('G') !Grass reference
            KCMAX = MAX((1.2+(0.04*(WND-2.0)-0.004*(RHMIN-45.0))
     &                      *(CHT/3.0)**(0.3)),KCB+0.05)
      END SELECT

      !Effective canopy cover (fc) (FAO-56 Eq. 76)
      IF (KCB .LE. KCBMIN) THEN
         FC = 0.0
      ELSE
         FC = ((KCB-KCBMIN)/(KCMAX-KCBMIN))**(1.0+0.5*CANHT)
      ENDIF

      !Exposed and wetted soil fraction (FAO-56 Eq. 75)
      !Unresolved issue with FW (fraction wetted soil surface).
      !Some argue FW should not be used to adjust demand.
      !Rather wetting fraction issue should be addressed on supply side.
      !Difficult to do with a 1-D soil water model
      FW = 1.0
      FEW = MIN(1.0-FC,FW)

      !Potential evaporation coefficient (Ke) (Based on FAO-56 Eq. 71)
      !Kr = 1.0 since this is potential Ke. Model routines handle stress
      KE = MAX(0.0, MIN(1.0*(KCMAX-KCB), FEW*KCMAX))

      !Potential crop coefficient (Kc) (FAO-56 Eqs. 58 & 69)
      KC = KCB + KE

      !Potential evapotranspiration (FAO-56 Eq. 69)
      EO = (KCB + KE) * REFET

      EO = MAX(EO,0.0001)

      CALL PUT('SPAM', 'REFET', REFET)
      CALL PUT('SPAM', 'KCB', KCB)
      CALL PUT('SPAM', 'KE', KE)
      CALL PUT('SPAM', 'KC', KC)

!-----------------------------------------------------------------------
      RETURN
      END SUBROUTINE PETASCE
!-------------------------------------------------------------------

C=======================================================================

C=======================================================================
C  PETPEN, Subroutine, N.B. Pickering
C  Calculates FAO-56 Penman-Monteith potential evapotranspiration, exactly
C  grass reference, with place for optional Kc, need this Kc in species.
!-----------------------------------------------------------------------
C  REVISION HISTORY
C  02/19/1992 NBP Written
C  11/04/1993 NBP Renamed routine PET to PETPEN.  Changed XLAI to XHLAI
C               Added XHLAI .LE. 0.0 statement.
C  05/13/1994 NBP Converted all vapor pressures to Pa.  Rearranged.
C  09/16/1994 NBP Added limits to prevent EO and ES (PE) < 0.
C  10/17/1997 CHP Updated for modular format.
C  09/01/1999 GH  Incorporated into CROPGRO
C  05/06/2002 WMB Fixed Stefan-Boltzmann constant
C  01/15/2003 KJB discarded old Penman FAO-24 (it is much too stressful)
C     replaced with Penman FAO-56, exactly grass reference, with explicit
C     LAI 2.88, height 0.12 m, Rs = 100/(0.5*2.88)
C  01/15/2003 KJB:  THREE ISSUES TO ADDRESS:
C  1) USING FIXED ALBEDO, BECAUSE THAT IS HOW REFERENCE IS DEFINED
C  2)  PRESENTLY USING A LOCKED-IN VALUE OF 1.1 TO GIVE KC OF 1.1
C  I WOULD LIKE TO SEE OPTION OF SPECIES INPUT OF KC=1.1 TO 1.3
C  3) WINDHT WAS IN OLD, APPARENTLY 2.0, NO LONGER HERE.  ???
C  02/06/2003 KJB/CHP Added EORATIO as input from plant routines.
!  07/24/2006 CHP Use MSALB instead of SALB (includes mulch and soil
!                 water effects on albedo)
!  09/19/2006 SSJ Fixed error in REFHT calc as noted below.
!  08/25/2011 CHP Use measured vapor pressure (VAPR), if available
!-----------------------------------------------------------------------
!  Called from:   PET
!  Calls:         None
C=======================================================================
      SUBROUTINE PETPEN(
     &    CLOUDS, EORATIO, MSALB, SRAD, TAVG, TDEW,       !Input
     &    TMAX, TMIN, VAPR, WINDSP, WINDHT, XHLAI,        !Input
     &    EO)                                             !Output
!-----------------------------------------------------------------------
      IMPLICIT NONE
      SAVE
!-----------------------------------------------------------------------
!     INPUT VARIABLES:
      REAL CLOUDS, EORATIO, MSALB, SRAD, TAVG, TDEW, TMAX, TMIN,
     &        WINDSP, XHLAI, WINDSP_M
!-----------------------------------------------------------------------
!     OUTPUT VARIABLES:
      REAL EO
!-----------------------------------------------------------------------
!     LOCAL VARIABLES:
      REAL ALBEDO, EAIR, ESAT, G, LHVAP, PSYCON, RADB,
     &  RNET, RNETMG, S, TK4,
     &  VHCAIR, VPD, DAIR, RT, ET0, KC, WINDHT, VAPR
      REAL SHAIR, PATM, SBZCON
      REAL k, d, REFHT, Zom, Zoh, ra, rl, rs    !added for PenMon
!      REAL alt_RADB, Tprev
!      INTEGER THREEDAYCOUNT
!      REAL    THREEDAYAVG(3)

!     PARAMETER (WINDHT = 2.0)
C     PARAMETER (SHAIR = 1005.0)
      PARAMETER (SHAIR = 0.001005)  !changed for PenMon to MJ/kg/K
      PARAMETER (PATM = 101300.0)
!      PARAMETER (SBZCON=4.093E-9)  !(MJ/m2/d)
      PARAMETER (SBZCON=4.903E-9)   !(MJ/K4/m2/d) fixed constant 5/6/02
!-----------------------------------------------------------------------
!     FUNCTION SUBROUTINES:
      REAL VPSLOP, VPSAT      !Found in file HMET.for

C-----------------------------------------------------------------------
C     Compute air properties.
      LHVAP = (2501.0-2.373*TAVG) * 1000.0                ! J/kg
C     PSYCON = SHAIR * PATM / (0.622*LHVAP)               ! Pa/K
      PSYCON = SHAIR * PATM / (0.622*LHVAP) * 1000000     ! Pa/K

!     Previous code:
      ESAT = (VPSAT(TMAX)+VPSAT(TMIN)) / 2.0              ! Pa
      EAIR = VPSAT(TDEW)                                  ! Pa

!     If actual vapor pressure is available, use it.
      IF (VAPR > 1.E-6) THEN
        EAIR = VAPR * 1000.
      ENDIF

      VPD = MAX(0.0, ESAT - EAIR)                         ! Pa
      S = (VPSLOP(TMAX)+VPSLOP(TMIN)) / 2.0               ! Pa/K
      RT = 8.314 * (TAVG + 273.0)                         ! N.m/mol
      DAIR = 0.028966*(PATM-0.387*EAIR)/RT                ! kg/m3
C BAD DAIR = 0.1 * 18.0 / RT * ((PATM  -EAIR)/0.622 + EAIR)   ! kg/m3
      VHCAIR = DAIR * SHAIR    !not used                  ! J/m3

C     Convert windspeed to 2 m reference height.
!     Do this conversion in WEATHR and send out 2m windspeed
!     CHP 11/26/01
!      WIND2 = WINDSP * (2.0/WINDHT)**0.2

C       Calculate aerodynamic resistance (ra).
C       ra (d/m) = {ln[zm-d/zom]*ln[zh-d/zoh]}/(k^2*uz)
C       zm = ht.wind measurement (m), zh = ht.humidity measurement (m),
C       zom,zoh=rooughness length of momentum, heat and vapor x-fer (m)
C       k=von Karman's constant 0.41, uz=WINDSP @ z m/d,
C       d = zero plane displacement height (m)

        REFHT = 0.12                 !arbitrary for testing PenMon
        WINDSP_M = WINDSP*(1000.)     !Converts km/d to m/d
        k = 0.41                     !von Karman's constant

!       was 2/3, which (for integers) results in zero!!
!       SSJ 9/19/2006 added the decimals
        !d = (2/3)*REFHT
        d = (2./3.)*REFHT

        Zom = 0.123*REFHT
        Zoh = 0.1*Zom
        ra = (LOG((WINDHT-d)/Zom)*LOG((WINDHT-d)/Zoh))/((k**2)*WINDSP_M)

C       Calculate surface resistance (rs).
C       rs = rl/LAIactive       rs (s m^-1),
C       rl = bulk stomatal resistance of the well-illuminated leaf (s m^-1)

        rl = 100           !value assummed from FAO grass reference
        rs = rl/(0.5*2.88) !0.5*XHLAI assumes half of LA is contributing
C                          !  to heat/vapor transfer
        rs = rs/86400      !converts (s m^-1 to d/m)

C     Calculate net radiation (MJ/m2/d).  By FAO method 1990. EAIR is divided
C       by 1000 to convert Pa to KPa.

c     MJ, 2007-04-11
c     --------------
c     There appears to be no support for soil heat flux (G), apart
c     from the variable already existing; it is just always set to
c     0, for some reason.
c     Here is the (improved) CANEGRO method for calculating G
c     (Allen, R.G. et al 1989,
c     'Operational Estimates of Reference Evapotranspiration',
c     Agronomy Journal Vol. 81, No. 4),
c     http://www.kimberly.uidaho.edu/water/papers/evapotranspiration/
c                   Allen_Operational_Estimates_Reference_ET_1989.pdf
c     :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c         3-day sum of average temperature:
c          IF (THREEDAYCOUNT .LT. 1) THEN
c             Initialise
c              THREEDAYCOUNT = 1
c              THREEDAYAVG   = Tavg
c          ELSE IF (THREEDAYCOUNT .GE. 3) THEN
c              THREEDAYCOUNT = 1
c          ELSE
c              THREEDAYCOUNT = THREEDAYCOUNT + 1
c          ENDIF
c          THREEDAYAVG(THREEDAYCOUNT) = Tavg
c          Tprev = SUM(THREEDAYAVG)/3.
c          G = (Tavg-Tprev) * 0.38
c     --------------
c     MJ, 2007-04-12:
c     :::::::::::::::
c     FAO suggests that G be set to 0.  Oh well.
c     ------------------------------------------

      G = 0.0
      IF (XHLAI .LE. 0.0) THEN
        ALBEDO = MSALB
      ELSE
C  KJB NOTE THAT REFERENCE IS ALWAYS ALBEDO FIXED TO 0.23,  OLD PEN VARIED
C  THE ALBEDO WITH LAI.  WHAT DO WE WANT?  IS THIS PART OF THE REASON THAT
C  KC IS NEEDED WITH THE REFERENCE FORMULATION?
C       ALBEDO = 0.23-(0.23-SALB)*EXP(-0.75*XHLAI)
        ALBEDO = 0.23
      ENDIF

      TK4 = ((TMAX+273.)**4+(TMIN+273.)**4) / 2.0
C
C     BELOW WAS THE OLD PENMAN, DIFFERENT CLOUDS METHOD, EAIR CHG IS GOOD
C     RADB = SBZCON * TK4 * (0.4 - 0.005 * SQRT(EAIR)) *
C    &        (1.1 * (1. - CLOUDS) - 0.1)
C

      RADB = SBZCON * TK4 * (0.34 - 0.14 * SQRT(EAIR/1000)) *
     &        (1.35 * (1. - CLOUDS) - 0.35)

      RNET= (1.0-ALBEDO)*SRAD - RADB

C     Compute EO using Penman-Montieth

      RNETMG = (RNET-G)
C     !MJ/m2/d
        ET0 = ((S*RNETMG + (DAIR*SHAIR*VPD)/ra)/(S+PSYCON*(1+rs/ra)))
C     !Converts MJ/m2/d to mm/d
        ET0 = ET0/ (LHVAP / 1000000.)
        IF (XHLAI .LE. 6.0) THEN
        XHLAI = XHLAI
        ELSE
        XHLAI = 6.0
        ENDIF
C   KJB LATER, NEED TO PUT VARIABLE IN PLACE OF 1.1
!      KC=1.0+(1.1-1.0)*XHLAI/6.0
      KC=1.0+(EORATIO-1.0)*XHLAI/6.0
      EO=ET0*KC
C     EO=ET0
        EO = MAX(EO,0.0)
!###  EO = MAX(EO,0.0)   !gives error in DECRAT_C
      EO = MAX(EO,0.0001)

!-----------------------------------------------------------------------
      RETURN
      END SUBROUTINE PETPEN

!-----------------------------------------------------------------------
!     PETPEN VARIABLES:
!-----------------------------------------------------------------------
! ALBEDO  Reflectance of soil-crop surface (fraction)
! CLOUDS  Relative cloudiness factor (0-1)
! DAIR
! EAIR    Vapor pressure at dewpoint (Pa)
! EO      Potential evapotranspiration rate (mm/d)
! ESAT    Vapor pressure of air (Pa)
! G       Soil heat flux density term (MJ/m2/d)
! LHVAP   Latent head of water vaporization (J/kg)
! PATM     = 101300.0
! PSYCON  Psychrometric constant (Pa/K)
! RADB    Net outgoing thermal radiation (MJ/m2/d)
! RNET    Net radiation (MJ/m2/d)
! RNETMG  Radiant energy portion of Penman equation (mm/d)
! RT
! S       Rate of change of saturated vapor pressure of air with
!           temperature (Pa/K)
! MSALB   Soil albedo with mulch and soil water effects (fraction)
! SBZCON   Stefan Boltzmann constant = 4.903E-9 (MJ/m2/d)
! SHAIR    = 1005.0
! SRAD    Solar radiation (MJ/m2-d)
! TAVG    Average daily temperature (�C)
! TDEW    Dewpoint temperature (�C)
! TK4     Temperature to 4th power ((oK)**4)
! TMAX    Maximum daily temperature (�C)
! TMIN    Minimum daily temperature (�C)
! Tprev   3-day sum of average temperature:
! VHCAIR
! VPD     Vapor pressure deficit (Pa)
! VPSAT   Saturated vapor pressure of air (Pa)
! VPSLOP  Calculates slope of saturated vapor pressure versus
!           temperature curve (Pa/K)
! WFNFAO  FAO 24 hour wind function
! WIND2   Windspeed at 2m reference height. (km/d)
! WINDSP  Wind speed at 2m (km/d)
! XHLAI   Leaf area index (m2[leaf] / m2[ground])
!-----------------------------------------------------------------------
!     END SUBROUTINE PETPEN
!-----------------------------------------------------------------------

C=======================================================================
C  PETDYN Subroutine, K. J. BOOTE, F. SAU, M. BOSTIC
C  Calculates PENMAN-MONTEITH potential evapotranspiration
C  using dynamic CANHT, LAI, along with wind effects on Ra, Rs
C  Steiner approach for Ra recommended, but FAO and Lhomme commented out
C  Sunlit LAI effect on Rs is recommended, but rl/(0.5*LAI) would work
C  Weighting used for Ra and Rs between soil and crop.  Need to changee
C  two constants (HTS and zos) if you change from sunlit LAI to other.
C-----------------------------------------------------------------------
C  REVISION HISTORY
C  11/19/01 TO 1/15/02  Written By Boote, Sau, McNair
C  01/15/03 Moved from V3.5 trial to V4.0  by K. J. Boote
!  07/24/2006 CHP Use MSALB instead of SALB (includes mulch and soil
!                 water effects on albedo)

!  Called from:   PET
!  Calls:         None
C=======================================================================
      SUBROUTINE PETDYN(
     &    CANHT, CLOUDS, MSALB, SRAD, TAVG, TDEW,         !Input
     &    TMAX, TMIN, WINDSP, XHLAI,                      !Input
     &    EO)                                             !Output
C  Calculates Penman-Monteith evapotranspiration
!-----------------------------------------------------------------------
      IMPLICIT NONE
      SAVE
!-----------------------------------------------------------------------
!     INPUT VARIABLES:
      REAL CLOUDS, MSALB, SRAD, TAVG, TDEW, TMAX, TMIN,
     &        WINDSP, XHLAI, WINDSP_M
!-----------------------------------------------------------------------
!     OUTPUT VARIABLES:
      REAL EO
!-----------------------------------------------------------------------
!     LOCAL VARIABLES:
      REAL ALBEDO, EAIR, ESAT, G, LHVAP, PSYCON, RADB,
     &  RNET, RNETMG, S, TK4,
     &  VHCAIR, VPD, DAIR, RT
      REAL SHAIR, PATM, SBZCON
      REAL k,DFAO, CANHT, ZOMF, ZOHF, ra, rl, rs, RAERO !add for PenDyn
      REAL ZCROP,DCROP,ZOMC,ZOVC,WIND2C,RASOIL,HTS,DLH,ZOLH
!      REAL MAXHT, rb, AC, AS, zos, RTOT                  !add for PenDyn
!     The variable 'AS' above has been changed to 'ASVar' because 'AS' is a
!     Python keyword
      REAL MAXHT, rb, AC, ASVar, zos, RTOT                  !add for PenDyn
C     PARAMETER (SHAIR = 1005.0)
      PARAMETER (SHAIR = 0.001005)  !changed for PenDyn to MJ/kg/K
      PARAMETER (PATM = 101300.0)
!      PARAMETER (SBZCON=4.093E-9)  !(MJ/m2/d)
      PARAMETER (SBZCON=4.903E-9)   !(MJ/K4/m2/d) fixed constant 5/6/02
!-----------------------------------------------------------------------
!     FUNCTION SUBROUTINES:
      REAL VPSLOP, VPSAT      !Found in file HMET.for

C-----------------------------------------------------------------------
C     Compute air properties.
      LHVAP = (2501.0-2.373*TAVG) * 1000.0                 ! J/kg
C     PSYCON = SHAIR * PATM / (0.622*LHVAP)                ! Pa/K
      PSYCON = SHAIR * PATM / (0.622*LHVAP) * 1000000     ! Pa/K
      ESAT = (VPSAT(TMAX)+VPSAT(TMIN)) / 2.0               ! Pa
      EAIR = VPSAT(TDEW)                                   ! Pa
      VPD = ESAT - EAIR                                    ! Pa
      S = (VPSLOP(TMAX)+VPSLOP(TMIN)) / 2.0                ! Pa/K
      RT = 8.314 * (TAVG + 273.0)                             ! N.m/mol
      DAIR = 0.028966*(PATM-0.387*EAIR)/RT                    ! kg/m3
C BAD DAIR = 0.1 * 18.0 / RT * ((PATM  -EAIR)/0.622 + EAIR)   ! kg/m3
      VHCAIR = DAIR * SHAIR    !not used                      ! J/m3

C     Convert windspeed to 2 m reference height.
!     Do this conversion in WEATHR and send out 2m windspeed
!     CHP 11/26/01
!      WIND2 = WINDSP * (2.0/WINDHT)**0.2

C       Calculate aerodynamic resistance (ra).
C       ra (d/m) = {ln[zm-d/zom]*ln[zh-d/zoh]}/(k^2*uz)
C       zm = ht.wind measurement (m), zh = ht.humidity measurement (m),
C       zom,zoh=rooughness length of momentum, heat and vapor x-fer (m)
C       k=von Karman's constant 0.41, uz=WINDSP @ z m/d,
C       d = zero plane displacement height (m)

      WINDSP_M = WINDSP*(1000.)/86400.          !Converts km/d to m/s
      k = 0.41                                  !von Karman's constant

      IF (CANHT .LE. 0.10) THEN
        ZCROP = 2.0 + 0.10
C       Next 3 are Steiner et al. coefficients, used for Steiner Ra
        DCROP = 0.75 * 0.10
        ZOMC = 0.25 * (0.10 - DCROP)
        ZOVC = 0.1 * ZOMC
        DFAO = 2. * 0.10 / 3.0
        ZOMF = 0.123*0.10
        ZOHF = 0.1*ZOMF

      ELSE
        ZCROP = 2.0 + CANHT
        DCROP = 0.75 * CANHT
        ZOMC = 0.25 * (CANHT - DCROP)
        ZOVC = 0.1 * ZOMC
        DFAO= 2.0 * CANHT / 3.0
        ZOMF = 0.123*CANHT
        ZOHF = 0.1*ZOMF
      ENDIF

C     LHOMME ET AL. AG & FOR. MET. 104:119.  2000.
C     Combined effects of LAI and crop height on Ra
C     cd = 0.2 (in eq below), where X=0.2*LAI
C     Zolh up to X<0.2 (or LAI=1), then X 0.2 to 1.5 (LAI=7.5)
C     Actually should have a cap at LAI 7.5 or less.

      DLH = 1.1*MAX(0.10,CANHT)*LOG(1.+(0.2*XHLAI)**0.25)

      IF (XHLAI .LT. 1.0) THEN
        ZOLH = 0.01+0.3*MAX(0.10,CANHT)*(0.2*XHLAI)**0.5
      ELSE
C        ELSEIF (XHLAI .LT. 7.5)
        ZOLH = 0.3*MAX(0.10,CANHT)*(1.0-DLH/MAX(0.10,CANHT))
      ENDIF

C  Concept of Ra, always for 2 m above crop height, from Steiner et al
C       Agron. J. 83:240.  1991.  Also, needs wind speed adjusted, up to
C       10 m, then back down to exactly 2 m above crop height.
C       Needs z defined at 2 m above crop, or z = 2.0 + CANHT
C       Grass assumed 0.10 m, its d is 0.075, its Zom is 0.00625

      WIND2C = WINDSP_M * LOG((10.-0.075)/0.00625) *
     &                      LOG((ZCROP-DCROP)/ZOMC) /
     &         (LOG((10.-DCROP)/ZOMC)*LOG((2.-0.075)/0.00625))

C       Steiner Ra
      ra = ( (LOG((ZCROP-DCROP)/ZOMC)*LOG((ZCROP-DCROP)/ZOVC))
     &       /((k**2)*WIND2C) )  /86400

C       Standard FAO Ra
C       ra = ( (LOG((ZCROP-DFAO)/ZOMF)*LOG((ZCROP-DFAO)/ZOHF))
C    &       /((k**2)*WIND2C) )  /86400

C       Lhomme Ra
C       ra = ( (LOG((ZCROP-DLH)/ZOLH)*LOG((ZCROP-DLH)/(0.1*ZOLH)))
C    &       /((k**2)*WIND2C) )  /86400

C      NOW, COMPUTING Ra for bare soil and Rs for bare soil
C      For bare soil Ra, with an effective height of 0.40 m
C      Uses standard FAO eq, windsp for 2 m height.  Not for soil Rs
C      HTS = 0.13, for SUNLIT LAI FORM.  HTS = 0.25 for 0.5*LAI FORM.

      HTS = 0.13
C      HTS = 0.25
      RASOIL = (  (LOG((2.0-2*HTS/3.)/(0.123*HTS))
     &    *LOG((2.0-2*HTS/3.)/(0.1*0.123*HTS)))/((k**2)*WINDSP_M))/86400

CWMB    BOUNDARY LAYER RESISTANCE (rb) FOR BARE SOIL FROM (JAGTAP AND JONES, 1989)
C       zos = roughness ht. of soil (m), MAXHT = maximum plant height (m)
C       MAXHT is a dummy argument to get right Rs from soil.  Not real
C       This is wet surface resistance, Rs-soil, to match up with Rs-crop
C       Do not want WIND2C, as this one acts most for bare soil, no crop
C
C       For Sunlit LAI for Rc, use zos = 0.01
C       For 0.5*LAI for Rc, need zos = 0.03
      zos = 0.01
C       zos = 0.03
      MAXHT = 1.0
      rb=((log(2.0/zos)*log((0.83*MAXHT)/zos))/
     &            ((k**2)*WINDSP_M))/86400
C

C       Using K = 0.5 everywhere possible
        AC = 1-exp(-0.50*XHLAI)
        ASVar = 1 - AC

      RAERO = AC*RA + ASVar*RASOIL
C     Calculate surface resistance (rs).
C     rs = rl/LAIactive       rs (s m^-1),
C     rl = bulk stomatal resistance of the well-illuminated leaf (s m^-1)

      rl = 100                !value assummed from FAO grass reference
      IF (XHLAI .GE. 0.1) THEN
C          rs = rl/(0.5*XHLAI)
        rs = rl/((1/0.5)*(1.0-EXP(-0.5*XHLAI)))       !SUNLIT LAI form
      ELSE
        rs = rl/(0.5*0.1)
      ENDIF

      rs = rs/86400           !converts (s m^-1 to d/m)

      RTOT = AC*rs + ASVar*rb

C     Calculate net radiation (MJ/m2/d).  By FAO method 1990. EAIR is divided
C       by 1000 to convert Pa to KPa.

      G = 0.0
      IF (XHLAI .LE. 0.0) THEN
        ALBEDO = MSALB
      ELSE
C     I THINK THIS K VALUE SHOULD BE 0.5, NEAR THEORETICAL OF 0.5 KJB
        ALBEDO = 0.23-(0.23-MSALB)*EXP(-0.75*XHLAI)
      ENDIF

      TK4 = ((TMAX+273.)**4+(TMIN+273.)**4) / 2.0
      RADB = SBZCON * TK4 * (0.34 - 0.14 * SQRT(EAIR/1000)) *
     &        (1.35 * (1. - CLOUDS) - 0.35)
      RNET= (1.0-ALBEDO)*SRAD - RADB

C     Compute EO using Penman-Montieth

      RNETMG = (RNET-G)
C     !MJ/m2/d
      EO=((S*RNETMG + (DAIR*SHAIR*VPD)/RAERO)/(S+PSYCON*(1+RTOT/RAERO)))
C     !Converts MJ/m2/d to mm/d
        EO = EO/ (LHVAP / 1000000.)
!###  EO = MAX(EO,0.0)   !gives error in DECRAT_C
      EO = MAX(EO,0.0001)

!-----------------------------------------------------------------------
      RETURN
      END SUBROUTINE PETDYN

!     PETPEN VARIABLES:  Nearly same as PETPEN above

C=======================================================================
C  PETPT, Subroutine, J.T. Ritchie
C  Calculates Priestly-Taylor potential evapotranspiration
C-----------------------------------------------------------------------
C  REVISION HISTORY
C  ??/??/19?? JR  Written
C  11/04/1993 NBP Modified
C  10/17/1997 CHP Updated for modular format.
C  09/01/1999 GH  Incorporated into CROPGRO
!  07/24/2006 CHP Use MSALB instead of SALB (includes mulch and soil
!                 water effects on albedo)
!-----------------------------------------------------------------------
!  Called by:   WATBAL
!  Calls:       None
C=======================================================================
      SUBROUTINE PETPT(
     &    MSALB, SRAD, TMAX, TMIN, XHLAI,                 !Input
     &    EO)                                             !Output

!-----------------------------------------------------------------------
      IMPLICIT NONE

!-----------------------------------------------------------------------
!     INPUT VARIABLES:
      REAL MSALB, SRAD, TMAX, TMIN, XHLAI
!-----------------------------------------------------------------------
!     OUTPUT VARIABLES:
      REAL EO
!-----------------------------------------------------------------------
!     LOCAL VARIABLES:
      REAL ALBEDO, EEQ, SLANG, TD

!-----------------------------------------------------------------------
!     Should use TAVG here -- we have it from WEATHER variable!
!     SSJ 9/18/2006
!     TD = TAVG
!     JWJ 2/15/2007 - Can't use TAVG unless coefficients in EEQ
!         equation are recalibrated.  Keep TD calc as it was
!         developed.
      TD = 0.60*TMAX+0.40*TMIN

      IF (XHLAI .LE. 0.0) THEN
        ALBEDO = MSALB
      ELSE
        ALBEDO = 0.23-(0.23-MSALB)*EXP(-0.75*XHLAI)
      ENDIF

      SLANG = SRAD*23.923
      EEQ = SLANG*(2.04E-4-1.83E-4*ALBEDO)*(TD+29.0)
      EO = EEQ*1.1

      IF (TMAX .GT. 35.0) THEN
        EO = EEQ*((TMAX-35.0)*0.05+1.1)
      ELSE IF (TMAX .LT. 5.0) THEN
        EO = EEQ*0.01*EXP(0.18*(TMAX+20.0))
      ENDIF

!###  EO = MAX(EO,0.0)   !gives error in DECRAT_C
      EO = MAX(EO,0.0001)

!-----------------------------------------------------------------------
      RETURN
      END SUBROUTINE PETPT
!-----------------------------------------------------------------------
!     PETPT VARIABLES:
!-----------------------------------------------------------------------
! ALBEDO  Reflectance of soil-crop surface (fraction)
! EEQ     Equilibrium evaporation (mm/d)
! EO      Potential evapotranspiration rate (mm/d)
! MSALB   Soil albedo with mulch and soil water effects (fraction)
! SLANG   Solar radiation
! SRAD    Solar radiation (MJ/m2-d)
! TD      Approximation of average daily temperature (�C)
! TMAX    Maximum daily temperature (�C)
! TMIN    Minimum daily temperature (�C)
! XHLAI   Leaf area index (m2[leaf] / m2[ground])
!-----------------------------------------------------------------------
!     END SUBROUTINE PETPT
C=======================================================================

C=======================================================================
C  PETPNO, Subroutine, N.B. Pickering
C  Calculates FAO-24 Penman potential evapotranspiration (without
C  correction)--grass reference.
!-----------------------------------------------------------------------
C  REVISION HISTORY
C  02/19/1992 NBP Written
C  11/04/1993 NBP Renamed routine PET to PETPEN.  Changed XLAI to XHLAI
C               Added XHLAI .LE. 0.0 statement.
C  05/13/1994 NBP Converted all vapor pressures to Pa.  Rearranged.
C  09/16/1994 NBP Added limits to prevent EO and ES (PE) < 0.
C  10/17/1997 CHP Updated for modular format.
C  09/01/1999 GH  Incorporated into CROPGRO
C  05/06/2002 WMB Fixed Stefan-Boltzmann constant
!  07/24/2006 CHP Use MSALB instead of SALB (includes mulch and soil
!                 water effects on albedo)
!-----------------------------------------------------------------------
!  Called from:   PET
!  Calls:         None
C=======================================================================
      SUBROUTINE PETPNO(
     &    CLOUDS, MSALB, SRAD, TAVG, TDEW,                !Input
     &    TMAX, TMIN, WINDSP, XHLAI,                      !Input
     &    EO)                                             !Output
!-----------------------------------------------------------------------
      IMPLICIT NONE
!-----------------------------------------------------------------------
!     INPUT VARIABLES:
      REAL CLOUDS, MSALB, SRAD, TAVG, TDEW, TMAX, TMIN,
     &        WINDSP, XHLAI
!-----------------------------------------------------------------------
!     OUTPUT VARIABLES:
      REAL EO
!-----------------------------------------------------------------------
!     LOCAL VARIABLES:
      REAL ALBEDO, EAIR, ESAT, G, LHVAP, PSYCON, RADB,
     &  RNET, RNETMG, S, TK4,
     &  VHCAIR, VPD, WFNFAO, DAIR, RT
      REAL SHAIR, PATM, SBZCON

      PARAMETER (SHAIR = 1005.0)
      PARAMETER (PATM = 101300.0)
!      PARAMETER (SBZCON=4.093E-9)   !(MJ/m2/d)
      PARAMETER (SBZCON=4.903E-9)   !(MJ/K4/m2/d) fixed constant 5/6/02
!-----------------------------------------------------------------------
!     FUNCTION SUBROUTINES:
      REAL VPSLOP, VPSAT      !Found in file HMET.for

C-----------------------------------------------------------------------
C     Compute air properties.
      LHVAP = (2501.0-2.373*TAVG) * 1000.0                 ! J/kg
      PSYCON = SHAIR * PATM / (0.622*LHVAP)                ! Pa/K
      ESAT = (VPSAT(TMAX)+VPSAT(TMIN)) / 2.0               ! Pa
      EAIR = VPSAT(TDEW)                                   ! Pa
      VPD = ESAT - EAIR                                    ! Pa
      S = (VPSLOP(TMAX)+VPSLOP(TMIN)) / 2.0                ! Pa/K
      RT = 8.314 * (TAVG + 273.0)                             ! N.m/mol
      DAIR = 0.1 * 18.0 / RT * ((PATM  -EAIR)/0.622 + EAIR)   ! kg/m3
      VHCAIR = DAIR * SHAIR    !not used                      ! J/m3

C     Convert windspeed to 2 m reference height.
!     Do this conversion in WEATHR and send out 2m windspeed
!     CHP 11/26/01
!      WIND2 = WINDSP * (2.0/WINDHT)**0.2

C     Calculate net radiation (MJ/m2/d).  Constants for RADB from
C     Jensen et al (1989) for semi-humid conditions.  The value 0.005
C     converts the value 0.158 from kPa to Pa.

      G = 0.0
      IF (XHLAI .LE. 0.0) THEN
        ALBEDO = MSALB
      ELSE
        ALBEDO = 0.23-(0.23-MSALB)*EXP(-0.75*XHLAI)
      ENDIF

      TK4 = ((TMAX+273.)**4+(TMIN+273.)**4) / 2.0
      RADB = SBZCON * TK4 * (0.4 - 0.005 * SQRT(EAIR)) *
     &        (1.1 * (1. - CLOUDS) - 0.1)
      RNET= (1.0-ALBEDO)*SRAD - RADB

C     Compute ETP using the FAO wind function.  The multipliers for WNDFAO
C     are 1000 times smaller than in Jensen et al (1979) to convert VPD in
C     Pa to kPa. Equation for RNETMG converts from MJ/m2/d to mm/day.

!      WFNFAO = 0.0027 * (1.0+0.01*WIND2)
      WFNFAO = 0.0027 * (1.0+0.01*WINDSP)
      RNETMG = (RNET-G) / LHVAP * 1.0E6
      EO = (S*RNETMG + PSYCON*WFNFAO*VPD) / (S+PSYCON)
!###  EO = MAX(EO,0.0)   !gives error in DECRAT_C
      EO = MAX(EO,0.0001)

!-----------------------------------------------------------------------
      RETURN
      END SUBROUTINE PETPNO

!-----------------------------------------------------------------------
!     PETPEN VARIABLES:
!-----------------------------------------------------------------------
! ALBEDO  Reflectance of soil-crop surface (fraction)
! CLOUDS  Relative cloudiness factor (0-1)
! DAIR
! EAIR    Vapor pressure at dewpoint (Pa)
! EO      Potential evapotranspiration rate (mm/d)
! ESAT    Vapor pressure of air (Pa)
! G       Soil heat flux density term (MJ/m2/d)
! LHVAP   Latent head of water vaporization (J/kg)
! PATM     = 101300.0
! PSYCON  Psychrometric constant (Pa/K)
! RADB    Net outgoing thermal radiation (MJ/m2/d)
! RNET    Net radiation (MJ/m2/d)
! RNETMG  Radiant energy portion of Penman equation (mm/d)
! RT
! S       Rate of change of saturated vapor pressure of air with
!           temperature (Pa/K)
! MSALB   Soil albedo with mulch and soil water effects (fraction)
! SBZCON   Stefan Boltzmann constant = 4.093E-9 (MJ/m2/d)
! SHAIR    = 1005.0
! SRAD    Solar radiation (MJ/m2-d)
! TAVG    Average daily temperature (�C)
! TDEW    Dewpoint temperature (�C)
! TK4     Temperature to 4th power ((oK)**4)
! TMAX    Maximum daily temperature (�C)
! TMIN    Minimum daily temperature (�C)
! VHCAIR
! VPD     Vapor pressure deficit (Pa)
! VPSAT   Saturated vapor pressure of air (Pa)
! VPSLOP  Calculates slope of saturated vapor pressure versus
!           temperature curve (Pa/K)
! WFNFAO  FAO 24 hour wind function
! WIND2   Windspeed at 2m reference height. (km/d)
! WINDSP  Wind speed at 2m (km/d)
! XHLAI   Leaf area index (m2[leaf] / m2[ground])
!-----------------------------------------------------------------------
!     END SUBROUTINE PETPNO
!-----------------------------------------------------------------------

C=======================================================================
C=======================================================================
C  PETMEY, Subroutine
!  Copyright(c) CSIRO 2000C  Calculates soil-plant-atmosphere interface
!  energy balance components.
C-----------------------------------------------------------------------
C  REVISION       HISTORY

C-----------------------------------------------------------------------
C  Called by: Main

C=============================================================================
!  Routine to calculate Potential Evapotranspiration (ET) from daily         !
!  weather data.                                                             !
!                                                                            !
!  Uses coefficients and methods as per                                      !
!  "Standard reference evaporation calculation for inland south eastern      !
!   Australia" By Wayne Meyer 1993                                           !
!                                                                            !
!  Written in Microsoft Fortran V5.1 by Bob White March 1994                 !
!                                                                            !
!  Long variable names (up to 31 characters) have been used. This may cause  !
!  some problems if this routine is complied with early versions of fortran  !
!                                                                            !
!  Function returns calculated value for Potential ET (0.0 if error)         !
!                                                                            !
!  Modified to account for changing albedo from bare soil (salb) to crop     !
!  (0.23) as canopy (LAI) increases. RJGW -> 05-04-95                        !
!                                                                            !
!  04/01/2004 CHP adapted for CSM
!  07/24/2006 CHP Use MSALB instead of SALB (includes mulch and soil
!                 water effects on albedo)
C=============================================================================

! VARIABLES INPUT TO ROUTINE
C=============================================================================
!! Name             !                                                        !
C=============================================================================
!! MeanTemp         ! Mean daily temperature in degres C                     !
C=============================================================================
!! Prev3dayMean     ! Mean of the previous 3 days mean temperature           !
C=============================================================================
!! DailyWindRun     ! Daily wind run in Km / day                             !
C=============================================================================
!! SolarIrradiance  ! Solar irradiance (MJ / m**2 / day)                     !
C=============================================================================
!! MeanDewPt        ! Mean daily dew point temperature (Deg C)               !
C=============================================================================
!! Jday             ! Julian day of the year                                 !
C=============================================================================
!!VARIABLES LOCAL TO THIS ROUTINE
C=============================================================================
!!                  ! Description                                            !
C=============================================================================
!! Albedo           !                                                        !
C=============================================================================
!! Coeff_A          ! Empirical coefficient used in Ro calculation           !
C=============================================================================
!! Coeff_B          !    "          "        "    "  "      "                !
C=============================================================================
!! Coeff_C          ! Empirical coefficient used in Net emissivity calc.     !
C=============================================================================
!! Coeff_D          !    "           "        "   "  "       "      "        !
C=============================================================================
!! Coeff_WindA      ! Empirical coefficient used in wind function calc.      !
C=============================================================================
!! Coeff_WindB      !    "           "        "   "  "       "     "         !
C=============================================================================
!! Delta            ! Used in proportioning term see equ (7)                 !
C=============================================================================
!! DODPG            ! Proportioning term                                     !
C=============================================================================
!! ETpot            ! Calculated potential evapotranspiration                !
C=============================================================================
!! Fac1             ! Intermediate term in long wave radiation calc.         !
C=============================================================================
!! Gflux            ! Ground heat flux                                       !
C=============================================================================
!! LatHeapVap       ! Latent heat of vaporisation                            !
C=============================================================================
!! MaxIrradiance    ! Max clear day irradiance                               !
C=============================================================================
!! NetEmissivity    ! Net emissivity                                         !
C=============================================================================
!! NetRad           ! Net radiation                                          !
C=============================================================================
!! PI               !                                                        !
C=============================================================================
!! Radj             ! Julian day of year converted to radians                !
C=============================================================================
!! RalLon           ! Long wave radiation                                    !
C=============================================================================
!! StefBoltz        ! Stefan-Boltzman constant                               !
C=============================================================================
!! VPdew            ! Actual daily vapour pressure                           !
C=============================================================================
!! VPD              ! Vapour pressure deficit                                !
C=============================================================================
!! VPsat            ! Saturation vapour pressure                             !
C=============================================================================
!! WindFunc         ! Wind function (see equ 24)                             !
C=============================================================================
C=============================================================================

      Subroutine Petmey(CONTROL,
     &    MeanTemp, DailyWindRun, SolarIrradiance,        !Input
     &    MeanDewPt, Xhlai, MSALB,                        !Input
     &    EO)                                             !Output

      Use mini_ModuleDefs
      Implicit none
      SAVE

!      INTENT(IN) :: CONTROL,
!     &    MeanTemp, DailyWindRun, SolarIrradiance,
!     &    MeanDewPt, Xhlai, MSALB
!      INTENT(OUT) :: EO

       Integer Jday,Year,Yrdoy,yRSIM
       Real Albedo, Coeff_WindA, Coeff_WindB
       Real Coeff_A,Coeff_B,Coeff_C,Coeff_D
       Real DailyWindRun,Eo,Xhlai
       Real Delta, dodpg, Fac1, Gflux, LatHeatVap
       Real MaxIrradiance,MSALB
       Real MeanDewPt, MeanTemp
       Real NetEmissivity,NetRad,PI
!       Real Prev3dayMean,Radj, RadLon, SolarIrradiance, StefBoltz
       Real Radj, RadLon, SolarIrradiance, StefBoltz
!       Real VPdew, VPD, VPsat, WindFunc
!      VPsat has been renamed to VPsatVar in order to prevent it from colliding
!      with the function VPSAT
       Real VPdew, VPD, VPsatVar, WindFunc
       Real TAVt,Tavy2,Tavy1,T3day,Tav
       CHARACTER (len=2) Crop
!       Character*2 Crop
C
        TYPE (ControlType) CONTROL
        YRDOY = CONTROL % YRDOY
        YRSIM = CONTROL % YRSIM

        Crop = CONTROL % CROP

!       write(*,10)MeanTemp,Prev3dayMean,DailyWindRun,
!     &            SolarIrradiance, MeanDewPt,Albedo,Jday
!10     format(1x,'Variables passed to ETpot',/,
!     &        1x,'Mean temp = ',F6.1,/,
!     &        1x,'Prev 3 day mean temp = ',F6.1,/,
!     &        1x,'Daily wind run = ',F6.1,/,
!     &        1x,'Solar irradiance = ',F6.1,/,
!     &        1x,'Mean dew point = ',F6.1,/,
!     &        1x,'Albedo = ',F6.3,/,
!     &        1x,'Day of year = ',I3,/)

!  EMPiRICAL COEFFICIENTS (as defined by Meyer Tech memo 1993)
c
c get day of year for max irradiance calculation
c

        CALL Yr_Doy(Yrdoy,Year,Jday)
c
c    compute moving average 3 day temperature - use average for first 3 days
c
      Tav=MeanTemp
      If(YrDoy.le.Yrsim+3)Then
         Tavt=Tav
         Tavy2=Tav
         Tavy1=Tav
      Else
         Tavy2=Tavy1
         Tavy1=Tavt
         Tavt=Tav
      Endif
      T3Day=(Tavy2+Tavy1+tav)/3.0

c
c   calculate albedo
c
       IF (Crop.eq.'RI') THEN
          Albedo=0.23-(0.23-0.05)*exp(-0.75*xhlai)
       Else
          Albedo =0.23 -(0.23 -MSALB)*exp(-0.75*Xhlai)
       Endif

        Coeff_A     = 0.92
        Coeff_B     = 0.08
        Coeff_C     = 0.34
        Coeff_D     = -0.139
        Coeff_WindA = 17.8636
        Coeff_WindB = 0.0440
        !Albedo      = 0.23 This is being passed in
        StefBoltz   = 4.896e-09
        PI          = 22.0 / 7.0

!  CALCULATE LATENT HEAT OF VAPORIZATION, HTVAP (MJ/m2/mm)

        LatHeatVap = 2.50025 - 0.002365 * MeanTemp

!  CALCULATE WEIGHING FACTOR, DODPG (-)

!     Slope of saturation curve (kPa/Deg C)
        delta = 0.1 * exp(21.255 - (5304 / (MeanTemp+273.1)))
     &          * (5304 / (MeanTemp+273.1)**2)

!     PROPORTIONING TERM
        dodpg = delta/(delta+0.066)

!  Calculated incoming solar irradiance on a clear day, (MJ/m**2/day)
!  Maximum daily irradiance from fitted data (for SE Aust.)
!  Use a general equation or lookup table for other areas

        RadJ = (REAL(Jday) / 365.25) * PI * 2.0

        MaxIrradiance = 22.357 + (11.0947 * cos(RadJ)) -
     &                  (2.3594 * sin(RadJ))

!        if (SolarIrradiance .gt. MaxIrradiance)
!     &      SolarIrradiance = MaxIrradiance

        VPsatVar = 0.611*exp((17.27*MeanTemp)/(MeanTemp + 237.3))
        VPdew = 0.611*exp((17.27*MeanDewPt)/(MeanDewPt + 237.3))
        VPdew = AMIN1(VPdew,VPsatVar)
        VPD = VPsatVar-VPdew

!  CALCULATE OUTGOING LONGWAVE RADIATION, RADLON [Ro] (MJ/m**2/day)

        NetEmissivity = Coeff_C+(Coeff_D*sqrt(VPdew))

        Fac1 = (Coeff_A*(SolarIrradiance/MaxIrradiance)) + Coeff_B
        Radlon = Fac1 * NetEmissivity * StefBoltz * (MeanTemp+273.)**4.

!  CALCULATE NET RADIATION, RADNET (MJ/m2)

        NetRad = ((1. - Albedo) * SolarIrradiance) - Radlon

!  CALCULATE SOIL HEAT FLUX, SHFLUX (MJ/m2)

        Gflux = (MeanTemp - T3Day) * 0.12

!  CALCULATE COMPONENTS OF AERODYNAMIC TERM

        WindFunc = Coeff_WindA + (Coeff_WindB * DailyWindRun)

!  POTENTIAL EVAPOTRANSPIRATION BY COMBINATION METHOD, ETPOT (mm/day)

!        Gflux= AMIN1(NetRad,Gflux)

        Eo = ( dodpg * (NetRad-Gflux)
     &          + (1.- dodpg) * WindFunc * VPD )/LatHeatVap

      if (eo.lt.0.0) eo = 0.0
      end Subroutine Petmey
!=======================================================================

!=======================================================================
!  PSE, Subroutine, J.T. Ritchie
!  Calculates soil potential evaporation from total PET and LAI.
!-----------------------------------------------------------------------
!  REVISION HISTORY
!  ??/??/19?? JR  Written
!  11/04/1993 NBP Modified
!  07/21/1998 CHP changed PE Function to PSE Subroutine
!  01/15/2003 KJB CHANGED TO USE SAME K EXTINCTION AS USED FOR TRANSP
!    VILLALOBOS MEASURED K=0.52 FOR BOTH SOIL EVAPORATION AND TRANSP
!    THEORY OF GOUDRIAAN INDICATES A VALUE NEAR 0.5 BECAUSE OF BOTH
!    NEAR-INFARED PLUS VISIBLE COMBINE TO GIVE YOU THIS COMBINATION K
!  07/08/2003 CHP/LAH added use of KSEVAP which comes from crop routines
!  03/10/2006 CHP Reduce potential soil evaporation if mulch cover.
!                 From A. Andeles tillage routine.
!  05/26/2007 CHP/MJ Use XLAI instead of XHLAI
!                 This was important for Canegro and affects CROPGRO crops
!                 only very slightly (max 0.5% yield diff for one peanut
!                 experiment).  No difference to other crop models.
!  06/25/2008 CHP Move mulch evaporationto MULCHEVAP subroutine
!-----------------------------------------------------------------------
!  Input : EO,XLAI
!  Output: PE
!=======================================================================

      SUBROUTINE PSE(EO, KSEVAP, XLAI, EOS)

!-----------------------------------------------------------------------
      USE mini_ModuleDefs
      USE ModuleData
      IMPLICIT NONE
      SAVE

!     CHARACTER*1 MEINF
      REAL EO, XLAI, EOS
      REAL KSEVAP
      REAL KE, REFET

      CALL GET('SPAM', 'KE', KE)
      CALL GET('SPAM', 'REFET', REFET)
!-----------------------------------------------------------------------
!     Potential soil evaporation based on leaf area index and potential
!         evapotranspiration.

! LAH JULY 2, 2003
      IF (KE .GE. 0.0) THEN
        EOS = KE * REFET !KRT added for ASCE dual Kc ET approach
      ELSEIF (KSEVAP .LE. 0.0) THEN

!       Old computation:
        IF (XLAI .LE. 1.0) THEN   !<-------!
!         EOS = EO*(1.0 - 0.43*XLAI)       !
!         get rid of discontinuity:
          EOS = EO*(1.0 - 0.39*XLAI)       !
        ELSE                               !-> old code
          EOS = EO/1.1*EXP(-0.4*XLAI)      !
        ENDIF    !<------------------------!

      ELSE
        EOS = EO*EXP(-KSEVAP*XLAI) !<------- Tony's new code 07/02/2003
      ENDIF

!     Ken's new computation: 01/03/2003
!      EOS = EO*EXP(-0.50*XLAI)

!     Note from Tony:  this is not the same as the old computation and
!       may cause different results.  We need to re-evaluate.
!     Probably should use KEP here.

      EOS = MAX(EOS,0.0)

      RETURN
      END SUBROUTINE PSE

!-----------------------------------------------------------------------
!     PSE VARIABLES:
!-----------------------------------------------------------------------
! EO     Potential evapotranspiration rate (mm/d)
! EOS    Potential rate of soil evaporation (mm/d)
! KE     Evaporation coefficient for ASCE dual Kc ET method
! REFET  ASCE Standardized Reference Evapotranspiration (alfalfa or grass)
! XLAI   Leaf area index (m2[leaf] / m2[ground])
!-----------------------------------------------------------------------
!     END SUBROUTINE PSE
C=======================================================================

C=======================================================================
C  FLOOD_EVAP, Subroutine, U. Singh
C  Determines floodwater evaporation
C-----------------------------------------------------------------------
C  REVISION HISTORY
C  ??/??/??   US  Written.
C  02/27/2002 CHP modified for modular format.
!  12/07/2005 CHP added discontinuity prevention
!-----------------------------------------------------------------------
!  Called by:   SPAM
!  Calls:       None
C=======================================================================
      SUBROUTINE FLOOD_EVAP(XLAI, EO, EF)

!-----------------------------------------------------------------------
      IMPLICIT NONE
      REAL EO, EF, EF85, XLAI

!-----------------------------------------------------------------------
!     EF = EO*(1.0-0.45*XLAI)
      EF = EO*(1.0-0.53*XLAI)  !prevents discontinuity
      IF (XLAI .GT. 0.85) THEN
!       EF85 = EO * 0.62  !EF at XLAI=0.85, prevents discontinuity
!       EF = AMIN1(EF85, EO/1.1*EXP(-0.60*XLAI))
        EF = EO/1.1*EXP(-0.60*XLAI)
      ENDIF

!-----------------------------------------------------------------------
      RETURN
      END SUBROUTINE FLOOD_EVAP
C=======================================================================


      subroutine stressperm_7(i)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************

! ********Bai et al model (stress based)
! 2d not implemented
      use comai
      use combi
      use comdi
      use comdti, only : n0
      use comsi

      implicit none
      integer i, iispmd
      integer kbx1,kbx2,kby1,kby2,kbz1,kbz2,idir

      real*8  ipmd7_dsx,ipmd7_dsy,ipmd7_dsz
      real*8  ipmd7_dsxy,ipmd7_dsxz,ipmd7_dsyz
      real*8  ipmd7_knx,ipmd7_kny,ipmd7_knz
      real*8  ipmd7_nmx,ipmd7_nmy,ipmd7_nmz
      real*8  ipmd7_shx,ipmd7_shy,ipmd7_shz
      real*8  pi, phid
      real*8  frac_tol, disz,disy,disx
      real*8  ksx, ksy, ksz
      real*8 frac_bx, frac_by, frac_bz

      parameter (frac_tol=0.00001, pi=3.1415926535)

      iispmd = ispm(i)

      if(icnl.ne.0) then
         write(ierr,*) 'Bai model not implemented in 2D'
         write(ierr,*) 'stopping in stress_perm.f'

      endif
!
!     **************************** 3D
!
      if(icnl.eq.0) then
         if (.not. allocated(check)) allocate(check(n0))
         if (.not. allocated(estr_x0)) then
            allocate(estr_x0(n0))
            allocate(estr_y0(n0))
            allocate(estr_z0(n0))
         endif
         if(.not.allocated(str_xy0)) then
            allocate(str_xy0(n0))
            allocate(str_xz0(n0))
            allocate(str_yz0(n0))
         endif
         frac_bx = spm1f(iispmd)
         frac_by = spm2f(iispmd)
         frac_bz = spm3f(iispmd)
         knx_stressperm = spm4f(iispmd)
         ksx = spm5f(iispmd)
         phid = spm6f(iispmd)

         kny_stressperm = knx_stressperm
         knz_stressperm = knx_stressperm
         ksy = ksx
         ksz = ksx
         ipmd7_nmx = 0.
         ipmd7_nmy = 0.
         ipmd7_nmz = 0.
         ipmd7_shx = 0.
         ipmd7_shy = 0.
         ipmd7_shz = 0.

         perx_m=1.e4
         pery_m=1.e4
         perz_m=1.e4
!     initial stress - current stress
         ipmd7_dsx = estr_x0(i) - (str_x(i)-phi(i))
         ipmd7_dsy = estr_y0(i) - (str_y(i)-phi(i))
         ipmd7_dsz = estr_z0(i) - (str_z(i)-phi(i))
         ipmd7_dsxy = abs(str_xy0(i) - str_xy(i))
         ipmd7_dsxz = abs(str_xz0(i) - str_xz(i))
         ipmd7_dsyz = abs(str_yz0(i) - str_yz(i))

         if(ipmd7_dsx.lt.0) ipmd7_dsx = 0.
         if(ipmd7_dsy.lt.0) ipmd7_dsy = 0.
         if(ipmd7_dsz.lt.0) ipmd7_dsz = 0.

         kbx1 = ipermx(i,1)
         kbx2 = ipermx(i,2)
         kby1 = ipermy(i,1)
         kby2 = ipermy(i,2)
         kbz1 = ipermz(i,1)
         kbz2 = ipermz(i,2)
!
!     identify displacements
!
         disx = (cord(kbx2,1)-cord(kbx1,1))/2.
         disy = (cord(kby2,2)-cord(kby1,2))/2.
         disz = (cord(kbz2,3)-cord(kbz1,3))/2.

!
!     fracture dilation (normal and shear)
!
         if(frac_bx.ne.0.) then
            ipmd7_nmx = ipmd7_dsx/(knx_stressperm*frac_bx) + disx/frac_bx       &
      *((ipmd7_dsx-poisson(i)*(ipmd7_dsy+ipmd7_dsz))/elastic_mod(i)  &
             +alp(i)*(t(i)-tini(i)))

            if(str_x(i)-phi(i).lt.0) then
               ipmd7_shx = 0.
            else
               ipmd7_shx = ((disy/e3(i)+1/ksy)*ipmd7_dsxy            &
         +(disz/e3(i)+1/ksz)*ipmd7_dsxz)*tan(phid/180*pi)/frac_bx
            endif

         endif

         if(frac_by.ne.0.) then
              ipmd7_nmy = ipmd7_dsy/(kny_stressperm*frac_by) + disy/frac_by    &
        *((ipmd7_dsy-poisson(i)*(ipmd7_dsx+ipmd7_dsz))/elastic_mod(i)  &
                +alp(i)*(t(i)-tini(i)))

              if(str_y(i)-phi(i).lt.0) then
                 ipmd7_shy = 0.
              else
                 ipmd7_shy = ((disx/e3(i)+1/ksx)*ipmd7_dsxy  &
          +(disz/e3(i)+1/ksz)*ipmd7_dsyz)*tan(phid/180*pi)/frac_by
              endif

           endif

           if(frac_bz.ne.0.) then
              ipmd7_nmz = ipmd7_dsz/(knz_stressperm*frac_bz) + disz/frac_bz  &
        *((ipmd7_dsz-poisson(i)*(ipmd7_dsx+ipmd7_dsy))/elastic_mod(i)  &
                  +alp(i)*(t(i)-tini(i)))

              if(str_z(i)-phi(i).lt.0) then
                 ipmd7_shy = 0.
              else
                 ipmd7_shz = ((disx/e3(i)+1/ksx)*ipmd7_dsxz  &
          +(disy/e3(i)+1/ksy)*ipmd7_dsyz)*tan(phid/180*pi)/frac_bz
              endif

           endif

! check
           check(i) = ipmd7_shy*frac_by
!
!     perm enhancement
!

           if(frac_by.ne.0.or.frac_bz.ne.0) then
              pnx(i) = pnx0(i)/(frac_by**3+frac_bz**3)*  &
                  ( frac_by**3*(1+ipmd7_nmy+ipmd7_shy)**3 &
                  + frac_bz**3*(1+ipmd7_nmz+ipmd7_shz)**3 )
           endif

           if(frac_bx.ne.0.or.frac_bz.ne.0) then
              pny(i) = pny0(i)/(frac_bx**3+frac_bz**3)*  &
                  ( frac_bx**3*(1+ipmd7_nmx+ipmd7_shx)**3  &
                  + frac_bz**3*(1+ipmd7_nmz+ipmd7_shz)**3 )
           endif

           if(frac_bx.ne.0.or.frac_by.ne.0) then
              pnz(i) = pnz0(i)/(frac_bx**3+frac_by**3)*  &
                  ( frac_bx**3*(1+ipmd7_nmx+ipmd7_shx)**3  &
                  + frac_by**3*(1+ipmd7_nmy+ipmd7_shy)**3 )
           endif

!     pnx(i) = min(perx_m*pnx0(i),pnx(i))
!     pny(i) = min(pery_m*pny0(i),pny(i))
!     pnz(i) = min(perz_m*pnz0(i),pnz(i))
!     pnx(i) = max(0.01*pnx0(i),pnx(i))
!     pny(i) = max(0.01*pny0(i),pny(i))
!     pnz(i) = max(0.01*pnz0(i),pnz(i))

        endif
          return

          end
!....................................................................


!bloss#include <misc.h>
!bloss#include <params.h>
subroutine zenith(calday  ,clat    , clon   ,coszrs  ,ncol    )
!-----------------------------------------------------------------------
!
! Purpose:
! Compute cosine of solar zenith angle for albedo and radiation
!   computations.
!
! Method:
! <Describe the algorithm(s) used in the routine.>
! <Also include any applicable external references.>
!
! Author: J. Kiehl
!
!-----------------------------------------------------------------------
   use shr_kind_mod, only: r4 => shr_kind_r4
   use shr_orb_mod
!bloss
   use ppgrid, only: eccen, mvelpp, lambm0, obliqr, eccf

   implicit none

!bloss#include <crdcon.h>
!bloss#include <comsol.h>
!------------------------------Arguments--------------------------------
!
! Input arguments
!
   integer, intent(in) :: ncol                 ! number of positions
   real(r4), intent(in) :: calday              ! Calendar day, including fraction
   real(r4), intent(in) :: clat(ncol)          ! Current centered latitude (radians)
   real(r4), intent(in) :: clon(ncol)          ! Centered longitude (radians)
!
! Output arguments
!
   real(r4), intent(out) :: coszrs(ncol)       ! Cosine solar zenith angle
!
!---------------------------Local variables-----------------------------
!
   integer i         ! Position loop index
   real(r4) delta    ! Solar declination angle  in radians
!bloss   real(r4) eccf     ! Earth orbit eccentricity factor
!
!-----------------------------------------------------------------------
!
   call shr_orb_decl (calday  ,eccen     ,mvelpp  ,lambm0  ,obliqr  , &
                      delta   ,eccf      )
!
! Compute local cosine solar zenith angle,
!
   do i=1,ncol
      coszrs(i) = shr_orb_cosz( calday, clat(i), clon(i), delta )
   end do
!
   return
end subroutine zenith


c*****************************************************************************
c
c      Initialization routine
c
c******************************************************************************
c
       SUBROUTINE SJINIT(NAMAX,NSMAX,NIW,NRW,ATOM,CHEM,IW,RW)
c
c      Initialization routine
c------------------------------------------------------------------------------
c      Identifies the linearly independent atoms in the allowed species
c      set and distributes the atom populations to a set of system
c      base species, which are expected to be the dominant species.
c      This is accomplished by an approximate Gibbs function minimization
c      in which the ln(X) term is neglected, giving rise to a linear
c      minimization problem solved by the standard simplex process (SJISMP).
c      There will be one base species for each linearly independent atom.
c      A specification of impossible populations is identified by SJISMP,
c      in which case the initialization is terminated.
c
c      The simplex multipliers emerging at the end of this process are
c      element potentials corresponding to the prescribed mol fractions of
c      the base species species. Using these potentials, the mol fractions
c      estimated for all other species are less than unity. Thus, they form
c      a first guess for the element potentials.
c
c      The main analysis loop begins with a set of trial mols from which
c      the mol fractions and phase mols are calculated (SJIPMX).
c
c      The element potentials are then estimated (SJIESL) with iteration
c      until a consistent set has been found for the given basis set.
c
c      The conditioned population equations are examined in SJIESL to see if
c      any base is dominated by another species not a balancer. If there
c      is dominance, then a base change is made (SJISMP) and the element
c      potentials are reestimated using SJIESL.
c
c      Once a consistent set of basis species and potentials have been found,
c      the mol fractions of balancing species are estimated, and atoms are
c      redistributed to seek these target mol fractions (SJISRD).
c
c      These processes are repeated until sufficient consistency is obtained.
c------------------------------------------------------------------------------
c      On return:
c
c          Successful initialization:
c
c              KERR = 0
c
c          Problems encountered:
c
c              KERR = 1 program problems (singularities)
c                     2 unable to initialize
c                     3 impossible populations
c------------------------------------------------------------------------------
c      Nomenclature:
c
c      Variables in the argument list:
c @        NAMAX       maximum number of atoms
c @        NSMAX       maximum number of species
c @        NIW         dimension of work array IW
c @        NRW         dimension of work array IR
c @        ATOM(I)     CHARACTER*2 name of Ith atom
c @        CHEM(J)     CHARACTER*8 name of Jth species
c          IW(I)       integer work array
c          RW(I)       REAL*8 work array
c
c      Variables in the integer work array IW:
c #        IB(K) = I   if the Ith atom is the Kth independent system atom
c #        JB(K) = J   if the Jth system species is the Kth base species
c -        JBA(K) = J  JB(K) after last redistribution
c -        JBB(K) = J  JB(K) for the best basis
c -        JBO(K) = J  JB(K) before redistribution
c #        KB(J)       basis control (SJISMP)
c @                 -1 if the Jth species is a base freed for SJISRD call
c                    0 if the Jth species is not a base
c                    1 if the Jth species is a base
c                    2 if the Jth species is a balancing species
c                    4 if the Jth species is excluded
c          KBA(J)      KB(J) after last redistribution
c -        KBB(J)      KB(J) for the best basis
c -        KBO(J)      KB(J) before the last distribution
c #        KERR        error flag
c @        KMON        monitor control
c @        KUMO        output unit for monitor
c @        N(I,J)      number of Ith atoms in Jth system species
c @        NA          number of atom types
c #        NB          number of base species (independent atoms)
c @        NP          number of phases
c @        NS          number of species
c @        NSP(M)      number of species in the Mth phase

c      Variables in the real work array RW:
c -        ELMB(K)     ELAM(K) for best basis
c #        ELAM(K)     element potential for the Kth independent system atom
c @        G(J)        g(T,P)/RT  for the Jth species
c @        HUGE        large machine number
c @        PA(I)       population of the Ith atoms
c #        PC(K)       Kth conditioned population
c #        PMOL(M)     mols of Mth phase
c -        SMLA(J)     SMOLS(J) after last redistribution
c -        SMLB(J)     SMOLS(J) for best basis
c -        SMLO(J)     SMOLS(J) for before redistribution
c #        SMOL(J)     mols of Jth species
c #        X(J)        mols fraction of the Jth species (in its phase)
c -        XO(J)       X(J) of last distribution
c
c      Variables used only internally:
c          DOM         maximum dominance of a base by a secondary species
c          DOMB        DOM for best basis
c          KCCPC       conditioning matrix calculation control
c          KEX30       exit control
c          KRED        redistribution control (0=don't, 1=maybe)
c          KTRB        basis change iteration counter
c          KTRR        redistribution counter
c          XRMIN       fractional change in X for initiation convergence
c          ZERO        0 in calculation precision
c------------------------------------------------------------------------------
       IMPLICIT        REAL*8  (A-H,O-Z)
       CHARACTER*2     ATOM,ELECT
       CHARACTER*8     CHEM
       LOGICAL*2       SJICKR
c------------------------------------------------------------------------------
       DIMENSION   ATOM(NAMAX),CHEM(NSMAX),IW(NIW),RW(NRW)
c------------------------------------------------------------------------------
c    pointers
       COMMON /SJEPTR/
     ;   IoKERR,IoKMON,IoKTRE,IoKUMO,IoNA,IoNB,IoNP,IoNS,IoIB,IoIBO,
     ;   IoJB,IoJBAL,IoJBA,IoJBB,IoJBO,IoJBX,IoJS2,IoKB,IoKB2,IoKBA,
     ;   IoKBB,IoKBO,IoKPC,IoKPCX,IoLB2,IoMPA,IoMPJ,IoN,LoN,IoNSP,
     ;   IoFRND,IoHUGE,IoR1,IoR2,IoR3,IoA,LoA,IoB,LoB,IoBBAL,
     ;   IoCM,LoCM,IoD,LoD,IoDC,LoDC,IoDPML,IoDLAM,IoDLAY,IoE,
     ;   LoE,IoEEQN,IoELAM,IoELMA,IoELMB,IoF,IoG,IoHA,IoHC,IoPA,
     ;   IoPC,IoPMOL,IoQ,LoQ,IoQC,LoQC,IoRC,LoRC,IoRL,IoRP,
     ;   IoSMOA,IoSMOB,IoSMOO,IoSMOL,IoSMUL,IoW,IoX,IoXO,IoY,IoZ
c------------------------------------------------------------------------------
c    Electron designation
       DATA ELECT /'e-'/
c------------------------------------------------------------------------------
c    set comparison constants in calculation precision
       ZERO = 0
       ONE = 1
c
c    get parameters
       NA = IW(IoNA)
       NP = IW(IoNP)
       NS = IW(IoNS)
       KMON = IW(IoKMON)
       KUMO = IW(IoKUMO)
c
c    monitor
       IF (KMON.GT.1)  WRITE (KUMO,1)
1      FORMAT (/' Initialization:')
c
c    clear X and allow all species
       DO 3 J=1,NS
           RW(IoX+J) = 0
           IW(IoKB+J) = 0
3          CONTINUE
c
c    check for zero atom populations and exclude such species
       DO 9 I=1,NA
           IF (RW(IoPA+I).EQ.ZERO)  THEN
               IF (ATOM(I).NE.ELECT)  THEN
                   IF (KMON.GT.1)  WRITE (KUMO,4) ATOM(I)
4                  FORMAT (/' Eliminating species containing ',
     ;                       'absent ',A,' atoms:')
                   DO 7 J=1,NS
                       IF (IW(IoN+I+LoN*J).NE.0)  THEN
                           IF (KMON.GT.1)  WRITE (KUMO,6) CHEM(J)
6                          FORMAT (5X,A)
                           IW(IoKB+J) = 4
                           ENDIF
7                      CONTINUE
                   ENDIF
               ENDIF
9          CONTINUE
c
c ** simplex initialization
c
c    simplex distribution
10     L = 0
       CALL SJISMP(NAMAX,NSMAX,NIW,NRW,ATOM,CHEM,IW,RW,L)
       IF (IW(IoKERR).NE.0)  RETURN
c    check for no basis for anything
       NB = IW(IoNB)
       IF (NB.EQ.0)  THEN
           IW(IoKERR) = 3
           RETURN
           ENDIF
c
c    initialize counters and controls
       KTRR = 0
       KEX30 = 1
       KCCPC = 0
c
c ** loop point after redistribution
c
c    set rebasing counter
20     KTRB = 0
       DOMB = RW(IoHUGE)
c
c ** loop point after rebasing
c
30     KTRB = KTRB + 1
c
c    calculate the conditioning matrix and conditioned populations
       CALL SJICPC(NIW,NRW,IW,RW,KCCPC)
       IF (IW(IoKERR).NE.0)  RETURN
       KCCPC = 1
c
c    calculate phase mols and mol fractions
       CALL SJIPMX(NSMAX,NIW,NRW,CHEM,IW,RW)
c
c    select exit
       GOTO (32,60,90), KEX30
c
c    estimate ELAMs and dominance
32     L = 0
       CALL SJIESL(NSMAX,NIW,NRW,CHEM,IW,RW,L,DOM,JW)
c
c    check for species exclusion
       IF (IW(IoKERR).EQ.4)  GOTO 10
c    check for ESTEP error
       IF (IW(IoKERR).NE.0)  RETURN
c
c    check for needed rebasing
       IF (JW.NE.0)  THEN
c        check vs best basis
           IF (DOM.LT.DOMB)  THEN
c            save base as best
               DO 33 J=1,NS
                   IW(IoKBB+J) = IW(IoKB+J)
                   RW(IoSMOB+J) = RW(IoSMOL+J)
33                 CONTINUE
               DO 35 K=1,NB
                   IW(IoJBB+K) = IW(IoJB+K)
                   RW(IoELMB+K) = RW(IoELAM+K)
35                 CONTINUE
               DOMB = DOM
               ENDIF
c        check rebasing count
           IF (KTRB.GT.NB)  THEN
c            excessive rebasing attempts; use best
               GOTO 50
               ENDIF
c        install JW as a base
           L = JW + 10
           CALL SJISMP(NAMAX,NSMAX,NIW,NRW,ATOM,CHEM,IW,RW,L)
           IF (IW(IoKERR).NE.0)  RETURN
c        check for repeat of the best basis
           IF (KTRB.GT.1)  THEN
               DO 37 J=1,NS
                   L = IW(IoKBB+J)
                   IF (L.LT.0) L = - L
                   IF ((IW(IoKB+J).EQ.1).AND.(L.NE.1))  GOTO 40
37                 CONTINUE
c            rebasing cycling
               GOTO 50
               ENDIF
c
c       try the new basis
40         KEX30 = 1
           GOTO 30
c
c       reinstall the best basis
50         DO 51 J=1,NS
               IW(IoKB+J) = IW(IoKBB+J)
               RW(IoSMOL+J) = RW(IoSMOB+J)
51             CONTINUE
           DO 53 K=1,NB
               RW(IoELAM+K) = RW(IoELMB+K)
               IW(IoJB+K) = IW(IoJBB+K)
53             CONTINUE
           DOM = DOMB
           KEX30 = 2
           GOTO 30
c
           ENDIF
c
c ** redistribution check
c
c    set controls
60     KRED = 0
       KEX30 = 1
c
c    set targets for balancers
       DO 65 J=1,NS
           IF (IW(IoKB+J).EQ.2)  THEN
c        set redistribution to balancer
c            flag possible redistribution
               IF (KRED.EQ.0)  KRED = 1
c            estimate mol fraction
               SUM = - RW(IoG+J)
               DO 63 K=1,NB
                   I = IW(IoIB+K)
                   SUM = SUM + RW(IoELAM+K)*IW(IoN+I+LoN*J)
63                 CONTINUE
                RW(IoX+J) = SJUEXP(SUM)
c            check for valid value
               IF (RW(IoX+J).GE.ONE)  THEN
c                abort redistribution
                   IF (KMON.GT.1)  WRITE (KUMO,64) CHEM(J)
64                 FORMAT (/' Redistribution to x>1 for ',A,
     ;                      ' not allowed; attempting solution.')
                   GOTO 90
                   ENDIF
               ENDIF
65         CONTINUE
c
c    check for no targets
       IF (KRED.EQ.0)  THEN
           IF (KMON.GT.1)  WRITE (KUMO,66)
66         FORMAT (/' Initializer distribution converged.')
           GOTO 90
           ENDIF
c
c    check for repeating redistribution
       IF (KTRR.GT.0)  THEN
c        check repeat of the last distribution
       IF (SJICKR(NIW,NRW,IW,RW))  THEN
c            repeating
               IF (KMON.GT.1)  WRITE (KUMO,66)
c            check for rebasing since the last redistribution
               IF (KTRB.NE.1)  THEN
c                rebased on this pass; restore last redistribution
                   DO 67 J=1,NS
                       IW(IoKB+J) = IW(IoKBA+J)
                       RW(IoSMOL+J) = RW(IoSMOA+J)
67                     CONTINUE
                   DO 69 K=1,NB
                       IW(IoJB+K) = IW(IoJBA+K)
                       RW(IoELAM+K) = RW(IoELMA+K)
69                     CONTINUE
c                go restore phase mols, conditioning
                   KEX30 = 3
                   GOTO 30
                   ENDIF
c            go exit
               GOTO 90
               ENDIF
           ENDIF
c
c ** redistribution
c
c    save distribution
70     DO 71 J=1,NS
           RW(IoXO+J) = RW(IoX+J)
           IW(IoKBO+J) = IW(IoKB+J)
           RW(IoSMOO+J) = RW(IoSMOL+J)
71         CONTINUE
       DO 73 K=1,NB
           IW(IoJBO+K) = IW(IoJB+K)
73         CONTINUE
c
c    monitor
       IF (KMON.GT.1)  THEN
           DO 75 J=1,NS
               IF (IW(IoKB+J).EQ.2) WRITE (KUMO,74) RW(IoX+J),CHEM(J)
74                 FORMAT (/' Redistributing atoms seeking',
     ;                      ' mol fraction =',E16.8,' for ',A)
75             CONTINUE
           ENDIF
c
c    redistribute
       CALL SJISRD(NAMAX,NIW,NRW,IW,RW)
c    check for failed redistribution
       IF (IW(IoKERR).NE.0) THEN
c        attempt solution with distribution before attempted redistribution
           DO 81 J=1,NS
               RW(IoSMOL+J) = RW(IoSMOO+J)
               IW(IoKB+J) = IW(IoKBO+J)
81             CONTINUE
           DO 83 K=1,NB
               IW(IoJB+K) = IW(IoJBO+K)
83             CONTINUE
           IF (KMON.GT.1)  WRITE (KUMO,84)
84         FORMAT (/' Unable to redistribute; attempting solution.')
           GOTO 90
           ENDIF
c
c    check count
       KTRR = KTRR + 1
       IF (KTRR.GT.NB*NP)  THEN
           IF (KMON.GT.1)  WRITE (KUMO,86)
86         FORMAT (/' Excessive iterations in initializer;',
     ;              ' attempting solution.')
           GOTO 90
           ENDIF
c
c    save redistribution
       DO 87 K=1,NB
           IW(IoJBA+K) = IW(IoJB+K)
           RW(IoELMA+K) = RW(IoELAM+K)
87         CONTINUE
       DO 89 J=1,NS
           IW(IoKBA+J) = IW(IoKB+J)
           RW(IoSMOA+J) = RW(IoSMOL+J)
89         CONTINUE
c
c    go try new distribution
       GOTO 20
c
c ** exit
c
c    clear flags
90     DO 91 J=1,NS
           IoKBJ = IoKB+J
           IF (IW(IoKBJ).LT.0)  IW(IoKBJ) = - IW(IoKBJ)
           IF (IW(IoKBJ).EQ.2)  IW(IoKBJ) = 0
91         CONTINUE
c
c    monitor
       If (KMON.GT.1)  THEN
           WRITE (KUMO,92)
92         FORMAT (/' Independent species used as basis set:')
           DO 95 K=1,NB
               J = IW(IoJB+K)
               WRITE (KUMO,94) CHEM(J)
94             FORMAT (5X,A)
95             CONTINUE
           ENDIF
c
c    normal return
       IW(IoKERR) = 0
       RETURN
c
       END
c******************************************************************************
c
       LOGICAL*2 FUNCTION SJICKR(NIW,NRW,IW,RW)
c
c      Tests to see if species, bases, and targets are the same as
c      for previous case KBO,XO to within XRMIN < X/XO < 1/XRMIN
c------------------------------------------------------------------------------
c      Nomenclature:
c
c      Variables in the argument list:
c
c @        NIW         dimension of work array IW
c @        NRW         dimension of work array IR
c          IW(I)       integer work array
c          RW(I)       REAL*8 work array
c
c      Variables in the integer work array IW:
c @        JB(K) = J   if the Jth species is the Kth base species
c @        KB(J)       basis control
c                   -1 if the Jth species is a base freed for SJISRD call
c                    0 if the Jth species is not a base
c                    1 if the Jth species is a base
c                    2 if the Jth species is a balancing species
c                    4 if the Jth species is excluded
c @        KBO(J)      old KB(J)
c @        KMON        monitor control
c @        KUMO        output unit for monitor
c @        NS          number of species
c
c      Variables in the real work array RW:
c @        X(J)        mol fraction of Jth species (here targets)
c @        XO(J)       old X(J)
c------------------------------------------------------------------------------
       IMPLICIT    REAL*8  (A-H,O-Z)
c------------------------------------------------------------------------------
       DIMENSION   IW(NIW),RW(NRW),IEPTR(80)
c------------------------------------------------------------------------------
c   pointers
       COMMON /SJEPTR/ IEPTR
       EQUIVALENCE (IoJB,IEPTR(11)),(IoKB,IEPTR(18)),(IoKBO,IEPTR(22)),
     ;   (IoKMON,IEPTR(2)),(IoKUMO,IEPTR(4)),(IoNS,IEPTR(8)),
     ;   (IoX,IEPTR(77)),(IoXO,IEPTR(78))
c------------------------------------------------------------------------------
c    get parameters
       KMON = IW(IoKMON)
       KUMO = IW(IoKUMO)
       NS = IW(IoNS)
c
c    set range constants in calculation precision
       XRMIN = 0.8
       XRMAX = 1.2
       ZERO = 0
c
c    compare
       DO 9 J=1,NS
c       is species included this time (KB = -1,1,2 ne 0,4)?
           L = IW(IoKB+J)
           M = IW(IoKBO+J)
           IF ((L.NE.0).AND.(L.NE.4))  THEN
c                included; must repeat if omitted before (KBO=0,4)
                   IF ((M.EQ.0).OR.(M.EQ.4))  GOTO 70
               ELSE
c                not included; must repeat if included before (KBO=-1,1,2)
                   IF ((M.NE.0).AND.(M.NE.4))  GOTO 70
               ENDIF
c        check for target (balancing species)
           IF (L.EQ.2)  THEN
               IF (RW(IoX+J).EQ.ZERO)  GOTO 70
c            check target for essential repeat
               TERM = DABS(RW(IoXO+J)/RW(IoX+J))
               IF ((TERM.LT.XRMIN).OR.(TERM.GT.XRMAX)) GOTO 70
               ENDIF
9          CONTINUE
c    same
       SJICKR = .TRUE.
       RETURN
c
c    not same
70     SJICKR = .FALSE.
       RETURN
c
       END
c******************************************************************************
c
       SUBROUTINE SJIPMX(NSMAX,NIW,NRW,CHEM,IW,RW)
c
c      Calculates phase mols and mol fractions from a set of mols.
c------------------------------------------------------------------------------
c      Nomenclature:
c
c      Variables in the argument list:
c @        NSMAX       maximum number of species
c @        NIW         dimension of work array IW
c @        NRW         dimension of work array IR
c @        CHEM(J)     CHARACTER*8 name of Jth species
c          IW(I)       integer work array
c          RW(I)       REAL*8 work array
c
c      Variables in the integer work array IW:
c @        KMON        monitor control
c @        KUMO        output unit for monitor
c @        NP          number of phases
c @        NS          number of species
c @        NSP(M)      number of species in Mth phase
c
c      Variables in the real work array RW:
c #        PMOL(M)     total mols in the Mth phase
c @        SMOL(J)     number of mols of the Jth species
c #        X(J)        mol fraction of the Jth species (in its phase)
c------------------------------------------------------------------------------
       IMPLICIT    REAL*8  (A-H,O-Z)
       CHARACTER*8 CHEM
c------------------------------------------------------------------------------
       DIMENSION   CHEM(NSMAX),IW(NIW),RW(NRW),IEPTR(80)
c------------------------------------------------------------------------------
c    pointers
       COMMON /SJEPTR/IEPTR
       EQUIVALENCE (IoKMON,IEPTR(2)),(IoKUMO,IEPTR(4)),(IoNP,IEPTR(7)),
     ;   (IoNS,IEPTR(8)),(IoNSP,IEPTR(30)),
     ;   (IoPMOL,IEPTR(62)),(IoSMOL,IEPTR(74)),(IoX,IEPTR(77))
c------------------------------------------------------------------------------
c    comparison constant in machine precision
       DATA   ZERO/0.D0/
c------------------------------------------------------------------------------
c    get parameters
       KMON = IW(IoKMON)
       KUMO = IW(IoKUMO)
       NP = IW(IoNP)
       NS = IW(IoNS)
c
c    analyze all phases
       J2=0
       DO 15 M=1,NP
c        analyze phase M
           J1 = J2 + 1
           J2 = J2 + IW(IoNSP+M)
c        compute total mols
           IoPMOM = IoPMOL + M
           RW(IoPMOM) = 0
           DO 11 J = J1,J2
               RW(IoPMOM) = RW(IoPMOM) + RW(IoSMOL+J)
11             CONTINUE
c        compute mol fractions
           IF (RW(IoPMOM).NE.ZERO)  THEN
                   DO 13 J=J1,J2
                       RW(IoX+J) = RW(IoSMOL+J)/RW(IoPMOM)
13                     CONTINUE
               ELSE
                   DO 14 J=J1,J2
                       RW(IoX+J) = 0
14                     CONTINUE
               ENDIF
15         CONTINUE
c
c    monitor
       IF (KMON.GT.1)  THEN
           WRITE (KUMO,20)
20         FORMAT (/' Estimated distribution:')
           WRITE (KUMO,21) (M,RW(IoPMOL+M),M=1,NP)
21         FORMAT ('   Phase ',I2,' mols =',1PE12.5)
           DO 29 J1=1,NS,6
               J2 = J1 + 5
               IF (J2.GT.NS)  J2 = NS
               WRITE (KUMO,22) (CHEM(J),J=J1,J2)
22             FORMAT  (6X,6(4X,A8))
               WRITE (KUMO,23) (RW(IoSMOL+J),J=J1,J2)
23             FORMAT  ('   mols:',6(1PE12.5))
               WRITE (KUMO,24) (RW(IoX+J),J=J1,J2)
24             FORMAT  ('      X:',6E12.5)
29             CONTINUE
           ENDIF
c
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE SJICPC(NIW,NRW,IW,RW,KOP)
c
c      Computes the conditioning matrix and conditioned populations
c------------------------------------------------------------------------------
c      The conditioning matrix satisfies
c
c          sum{CM(M,K)*N(I(K),J(L))} = delta(M,L)
c            independent atoms K
c------------------------------------------------------------------------------
c
c      For KOP = 0  makes the calculation and saves JB(K) in JBX(K)
c
c      For KOP > 0  only makes calculation if JB() ne JBX()
c
c      On return:
c
c          Successful:
c              CM and PC loaded
c              KERR = 0
c
c          Problems:
c              KERR = 1
c------------------------------------------------------------------------------
c      Nomenclature:
c
c      Variables in the argument list:
c @        NIW         dimension of work array IW
c @        NRW         dimension of work array IR
c          IW(I)       integer work array
c          RW(I)       REAL*8 work array
c @        KOP         option control (see above)
c
c      Variables in the integer work array IW:
c @        IB(K) = I   if the Ith atom is the Kth independent atom
c @        JB(K) = J   if the Jth species is the Kth base species
c @#       JBX(K)      JB of the previous call
c #        KERR        error flag
c @        N(I,J)      number if Ith atoms in the Jth species
c @        NB          number of independent atoms
c
c      Variables in the real work array RW:
c -        A(I,J)      work array
c #        CM(I,J)     conditioning matrix
c @        PA(I)       population of I atoms
c #        PC(K)       Kth conditioned population
c -        W(I)        work array
c
c      Variables used only internally:
c @#       NBX         NB at last call
c------------------------------------------------------------------------------
       IMPLICIT    REAL*8  (A-H,O-Z)
c------------------------------------------------------------------------------
       DIMENSION   IW(NIW),RW(NRW),IEPTR(80)
c------------------------------------------------------------------------------
c    pointers
       COMMON /SJEPTR/ IEPTR
       EQUIVALENCE (IoIB,IEPTR(9)),(IoJB,IEPTR(11)),(IoJBX,IEPTR(16)),
     ;  (IoKERR,IEPTR(1)),
     ;  (IoN,IEPTR(28)),(LoN,IEPTR(29)),(IoNB,IEPTR(6)),
     ;  (IoA,IEPTR(36)),(LoA,IEPTR(37)),
     ;  (IoCM,IEPTR(41)),(LoCM,IEPTR(42)),
     ;  (IoPA,IEPTR(60)),(IoPC,IEPTR(61)),(IoW,IEPTR(76))
c------------------------------------------------------------------------------
c    get parameters
       NB = IW(IoNB)
c
c    check option
       IF (KOP.GT.0)  THEN
           DO 5 K=1,NB
               IF (IW(IoJB+K).NE.IW(IoJBX+K))  GOTO 10
5              CONTINUE
c        redundant computation
           IW(IoKERR) = 0
           RETURN
           ENDIF
c
c -- Calculate C
c
10      NBX = NB
        DO 59 M=1,NB
c        set up the matrix and rhs
           DO 39 L=1,NB
c            identify the base species
               J = IW(IoJB+L)
c            save base species
               IW(IoJBX+L) = J
c            right hand side
               IF (L.EQ.M)  THEN
                       RW(IoW+L) = 1
                   ELSE
                       RW(IoW+L) = 0
                   ENDIF
c            matrix
               DO 29 K=1,NB
c                identify the atom
                   I = IW(IoIB+K)
c                set the coefficient
                   RW(IoA+L+LoA*K) = IW(IoN+I+LoN*J)
29                 CONTINUE
39             CONTINUE
c
c        solve for CM(M,K) for K=1,NB
           CALL SJULES(LoA,RW(IoA+1+LoA),RW(IoW+1),NB,IW(IoKERR))
           IF (IW(IoKERR).NE.0)  RETURN
c
c        set the Mth row of CM
           DO 49 K=1,NB
               RW(IoCM+M+LoCM*K) = RW(IoW+K)
49             CONTINUE
59         CONTINUE
c
c    compute conditioned populations
       DO 69 K=1,NB
           IoPCK = IoPC + K
           RW(IoPCK) = 0
           TERMX = 0
           DO 67 L=1,NB
               IL = IW(IoIB+L)
               TERM = RW(IoCM+K+LoCM*L)*RW(IoPA+IL)
               CALL SJUMAX(TERM,TERMX)
               RW(IoPCK) = RW(IoPCK) + TERM
67             CONTINUE
           CALL SJURND(RW(IoPCK),TERMX)
69         CONTINUE
c
c -- Normal return
c
       IW(IoKERR) = 0
       RETURN
       END
c******************************************************************************


	INTEGER I
	DO I = 1000,9999
	IF (I**0.5.EQ.INT(I**0.5)) THEN
	IF (I/1000.EQ.(I/100 - 10*(I/1000))) THEN
	IF ((I/10 - 10*(I/100)).EQ.MOD(I,10)) THEN
	WRITE (*,10) INT(I**0.5),I
10	FORMAT("N=",I2,"  AABB=",I4)
	END IF
	END IF
	END IF
	END DO
	STOP
	END

codes/AULAS DO FORTRAN/aula 7(Quadrado perfeito)/desafio.for


MODULE FUN_xyzNORMSQRD
!!#### PURPOSE
!! Compute the normalization factor squared for a vector in R^3.

!!#### METHOD
!! Square root of the sum of the squares of x, y, and z components.

!!#### DEPENDENCIES
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyzNORMSQRD_V
 MODULE PROCEDURE xyzNORMSQRD_V_Rsp
 MODULE PROCEDURE xyzNORMSQRD_V_Rdp
ENDINTERFACE
PUBLIC :: xyzNORMSQRD_V

CONTAINS

PURE FUNCTION xyzNORMSQRD_V_Rsp( V ) RESULT(NORMSQRD)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyzNORMSQRD_V.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyzNORMSQRD_V.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyzNORMSQRD_V_Rdp( V ) RESULT(NORMSQRD)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyzNORMSQRD_V.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyzNORMSQRD_V.f90.bdy"
!!--end--
END FUNCTION

END MODULE


program problem4
  use euler
  implicit none
  integer :: i,j,n,best=0

  do i=999,100,-1
     do j=i,100,-1
        n = i*j
        if (is_palindrome(n) .and. (n .gt. best)) then
           best = n
        end if
     end do
  end do
  print *, best

end program problem4