subroutine plcd_turnon(a)
   ! DESCRIPTION
   !    This routine starts the run for the elastic solid prob
   !-----------------------------------------------------------------------
   use typre
   use def_parame
!   use Mod_iofile
   use Mod_PLCD
   use Mod_Element
   use Mod_plcd_Material
   use Mod_plcd_SIMP_TopologyOptimization
   use Mod_plcd_TD_TopologyOptimization
   use Mod_plcd_TD_StochasticTopologyOptimization
   use MPI
   implicit none
   class(PLCDProblem), target :: a

   real(rp) :: time
   integer(ip) :: is, iss,ierr

   class(FiniteElement), pointer :: e => NULL()
   integer(ip) :: imaterial,ielem,nelem

   logical :: IsRequired

   interface
      subroutine plcd_ComputeInitialAcceleration(a)
      import
      implicit none
      class(PLCDProblem), target :: a

      end subroutine
   end interface

   !Setup stages and substages
   time = 0.0_rp
   do is = 1,a%NumberOfStages
      do iss = 1,a%Stages(is)%NumberOfSubstages
         a%Stages(is)%Substages(iss)%IniTime = time
         time = time + a%Stages(is)%Substages(iss)%TimeInterval
         a%Stages(is)%Substages(iss)%EndTime = time
      enddo
   enddo

!This is now done in plcd_memall, because the info is needed in read boundary conditions (for reading element info for each mat)
!    !Initially compute the constitutive tensor for each material
!    do imaterial = 1,a%NumberOfMaterials
!
!       if (a%UseUPFormulation) call a%Materials(imaterial)%p%SetUseUPFormulation(.true.)
!       call a%Materials(imaterial)%p%Setup
!
!       !Check if any material needs the element size so that it is computed
!       call a%Materials(imaterial)%p%IsElementSizeRequiredByEMDs(IsRequired)
!       if (IsRequired) a%IsElementSizeRequiredByEMDs = .true.
!    enddo

   !Allocate the data structures for the materials at each Gauss Point
!    call a%Mesh%ElementAlloc(e,a%Memor,'DefaultRule','plcd_Elmope')
!    call a%Mesh%GetNelem(nelem)
!    do ielem = 1,nelem
!       !Load Element
!       call a%Mesh%ElementLoad(ielem,e)
!       imaterial = a%AuxRead_ElementMaterialList(ielem)
!       if (imaterial <= 0 .or. imaterial > a%NumberOfMaterials) call runend('Wrong material number')
!       call a%Materials(imaterial)%p%SpecificCreateElementData(e%pgaus,a%ElementMaterialsData(ielem)%p)
!    enddo
!    call a%Mesh%ElementDealloc(e,a%Memor,'DefaultRule','plcd_Elmope')

   ! call a%Memor%dealloc(nelem,a%AuxRead_ElementMaterialList,'AuxRead_ElementMaterialList','plcd_memall')

   !Topology Optimization
   if (a%kfl_TopologyOptimization == 1) then
      call MemallSIMP(a)
   elseif (a%kfl_TopologyOptimization==2) then
      call MemallTD(a)
   end if

   !Large Strains, Updated Formulation
   if (a%kfl_LargeStrains == 1) then
      !So we can move the mesh for Updated Formulation
      call a%Mesh%SetALE(1_ip)
      call a%Mesh%SetDisplacements(a%Displacement(:,:,:))
   endif

   !Transient Problem, Compute Initial Accelerations
   if (a%kfl_TransientProblem == 1) then
      call plcd_ComputeInitialAcceleration(a)
   endif

end subroutine plcd_turnon


C=======================================================================
C  FOR_OPGROW, Subroutine, G. Hoogenboom, J.W. Jones
C-----------------------------------------------------------------------
C  Generates output file for daily growth variables
C-----------------------------------------------------------------------
C  REVISION       HISTORY
C  01/01/1990 GH  Written
C  09/21/1998 CHP Split off from OPDAY.FOR file
C  05/11/1999 GH  Incorporated in CROPGRO
C  06/19/2001 GH  Modified output format
C  08/20/2002 GH  Modified for Y2K
C-----------------------------------------------------------------------
C  Called by: PLANT
C  Calls:     None
!=======================================================================
      SUBROUTINE FOR_OPGROW(CONTROL, ISWITCH,
     &    CADLF, CADST, CANHT, CANWH, CMINEA, DWNOD,
     &    GROWTH, GRWRES, MAINR, MDATE, NFIXN, NSTRES,
     &    PCLSD, PCCSD, PCNL, PCNRT, PCNSD, PCNSH, PCNST,
     &    PG, PODNO, PODWT, PODWTD, RHOL, RHOS, RLV, RSTAGE,
     &    RTDEP, RTWT, SATFAC, SDWT, SEEDNO, SLA, STMWT, SWFAC,
     &    TGRO, TGROAV, TOPWT, TOTWT, TURFAC, VSTAGE, WTCO,
     &    WTLF, WTLO, WTNCAN, WTNLF, WTNST, WTNSD, WTNUP,
     &    WTNFX, WTSO, XLAI, YRPLT,
!     &  CADSR, PCNSR, PSRSRFD, PSRSRFL, RHOSR, STRWT,
!     &  WTNSR, WTSRO,

     &  DRMST, PPGFAC, PPMFAC, PPTFAC, SRFTEMP, ST, FREEZ2,

     &  AGRSTR, CADSR, CMOBSR, CPFSTR, CRUSSR, CSRFRZ, CSRW,
     &  CSTRM, DSTOR, FNINSR, FNINSRG, FRSTR, FRSTRM, NADSR,
     &  NGRSR, NGRSRG, NMOBSR, NRUSSR, NSRALL, NSRDOT, NSROFF,
     &  NVSTSR, PCNSR, PCSTRD, PROSRT, PSRSRFD, PSRLYRD,
     &  PSRSRFL, PSRLYR1, RHOSR, SRDAM, SRSRFD, SRLYRD, SSRDOT,
     &  SSRNDOT, STRWT, TPSRSRFL, TPSRLYR1, WCRSR, WNRSR,
     &  WRCSRDT, WSRDOT, WSRDOTN, WSRFDOT, WSRI, WSRIDOT,
     &  WTNSR, WTNSRA, WTNSRO, WTSRO, XSTR,

     &  PROSRF, PROSRG, PROSRI, PCARSR, PLIGSR,
     &  PLIPSR, POASR, PMINSR, ALPHSR, CMOBSRX, CADSRF, NMOBSRX, CLAIT,
     &  YSTOR, FRSTRF, FRSTRMX, STRSRFL, STRLYR1, SENSR,
     &  FNPTD, TYPPTD, FNPMD, TYPPMD, FNPGD, TYPPGD, HARD1, HARD2,
     &  FRZDC, FRZHRD, TYPHRD, FRZDHD, TYPDHD, RDRMG, RDRMM, RDRMT,
     &  RCHDP,
     &  FRLF, FRSTM, FRRT,
     &  FHWAH, FHLPH, DWTCO, DWTLO, DWTSO,fhpctn,RHOR,MOWC,RSPLC)

!-----------------------------------------------------------------------
      USE ModuleDefs     !Definitions of constructed variable types,
        ! which contain control information, soil
        ! parameters, hourly weather data.
      !     VSH
      USE CsvOutput
      USE Linklist
      IMPLICIT NONE
      SAVE
!-----------------------------------------------------------------------
      CHARACTER*1  IDETG, RNMODE
      CHARACTER*2  CROP
      CHARACTER*6, PARAMETER :: ERRKEY = 'OPGROW'
!      CHARACTER*8  FNAME
      CHARACTER*12 OUTG, OUTPC, OUTPN, OUTDRM, OUTSTOR, OUTINSTR

      CHARACTER*30 FILEIO

      INTEGER DAP, DAS, DOY, DYNAMIC, ERRNUM, FROP, I
      INTEGER NOUTDG, NOUTPC, NOUTPN, RUN, RSTAGE
      INTEGER NOUTDRM, NOUTSTOR, NOUTINSTR
      INTEGER TIMDIF, YEAR, YRDOY, MDATE, YRPLT, YRSIM

      INTEGER :: N_LYR = 10   ! VSH

      REAL CADLF, CADST, CANHT, CANWH, CMINEA, DWNOD
      REAL GROWTH, GRWRES, HI, HIP, MAINR, NSTRES
      REAL PCLSD, PCCSD, PCNL, PG, PODNO, PODWT, PODWTD
      REAL RHOL, RHOS, RTDEP, RTWT, STMWT, SDWT, SEEDNO
      REAL SDSIZE, SHELLW, SHELPC, SLA
      REAL SATFAC, SWFAC, TGROAV, TOPWT, TOTWT, TURFAC
      REAL VSTAGE, WTCO, WTLF, WTLO, WTSO, XLAI
      REAL RLV(NL)
      REAL TGRO(TS)

      REAL FRLF, FRSTM, FRRT, FHWAH, FHLPH, PELF

      REAL WTNCAN,WTNLF,WTNST,WTNSD,WTNUP,WTNFX
      REAL WTNVEG,PCNVEG,NFIXN
      REAL PCNST,PCNRT,PCNSH,PCNSD
!      REAL CADSR, PCNSR, PSRSRFD, PSRSRFL, RHOSR, STRWT,
!     &  WTNSR, WTSRO
      REAL DWTCO, DWTLO, DWTSO

      CHARACTER*6 DRMST
      CHARACTER*3   TYPPGD,TYPPTD, TYPPMD, TYPHRD, TYPDHD

      REAL PPGFAC, PPMFAC, PPTFAC, SRFTEMP, FREEZ2

      REAL AGRSTR, CADSR, CMOBSR, CPFSTR, CRUSSR, CSRFRZ, CSRW,
     &  CSTRM, DSTOR, FNINSR, FNINSRG, FRSTR, FRSTRM, NADSR,
     &  NGRSR, NGRSRG, NMOBSR, NRUSSR, NSRALL, NSRDOT, NSROFF,
     &  NVSTSR, PCNSR, PCSTRD, PROSRT, PSRSRFD, PSRLYRD,
     &  PSRSRFL, PSRLYR1, RHOSR,RHOR,SRDAM, SRSRFD, SRLYRD, SSRDOT,
     &  SSRNDOT, STRWT, TPSRSRFL, TPSRLYR1, WCRSR, WNRSR,
     &  WRCSRDT, WSRDOT, WSRDOTN, WSRFDOT, WSRI, WSRIDOT,
     &  WTNSR, WTNSRA, WTNSRO, WTSRO, XSTR

      REAL PROSRF, PROSRG, PROSRI, PCARSR, PLIGSR,
     &  PLIPSR, POASR, PMINSR, ALPHSR, CMOBSRX, CADSRF, NMOBSRX, CLAIT,
     &  YSTOR(8), FRSTRF, FRSTRMX, STRSRFL, STRLYR1, SENSR,
     &  FNPTD(4), FNPMD(4), FNPGD(4), HARD1, HARD2,
     &  FRZDC, FRZHRD(4),
     &  FRZDHD(4), RDRMG, RDRMM, RDRMT, RCHDP,fhpctn,MOWC,RSPLC

      REAL, DIMENSION(NL) :: ST
C-------------------------------------------

      LOGICAL FEXIST, FIRST

!-----------------------------------------------------------------------
!     Define constructed variable types based on definitions in
!     ModuleDefs.for.

!     The variable "CONTROL" is of type "ControlType".
      TYPE (ControlType) CONTROL

!     The variable "ISWITCH" is of type "SwitchType".
      TYPE (SwitchType) ISWITCH

!     No output for fallow crop
      CROP    = CONTROL % CROP
      IDETG   = ISWITCH % IDETG
      IF (CROP .EQ. 'FA' .OR. IDETG .EQ. 'N') RETURN

!     Transfer values from constructed data types into local variables.
      DAS     = CONTROL % DAS
      DYNAMIC = CONTROL % DYNAMIC
      FILEIO  = CONTROL % FILEIO
      FROP    = CONTROL % FROP
!      LUNIO   = CONTROL % LUNIO
      RUN     = CONTROL % RUN
      RNMODE  = CONTROL % RNMODE
      YRDOY   = CONTROL % YRDOY
      YRSIM   = CONTROL % YRSIM

      IDETG = ISWITCH % IDETG

      FMOPT  = ISWITCH % FMOPT    ! VSH

!***********************************************************************
!***********************************************************************
!     Run initialization - run once per simulation
!***********************************************************************
      IF (DYNAMIC .EQ. RUNINIT) THEN
!-----------------------------------------------------------------------
!      IF (IDETG .EQ. 'Y') THEN
        IF (FMOPT == 'A' .OR. FMOPT == ' ') THEN    ! VSH
        OUTG  = 'PlantGro.OUT'
        CALL GETLUN('OUTG', NOUTDG)

        OUTPN  = 'PlantN.OUT  '
        CALL GETLUN('OUTPN', NOUTPN)

        OUTPC  = 'PlantC.OUT  '
        CALL GETLUN('OUTPC', NOUTPC)

        OUTDRM  = 'Dormancy.OUT'
        CALL GETLUN('OUTDRM', NOUTDRM)

        OUTSTOR  = 'Storage.OUT '
        CALL GETLUN('OUTSTOR', NOUTSTOR)
        END IF    ! VSH
!        OUTINSTR  = 'StorSpIn.OUT'
!        CALL GETLUN('OUTINSTR', NOUTINSTR)

!      ENDIF

!***********************************************************************
!***********************************************************************
!     Seasonal initialization - run once per season
!***********************************************************************
      ELSEIF (DYNAMIC .EQ. SEASINIT) THEN
!-----------------------------------------------------------------------
!       Initialize daily growth output file
        IF (FMOPT == 'A' .OR. FMOPT == ' ') THEN    ! VSH
        INQUIRE (FILE = OUTG, EXIST = FEXIST)
        IF (FEXIST) THEN
        OPEN (UNIT = NOUTDG, FILE = OUTG, STATUS = 'OLD',
     &  IOSTAT = ERRNUM, ACCESS = 'APPEND')
        FIRST = .FALSE.
        ELSE
        OPEN (UNIT = NOUTDG, FILE = OUTG, STATUS = 'NEW',
     &  IOSTAT = ERRNUM)
        WRITE(NOUTDG,'("*GROWTH ASPECTS OUTPUT FILE")')
        FIRST = .TRUE.
        ENDIF

        !Write headers
!        CALL HEADER(SEASINIT, FILEIO, NOUTDG, RUN)
        CALL HEADER(SEASINIT, NOUTDG, RUN)
        WRITE (NOUTDG,210)
210   FORMAT('@YEAR DOY   DAS   DAP',
     &    '  L#SD  GSTD  LAID  LWAD  SWAD  QWAD  QS%D  Q1%D  GWAD',
     &    '  RWAD  CWAD  G#AD   GWGD  HIAD  PWAD',
     &    '  P#AD  WSPD  WSGD  NSTD  EWSD  LN%D',
     &    '  SH%D  HIPD  PWDD  PWTD  SLAD  CHTD',
     &    '  CWID  NWAD  RDPD  RL1D  RL2D  RL3D',
     &    '  RL4D  RL5D  RL6D  RL7D  RL8D  RL9D',
     &    '  RL10  CDAD  LDAD  SDAD  QDAD  HERB  FHL%  LF%D'
!    &    ' DWTCO DWTLO DWTSO CHTCM CPROT  MOWC  RSPLC')
     &    ' DWTCO DWTLO DWTSO CHTCM CPROT')
!-----------------------------------------------------------------------
!       Initialize daily plant nitrogen output file
        INQUIRE (FILE = OUTPN, EXIST = FEXIST)
        IF (FEXIST) THEN
        OPEN (UNIT = NOUTPN, FILE = OUTPN, STATUS = 'OLD',
     &  IOSTAT = ERRNUM, ACCESS = 'APPEND')
        FIRST = .FALSE.
        ELSE
        OPEN (UNIT = NOUTPN, FILE = OUTPN, STATUS = 'NEW',
     &  IOSTAT = ERRNUM)
        WRITE(NOUTPN,'("*PLANT N OUTPUT FILE")')
        FIRST = .TRUE.
        ENDIF

        !Write headers
!        CALL HEADER(SEASINIT, FILEIO, NOUTPN, RUN)
        CALL HEADER(SEASINIT, NOUTPN, RUN)

        WRITE (NOUTPN,230)
230   FORMAT('@YEAR DOY   DAS   DAP',
     &  '  CNAD  GNAD  VNAD  GN%D  VN%D    NFXC   NUPC',
     &  '  LNAD  SNAD  QNAD  LN%D  SN%D  QN%D  SHND',
     &  '  RN%D  NFXD')

!-----------------------------------------------------------------------
!       Initialize daily plant carbon output file
        INQUIRE (FILE = OUTPC, EXIST = FEXIST)
        IF (FEXIST) THEN
        OPEN (UNIT = NOUTPC, FILE = OUTPC, STATUS = 'OLD',
     &  IOSTAT = ERRNUM, ACCESS = 'APPEND')
        FIRST = .FALSE.
        ELSE
        OPEN (UNIT = NOUTPC, FILE = OUTPC, STATUS = 'NEW',
     &  IOSTAT = ERRNUM)
        WRITE(NOUTPC,'("*PLANT C OUTPUT FILE")')
        FIRST = .TRUE.
        ENDIF

        !Write headers
!        CALL HEADER(SEASINIT, FILEIO, NOUTPC, RUN)
        CALL HEADER(SEASINIT, NOUTPC, RUN)

        WRITE (NOUTPC,250)
250   FORMAT('@YEAR DOY   DAS   DAP  TWAD   PHAD',
     &  '   CMAD   CGRD   GRAD   MRAD   CHAD  QHAD  CL%D  CS%D',
     &  '  QC%D  CR%D  TGNN  TGAV  GN%D  GL%D  GC%D')

!-----------------------------------------------------------------------
!       Initialize daily Dormancy output file
        INQUIRE (FILE = OUTDRM, EXIST = FEXIST)
        IF (FEXIST) THEN
        OPEN (UNIT = NOUTDRM, FILE = OUTDRM, STATUS = 'OLD',
     &  IOSTAT = ERRNUM, ACCESS = 'APPEND')
        FIRST = .FALSE.
        ELSE
        OPEN (UNIT = NOUTDRM, FILE = OUTDRM, STATUS = 'NEW',
     &  IOSTAT = ERRNUM)
        WRITE(NOUTDRM,'("*PLANT DORMANCY OUTPUT FILE")')
        FIRST = .TRUE.
        ENDIF

        !Write headers
!        CALL HEADER(SEASINIT, FILEIO, NOUTDRM, RUN)
        CALL HEADER(SEASINIT, NOUTDRM, RUN)

        WRITE (NOUTDRM,270)
270   FORMAT('@YEAR DOY   DAS   DAP',
     &  '   QDSD  PPGF  PPMF  PPTF  TSRD  TS1D  FRZ2  LV%D  SV%D',
     &    '  QV%D  RV%D')

!-----------------------------------------------------------------------
!       Initialize daily Storage output file
        INQUIRE (FILE = OUTSTOR, EXIST = FEXIST)
        IF (FEXIST) THEN
        OPEN (UNIT = NOUTSTOR, FILE = OUTSTOR, STATUS = 'OLD',
     &  IOSTAT = ERRNUM, ACCESS = 'APPEND')
        FIRST = .FALSE.
        ELSE
        OPEN (UNIT = NOUTSTOR, FILE = OUTSTOR, STATUS = 'NEW',
     &  IOSTAT = ERRNUM)
        WRITE(NOUTSTOR,'("*PLANT STORAGE OUTPUT FILE")')
        FIRST = .TRUE.
        ENDIF

        !Write headers
!        CALL HEADER(SEASINIT, FILEIO, NOUTSTOR, RUN)
        CALL HEADER(SEASINIT, NOUTSTOR, RUN)

        WRITE (NOUTSTOR,280)
280   FORMAT('@YEAR DOY   DAS   DAP',
     &   '  QCQD  QHAD  QC%M  QRAD  QMAD  QCFD  QCAD  QCDD  QDTD',
     &   '  QN%X  QN%I  QV%D  QV%T  QNAA  QNRX  QNRN  QNAR  QNAM',
     &   '  QNAG  QNAN  QNAL  QN%N  QN%D  QW%C  QP%W  QL%S  QL%1',
     &   '  QS%D  Q1%D  QC%D  QCAM  QFDS  QFD1  QEAD  QEWD  QWAD',
     &   '  QT%S  QT%1  QCRD  QNMD  QCAG  QWNG  QWND  QFAD  QWAI',
     &   '  QMAM  QNAD  QNAC  QNLC  QDAD  XSTR')
         END IF    ! VSH
!-----------------------------------------------------------------------
!       Initialize Storage inputs output file
!        INQUIRE (FILE = OUTINSTR, EXIST = FEXIST)
!        IF (FEXIST) THEN
!          OPEN (UNIT = NOUTINSTR, FILE = OUTINSTR, STATUS = 'OLD',
!     &  IOSTAT = ERRNUM, ACCESS = 'APPEND')
!          FIRST = .FALSE.
!        ELSE
!          OPEN (UNIT = NOUTINSTR, FILE = OUTINSTR, STATUS = 'NEW',
!     &  IOSTAT = ERRNUM)
!          WRITE(NOUTINSTR,'("*PLANT STORAGE INPUTS OUTPUT FILE")')
!          FIRST = .TRUE.
!        ENDIF

        !Write headers
!        CALL HEADER(SEASINIT, FILEIO, NOUTINSTR, RUN)

!        WRITE (NOUTINSTR,290)
!  290   FORMAT('  SP%F  SP%G  SP%I  SRC%  SRG%  SRL%  SRO%  SRM%',
!     &  '  SR%L  SC%M  C%SR  SMNX  LAIT  SP%1  SP%2  SP%3  SP%4',
!     &    '  SP%5  SP%6  SP%7  SP%8  FRSR  FSRX  SRSF  SRL1  SNSR',
!     &  '  SRT1  SRT2  SRT3  SRT4  TSPT  SRM1  SRM2  SRM3  SRM4',
!     &    '  TSPM  SRG1  SRG2  SRG3  SRG4  TSPG  HRD1  HRD2  FZDC',
!     &  '  ZHD1  ZHD2  ZHD3  ZHD4  THRD  ZDH1  ZDH2  ZDH3  ZDH4',
!     &    '  TDHD  RDMG  RDMM  RDMT  RCHD')

!***********************************************************************
!***********************************************************************
!     DAILY OUTPUT
!***********************************************************************
      ELSE IF (DYNAMIC .EQ. OUTPUT) THEN

!-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C   CHECK FOR OUTPUT FREQUENCY
C-----------------------------------------------------------------------
      IF (YRDOY .LT. YRPLT .OR. YRPLT .LT. 0) RETURN
      IF ((MOD(DAS,FROP) .EQ. 0)          !Daily output every FROP days,
     &  .OR. (YRDOY .EQ. YRPLT)           !on planting date, and
     &  .OR. (YRDOY .EQ. MDATE)) THEN     !at harvest maturity

!       Print
        DAP = MAX(0,TIMDIF(YRPLT,YRDOY))
        CALL YR_DOY(YRDOY, YEAR, DOY)

        IF (IDETG .EQ. 'Y') THEN
        IF (PODWT .GT. 0.1) THEN
        SHELPC = SDWT*100./PODWT
        ELSE
        SHELPC = 0.0
        ENDIF

        SHELPC = MIN(SHELPC,99.99)
        SHELLW = PODWT - SDWT       !Not used

        IF (SEEDNO .GT. 0.0) THEN
        SDSIZE = SDWT/SEEDNO*1000
        ELSE
        SDSIZE = 0.0
        ENDIF

!        IF (WTLF .GT. 0. .AND. SDWT .GE. 0.) THEN
        IF (WTLF .GT. 0.) THEN
        PELF = 100.*WTLF/(WTLF+STMWT)
        ELSE
        PELF = 0.0
        ENDIF

        IF (FHWAH .eq. 0.0) THEN
        fhpctn = 0.0
        endif

        IF (TOPWT .GT. 0. .AND. SDWT .GE. 0.) THEN
        HI = SDWT/TOPWT
        ELSE
        HI = 0.
        ENDIF

        IF (TOPWT .GT. 0. .AND. PODWT .GE. 0.) THEN
        HIP = PODWT/TOPWT
        ELSE
        HIP = 0.
        ENDIF

        IF (FMOPT == 'A' .OR. FMOPT == ' ') THEN   ! VSH
        WRITE (NOUTDG,310)YEAR, DOY, DAS, DAP,VSTAGE,RSTAGE,XLAI,
     &    NINT(WTLF*10.),NINT(STMWT*10.),NINT(STRWT*10.),
     &    PSRSRFL, PSRLYR1, NINT(SDWT*10.),
     &    NINT(RTWT*10.),NINT(TOPWT*10.),NINT(SEEDNO),SDSIZE,HI,
     &    NINT(PODWT*10.),NINT(PODNO),(1.-SWFAC),(1.-TURFAC),
     &    (1.-NSTRES),SATFAC,PCNL,SHELPC,HIP,NINT(PODWTD*10.),
     &    NINT((PODWTD+PODWT)*10.),SLA,CANHT,CANWH,(DWNOD*10.),
     &    (RTDEP/100.),(RLV(I),I=1,10),
     &    NINT(WTCO*10.),NINT(WTLO*10.),NINT(WTSO*10.),
     &    NINT(WTSRO*10.),NINT(FHWAH*10.),FHLPH,
     &    PELF,NINT(DWTCO*10.),NINT(DWTLO*10.),NINT(DWTSO*10.),
     &    NINT(CANHT*100.),fhpctn*6.25    !,MOWC,RSPLC
310     FORMAT (1X,I4,1X,I3.3,2(1X,I5),
     &    1X,F5.1,1X,I5,1X,F5.2,3(1X,I5),2(1X,F5.2),4(1X,I5),
     &    1X,F6.1,1X,F5.3,2(1X,I5),4(1X,F5.3),3(1X,F5.2),
     &    2(1X,I5),1X,F5.1,2(1X,F5.2),1X,F5.1,11(1X,F5.2),
     &    4(I6),1x,I5,2(1X,F5.1),3(I6),I6,F6.2,F6.0,F6.2)
        END IF   ! VSH

!     VSH CSV output corresponding to PlantGro.OUT
      IF (FMOPT == 'C') THEN
       Call CsvOut_PlGroPrFrm(EXPNAME, RUN, CONTROL%TRTNUM,
     & CONTROL%ROTNUM, CONTROL%REPNO, YEAR,
     & DOY, DAS, DAP, VSTAGE, RSTAGE, XLAI, WTLF, STMWT, STRWT, PSRSRFL,
     & PSRLYR1, SDWT, RTWT, TOPWT, SEEDNO, SDSIZE, HI, PODWT, PODNO,
     & SWFAC, TURFAC, NSTRES, SATFAC, PCNL, SHELPC, HIP, PODWTD, SLA,
     & CANHT, CANWH, DWNOD, RTDEP, WTCO, WTLO, WTSO, WTSRO, FHWAH,
     & FHLPH, PELF, DWTCO, DWTLO, DWTSO, fhpctn, N_LYR, RLV,
     & vCsvlinePlGroPrFrm, vpCsvlinePlGroPrFrm, vlngthPlGroPrFrm)
       CALL LinklstPlGroPrFrm(vCsvlinePlGroPrFrm)
      END IF
C-----------------------------------------------------------------------
        WTNVEG  = (WTNLF + WTNST)

        IF ((WTLF+STMWT).GT. 0.0) THEN
        PCNVEG = (WTNLF+WTNST)/(WTLF+STMWT)*100.
        ELSE
        PCNVEG = 0.0
        ENDIF

        IF (FMOPT == 'A' .OR. FMOPT == ' ') THEN       ! VSH
        WRITE (NOUTPN,410) YEAR, DOY, DAS, DAP, (WTNCAN*10),
     &   (WTNSD*10), (WTNVEG*10), PCNSD, PCNVEG, (WTNFX*10),
     &   (WTNUP*10), (WTNLF*10), (WTNST*10), (WTNSR*10.), PCNL,
     &   PCNST, PCNSR, PCNSH, PCNRT, NFIXN*10
410     FORMAT(1X,I4,1X,I3.3,2(1X,I5),3(1X,F5.1),2(1X,F5.2),1X,
     &   2(1X,F6.1),3(1X,F5.1),3(1X,F5.2),2(1X,F5.2),1X,F5.1)
!CHP TEMP     &   (1X,F6.1),1X,F8.3,2(1X,F5.1),2(1X,F5.2),3(1X,F5.1))

        WRITE (NOUTPC,510) YEAR, DOY, DAS, DAP,
     &    NINT(TOTWT*10), PG, CMINEA, GROWTH,
     &    GRWRES, MAINR, (CADLF + CADST), CADSR, RHOL*100.,
     &    RHOS*100., RHOSR*100., RHOR*100., TGRO(12), TGROAV, PCNSD,
     &    PCLSD, PCCSD
510     FORMAT(1X,I4,1X,I3.3,3(1X,I5),6(1X,F6.2),F6.2,4(1X,F5.1),
     &   2(1X,F5.1),3(1X,F5.2))

        WRITE (NOUTDRM,610) YEAR, DOY, DAS, DAP,
     &    DRMST, PPGFAC, PPMFAC, PPTFAC, SRFTEMP, ST(1), FREEZ2,
     &    FRLF, FRSTM, FRSTR, FRRT
610     FORMAT(1X,I4,1X,I3.3,2(1X,I5),1X,A6,3(1X,F5.3),
     &    3(1X,F5.1),4(1X,F5.3))

        WRITE (NOUTSTOR,710) YEAR, DOY, DAS, DAP,
     &    AGRSTR, CADSR, CMOBSR, CPFSTR, CRUSSR, CSRFRZ,
     &    NINT(CSRW), CSTRM, DSTOR, FNINSR, FNINSRG, FRSTR,
     &    FRSTRM, NADSR, NGRSR, NGRSRG, NMOBSR, NRUSSR, NSRALL,
     &    NSRDOT, NSROFF, NVSTSR, PCNSR, PCSTRD, PROSRT, PSRSRFD,
     &    PSRLYRD, PSRSRFL, PSRLYR1, RHOSR, SRDAM, SRSRFD,
     &    SRLYRD, SSRDOT, SSRNDOT, NINT (STRWT*10), TPSRSRFL,
     &    TPSRLYR1, WCRSR, WNRSR, WRCSRDT, WSRDOT, WSRDOTN,
     &    WSRFDOT, WSRI, WSRIDOT, WTNSR, NINT(WTNSRA*10),
     &    WTNSRO, NINT(WTSRO*10.), XSTR

710    FORMAT(1X,I4,1X,I3.3,2(1X,I5),2(1X,F5.2),1X,F5.4,3(1X,F5.2),
     &    1X,I5,2(1X,F5.2),4(1X,F5.3),9(1X,F5.2),7(1X,F5.2),1X,
     &    F5.3,5(1X,F5.2),1X,I5,2(1X,F5.3),1X,F5.1,5(1X,F5.2),
     &    1X,F5.0,2(1X,F5.2),1X,I5,1X,F5.2,1X,I6,1X,F5.2)
        END IF    ! VSH

        IF (FMOPT == 'C') THEN   ! VSH
          Call CsvOutPlNPrFrm(EXPNAME, RUN, CONTROL%TRTNUM,
     & CONTROL%ROTNUM, CONTROL%REPNO, YEAR, DOY, DAS, DAP, WTNCAN,
     & WTNSD, WTNVEG, PCNSD, PCNVEG, WTNFX, WTNUP, WTNLF, WTNST, WTNSR,
     & PCNL, PCNST, PCNSR, PCNSH, PCNRT, NFIXN,
     & vCsvlinePlNPrFrm, vpCsvlinePlNPrFrm, vlngthPlNPrFrm)

          CALL LinklstPlNPrFrm(vCsvlinePlNPrFrm)

          CALL CsvOutPlCPrFrm(EXPNAME, CONTROL%RUN, CONTROL%TRTNUM,
     &CONTROL%ROTNUM, CONTROL%REPNO, YEAR, DOY, DAS, DAP,
     &TOTWT, PG, CMINEA, GROWTH, GRWRES, MAINR, CADLF,
     &CADST, CADSR, RHOL, RHOS, RHOSR, RHOR, TGRO, TGROAV, PCNSD,
     &PCLSD, PCCSD, TS,
     &vCsvlinePlCPrFrm, vpCsvlinePlCPrFrm, vlngthPlCPrFrm)

         CALL LinklstPlCPrFrm(vCsvlinePlCPrFrm)

         CALL CsvOutDormPrFrm(EXPNAME, CONTROL%RUN, CONTROL%TRTNUM,
     &CONTROL%ROTNUM, CONTROL%REPNO, YEAR, DOY, DAS, DAP,
     &DRMST, PPGFAC, PPMFAC, PPTFAC, SRFTEMP, ST, FREEZ2, FRLF, FRSTM,
     &FRSTR, FRRT, TS,
     &vCsvlineDormPrFrm, vpCsvlineDormPrFrm, vlngthDormPrFrm)

         CALL LinklstDormPrFrm(vCsvlineDormPrFrm)

         CALL CsvOutStorPrFrm(EXPNAME, CONTROL%RUN, CONTROL%TRTNUM,
     &CONTROL%ROTNUM, CONTROL%REPNO, YEAR, DOY, DAS, DAP, AGRSTR,
     &CADSR, CMOBSR, CPFSTR, CRUSSR, CSRFRZ, CSRW, CSTRM, DSTOR, FNINSR,
     &FNINSRG, FRSTR, FRSTRM, NADSR, NGRSR, NGRSRG, NMOBSR, NRUSSR,
     &NSRALL, NSRDOT, NSROFF, NVSTSR, PCNSR, PCSTRD, PROSRT, PSRSRFD,
     &PSRLYRD, PSRSRFL, PSRLYR1, RHOSR, SRDAM, SRSRFD, SRLYRD, SSRDOT,
     &SSRNDOT, STRWT, TPSRSRFL, TPSRLYR1, WCRSR, WNRSR, WRCSRDT, WSRDOT,
     &WSRDOTN, WSRFDOT, WSRI, WSRIDOT, WTNSR, WTNSRA,WTNSRO, WTSRO,XSTR,
     &vCsvlineStorPrFrm, vpCsvlineStorPrFrm, vlngthStorPrFrm)

         CALL LinklstStorPrFrm(vCsvlineStorPrFrm)
        END IF ! VSH

        ENDIF
      ENDIF

!***********************************************************************
!***********************************************************************
!     Seasonal Output
!***********************************************************************
      ELSE IF (DYNAMIC .EQ. SEASEND) THEN
C-----------------------------------------------------------------------

!       Write Storage inputs output file

!          WRITE (NOUTINSTR,810) PROSRF, PROSRG, PROSRI, PCARSR, PLIGSR,
!     &  PLIPSR, POASR, PMINSR, ALPHSR, CMOBSRX, CADSRF, NMOBSRX, CLAIT,
!     &  YSTOR(1), YSTOR(2), YSTOR(3), YSTOR(4), YSTOR(5), YSTOR(6),
!     &  YSTOR(7), YSTOR(8), FRSTRF, FRSTRMX, STRSRFL, STRLYR1, SENSR,
!     &  FNPTD(1), FNPTD(2), FNPTD(3),FNPTD(4), TYPPTD, FNPMD(1),
!     &  FNPMD(2), FNPMD(3), FNPMD(4), TYPPMD, FNPGD(1), FNPGD(2),
!     &  FNPGD(3), FNPGD(4), TYPPGD, HARD1, HARD2, FRZDC, FRZHRD(1),
!     &  FRZHRD(2), FRZHRD(3), FRZHRD(4), TYPHRD, FRZDHD(1), FRZDHD(2),
!     &  FRZDHD(3), FRZDHD(4), TYPDHD, RDRMG, RDRMM, RDRMT, RCHDP

!  810     FORMAT(8(1X,F5.3),15(1X,F5.2),3(1X,F5.3),4(1X,F5.1),3X,A3,
!     &              4(1X,F5.1),3X,A3,4(1X,F5.1),3X,A3,2(1X,F5.1),1X,F5.3,
!     &              4(1X,F5.1),3X,A3,4(1X,F5.1),3X,A3,4(1X,F5.3))

!            WRITE(NOUTINSTR,'("*DUMMY LINE FOR DEBUGGING")')

        !Close daily output files.
        IF (FMOPT == 'A' .OR. FMOPT == ' ') THEN   ! VSH
        CLOSE (NOUTDG)
        CLOSE (NOUTPN)
        CLOSE (NOUTPC)
        CLOSE (NOUTDRM)
        CLOSE (NOUTSTOR)
!        CLOSE (NOUTINSTR)
        END IF   ! VSH
!***********************************************************************
!***********************************************************************
!     END OF DYNAMIC IF CONSTRUCT
!***********************************************************************
      ENDIF
!***********************************************************************
      RETURN
      END ! SUBROUTINE FOR_OPGROW
!=======================================================================

!=======================================================================
!       Variable definitions for FOR_OPGROW
!-----------------------------------------------------------------------
! CANHT   Canopy height (m)
! CANWH   Canopy width normal to row (m)
! CROPD   Name of crop
! DAP     Number of days after planting (d)
! DWNOD   Current nodule mass (g[nodule] / m2)
! DYNAMIC Module control variable; =RUNINIT, SEASINIT, RATE, EMERG, INTEGR,
!           OUTPUT, or SEASEND
! ENAME   Experiment description
! EXPER   Experiment code (prefix of input files)
! HI      Ratio of seed weight (SDWT) to weight of above-ground portion of
!           plant (TOPWT) (g[seed] / g[tops])
! HIP     Ratio of pod weight (PODWT) to weight of above-ground portion of
!           plant (TOPWT) (g[pods] / g[tops])
! MODEL   Name of CROPGRO executable file
! MULTI   Current seasonal simulation (=1 for first or only simulation,
!           =NYRS for last simulation
! NL      maximum number of soil layers = 20
! NOUTDG  Unit number for growth output file
! NSTRES  Nitrogen stress factor (1=no stress, 0=max stress)
! OUTG    Growth output file name (typically 'GROWTH.OUT')
! PCNL    Percentage of N in leaf tissue (100 g[N] / g[leaf])
! PODNO   Total number of pods (#/m2)
! PODWT   Dry mass of seeds plus shells, including C and N
!           (g[pods] / m2[ground])
! PODWTD  Mass of detached pods (g[pods] / m2[ground])
! RLV(L)  Root length density for soil layer L ((cm root / cm3 soil))
! RSTAGE  Number of RSTAGES which have occurred.
! RTDEP   Root depth (cm)
! RTWT    Dry mass of root tissue, including C and N (g[root] / m2[ground])
! SDSIZE  Average mass of seeds (mg / seed)
! SDWT    Dry mass of seed tissue, including C and N (g[seed] / m2[ground])
! SEEDNO  Total number of seeds (#/m2)
! SHELLW  Shell mass (g[shell] / m2)
! SHELPC  Percentage of pod mass that is seeds (g[seed]/g[pods] * 100%)
! SLA     Specific leaf area (cm2[leaf] / m2[ground])
! STMWT   Dry mass of stem tissue, including C and N (g[stem] / m2[ground)
! SWFAC   Effect of soil-water stress on photosynthesis, 1.0=no stress,
!           0.0=max stress
! TITLET  Description of treatment for this simulation
! TOPWT   Total weight of above-ground portion of crop, including pods
!           (g[tissue] / m2)
! TURFAC  Water stress factor for expansion (0 - 1)
! VSTAGE  Number of nodes on main stem of plant
! WTCO    Cumulative losses of plant tissue (g[tissue] / m2)
! WTLF    Dry mass of leaf tissue including C and N (g[leaf] / m2[ground])
! WTLO    Cumulative leaf losses (g[leaf] / m2)
! WTSO    Cumulative stem losses (g[stem] / m2)
! XLAI    Leaf area (one side) per unit of ground area
!           (m2[leaf] / m2[ground])
! YRDOY   Current day of simulation (YYDDD)
! YRPLT   Planting date (YYDDD)
!***********************************************************************
!       END SUBROUTINE FOR_OPGROW
!=======================================================================


module emissMod
 integer *4                n_lat
 parameter(n_lat = 720)
 integer *4                n_lon
 parameter(n_lon = 1440)
 integer *4                n_chan
 parameter(n_chan = 6) !SJM 9/9/2015
 real  :: gmiobslow(7)
 real  :: gmiobshigh(2)
 real *4                   emissv_map(n_lon, n_lat, n_chan)
 real *4                   emissh_map(n_lon, n_lat, n_chan)
 real *4                   emissv_std_map(n_lon, n_lat, n_chan)
 real *4                   emissh_std_map(n_lon, n_lat, n_chan)
 real eLat, eLon
 real ::  kexttotEns(7,40,100), salbtotEns(7,40,100), asymtotEns(7,40,100)
end module emissMod

subroutine reademiss(imonth)
  use emissMod
  implicit none

  integer imonth
  select case(imonth)
  case(1)
     open(20,file='Emiss/emiss1.bin',form='unformatted')
  case(2)
     open(20,file='Emiss/emiss2.bin',form='unformatted')
  case(3)
     open(20,file='Emiss/emiss3.bin',form='unformatted')
  case(4)
     open(20,file='Emiss/emiss4.bin',form='unformatted')
  case(5)
     open(20,file='Emiss/emiss5.bin',form='unformatted')
  case(6)
     open(20,file='Emiss/emiss6.bin',form='unformatted')
  case(7)
     open(20,file='Emiss/emiss7.bin',form='unformatted')
  case(8)
     open(20,file='Emiss/emiss8.bin',form='unformatted')
  case(9)
     open(20,file='Emiss/emiss9.bin',form='unformatted')
  case(10)
     open(20,file='Emiss/emiss10.bin',form='unformatted')
  case(11)
     open(20,file='Emiss/emiss11.bin',form='unformatted')
  case(12)
     open(20,file='Emiss/emiss12.bin',form='unformatted')
  end select

  read(20) emissv_map(:,:,1:5)
  read(20) emissh_map(:,:,1:5)
  read(20) emissv_std_map(:,:,1:5)
  read(20) emissh_std_map(:,:,1:5)
  close(20)
  emissv_std_map(:,:,6) = emissv_std_map(:,:,5)
  emissh_std_map(:,:,6) = emissh_std_map(:,:,5)
end subroutine reademiss

subroutine getemiss(lat,lon,snowicecover,emissv,emissh,emissv_std,emissh_std)
  use emissMod
  use LUT_def
  implicit none
  real                    lat, lon
  integer                 snowicecover
  real                    emissv(n_chan)
  real                    emissh(n_chan)
  real                    emissv_std(n_chan)
  real                    emissh_std(n_chan)
  integer :: ii, jj, stype, i

!get surface type from map
  !print*, lat, lon
  ii=2880-floor((lat+90.)/180.*2880.)
  if(ii .lt. 1) ii=1
  if(ii .gt. 2880) ii = 2880
  jj=floor((lon+180.)/360.*5760.)+1
  if(jj .lt. 1) jj = 1
  if(jj .gt. 5760) jj = 5760
  !print*, ii,jj
  !stype = LUT%land_class_map_bare(jj,ii)
  if(snowicecover .eq. 2 .or. snowicecover .eq. 3) then
    stype = LUT%land_class_map_snow(jj,ii) !SJM 9/9/15
  else
    stype = LUT%land_class_map_snow(jj,ii) !SJM 9/9/15
  endif
  !print*, lat, lon, stype
!begin  WSO 11/7/13 added tests for indices out of bounds
!modified by SJM for use with GMI-derived maps
  ii=min(int((lat+70.)/0.25) + 1, 560)
  jj=min(int((lon+180.)/.25)+1, 1440)

!end  WSO  11/7/13
   if(stype .eq. 1) then
     emissv=-99.
     emissv_std = 0.
     emissh = -99.
     emissh_std=0.
     return
   endif
   !if(stype .eq. 2 .or. (stype .ge. 8 .and. stype .le. 11) .or. stype .eq. 14) then !sea ice or snow cover
   if(snowicecover .eq. 2 .or. snowicecover .eq. 3) then
    emissv(1) = LUT%emis_map_snow(jj,ii,1)
    emissv(2) = LUT%emis_map_snow(jj,ii,3)
    emissv(4) = LUT%emis_map_snow(jj,ii,5)
    emissv(5) = LUT%emis_map_snow(jj,ii,7)
    emissv(6) = LUT%emis_map_snow(jj,ii,9)
    emissh(1) = LUT%emis_map_snow(jj,ii,2)
    emissh(2) = LUT%emis_map_snow(jj,ii,4)
    emissh(4) = LUT%emis_map_snow(jj,ii,6)
    emissh(5) = LUT%emis_map_snow(jj,ii,8)
    emissh(6) = LUT%emis_map_snow(jj,ii,10)
!begin  SJM 2/14/17 read emissivity std deviations
    emissv_std(1) = LUT%estd_map_snow(jj,ii,1)
    emissv_std(2) = LUT%estd_map_snow(jj,ii,3)
    emissv_std(4) = LUT%estd_map_snow(jj,ii,5)
    emissv_std(5) = LUT%estd_map_snow(jj,ii,7)
    emissv_std(6) = LUT%estd_map_snow(jj,ii,9)
    emissh_std(1) = LUT%estd_map_snow(jj,ii,2)
    emissh_std(2) = LUT%estd_map_snow(jj,ii,4)
    emissh_std(4) = LUT%estd_map_snow(jj,ii,6)
    emissh_std(5) = LUT%estd_map_snow(jj,ii,8)
    emissh_std(6) = LUT%estd_map_snow(jj,ii,10)
!end  SJM 2/14/17
  else if(snowicecover .eq. 0 .or. snowicecover .eq. 1) then
    emissv(1) = LUT%emis_map_bare(jj,ii,1)
    emissv(2) = LUT%emis_map_bare(jj,ii,3)
    emissv(4) = LUT%emis_map_bare(jj,ii,5)
    emissv(5) = LUT%emis_map_bare(jj,ii,7)
    emissv(6) = LUT%emis_map_bare(jj,ii,9)
    emissh(1) = LUT%emis_map_bare(jj,ii,2)
    emissh(2) = LUT%emis_map_bare(jj,ii,4)
    emissh(4) = LUT%emis_map_bare(jj,ii,6)
    emissh(5) = LUT%emis_map_bare(jj,ii,8)
    emissh(6) = LUT%emis_map_bare(jj,ii,10)
!begin  SJM 2/14/17 read emissivity std deviations
    emissv_std(1) = LUT%estd_map_bare(jj,ii,1)
    emissv_std(2) = LUT%estd_map_bare(jj,ii,3)
    emissv_std(4) = LUT%estd_map_bare(jj,ii,5)
    emissv_std(5) = LUT%estd_map_bare(jj,ii,7)
    emissv_std(6) = LUT%estd_map_bare(jj,ii,9)
    emissh_std(1) = LUT%estd_map_bare(jj,ii,2)
    emissh_std(2) = LUT%estd_map_bare(jj,ii,4)
    emissh_std(4) = LUT%estd_map_bare(jj,ii,6)
    emissh_std(5) = LUT%estd_map_bare(jj,ii,8)
    emissh_std(6) = LUT%estd_map_bare(jj,ii,10)
!end  SJM 2/14/17
  else
    emissv(1) = LUT%emis_map_all(jj,ii,1)
    emissv(2) = LUT%emis_map_all(jj,ii,3)
    emissv(4) = LUT%emis_map_all(jj,ii,5)
    emissv(5) = LUT%emis_map_all(jj,ii,7)
    emissv(6) = LUT%emis_map_all(jj,ii,9)
    emissh(1) = LUT%emis_map_all(jj,ii,2)
    emissh(2) = LUT%emis_map_all(jj,ii,4)
    emissh(4) = LUT%emis_map_all(jj,ii,6)
    emissh(5) = LUT%emis_map_all(jj,ii,8)
    emissh(6) = LUT%emis_map_all(jj,ii,10)
!begin  SJM 2/14/17 read emissivity std deviations
    emissv_std(1) = LUT%estd_map_all(jj,ii,1)
    emissv_std(2) = LUT%estd_map_all(jj,ii,3)
    emissv_std(4) = LUT%estd_map_all(jj,ii,5)
    emissv_std(5) = LUT%estd_map_all(jj,ii,7)
    emissv_std(6) = LUT%estd_map_all(jj,ii,9)
    emissh_std(1) = LUT%estd_map_all(jj,ii,2)
    emissh_std(2) = LUT%estd_map_all(jj,ii,4)
    emissh_std(4) = LUT%estd_map_all(jj,ii,6)
    emissh_std(5) = LUT%estd_map_all(jj,ii,8)
    emissh_std(6) = LUT%estd_map_all(jj,ii,10)
!end  SJM 2/14/17
  endif

  if(emissv(1) .le. 0.) emissv(1) = LUT%land_class_emis_mean(stype-1,1)
  if(emissv(2) .le. 0.) emissv(2) = LUT%land_class_emis_mean(stype-1,3)
  if(emissv(4) .le. 0.) emissv(4) = LUT%land_class_emis_mean(stype-1,5)
  if(emissv(5) .le. 0.) emissv(5) = LUT%land_class_emis_mean(stype-1,7)
  if(emissv(6) .le. 0.) emissv(6) = LUT%land_class_emis_mean(stype-1,9)
  emissv(3) = 0.64*emissv(2)+0.36*emissv(4)
  if(emissh(1) .le. 0.) emissh(1) = LUT%land_class_emis_mean(stype-1,2)
  if(emissh(2) .le. 0.) emissh(2) = LUT%land_class_emis_mean(stype-1,4)
  if(emissh(4) .le. 0.) emissh(4) = LUT%land_class_emis_mean(stype-1,6)
  if(emissh(5) .le. 0.) emissh(5) = LUT%land_class_emis_mean(stype-1,8)
  if(emissh(6) .le. 0.) emissh(6) = LUT%land_class_emis_mean(stype-1,10)
  emissh(3) = 0.64*emissh(2)+0.36*emissh(4)

  !emissv_std=emissv_std_map(jj,ii,:)
  !emissh_std=emissh_std_map(jj,ii,:)
  !if(minval(emissv)<0) then
   ! print*, lat, lon
   ! print*, ii, jj
   ! print*, emissv
   ! stop
  !endif
end subroutine getemiss
! subroutine getemiss(lat,lon,emissv,emissh,emissv_std,emissh_std)
!   use emissMod
!   implicit none
!   real                    lat, lon
!   real                    emissv(n_chan)
!   real                    emissh(n_chan)
!   real                    emissv_std(n_chan)
!   real                    emissh_std(n_chan)
!   integer :: ii, jj
!
! !begin  WSO 11/7/13 added tests for indices out of bounds
!   ii=min(int((lat+90.)/0.25) + 1, 720)
!   if(lon<0) then
!      jj=min(int((lon+360)/.25)+1, 1440)
!   else
!      if(lon>=360) then
!         jj=min(int((lon-360)/.25) + 1, 1440)
!      else
!         jj=min(int(lon/.25) + 1, 1440)
!      endif
!   endif
! !end  WSO  11/7/13
!
!   emissv=emissv_map(jj,ii,:)
!   emissh=emissh_map(jj,ii,:)
!   emissv_std=emissv_std_map(jj,ii,:)
!   emissh_std=emissh_std_map(jj,ii,:)
!   if(minval(emissv)<0) then
!    ! print*, lat, lon
!    ! print*, ii, jj
!    ! print*, emissv
!    ! stop
!   endif
! end subroutine getemiss


!----------------------------------------------------------------------------
!BOP
!
! !MODULE:  GSI_NSTCouplerMod ---
!
! !DESCRIPTION: This stub provides the default interfaces to the
!               NST analysis calculations in GSI.
!
! !REVISION HISTORY:
!
!  07Oct2011 Akella/RT - Initial code
!  05Mar2012 Akella    - Create_nst and getnst from satthin are now nst_int_ & nst_set_
!                        Destroy_nst from satthin is nst_final_
!  2017--9-27 Li       - change nst_set to be nst_read and fix a bug in cal_tztr_
!
!EOP
!-------------------------------------------------------------------------

subroutine nst_init_()

     use mpimod,      only: mype
     use gridmod,     only: nlat_sfc,nlon_sfc, nlat, nlon
     use guess_grids, only: nfldnst, ntguesnst
     use gsi_nstcouplermod,     only: tref_full,dt_cool_full,z_c_full,dt_warm_full,z_w_full,&
                                      c_0_full,c_d_full,w_0_full,w_d_full
     use mpeu_util,   only: die, perr

     implicit none

     if(.not.allocated(tref_full))    allocate(tref_full    (nlat_sfc,nlon_sfc,nfldnst))
     if(.not.allocated(dt_cool_full)) allocate(dt_cool_full (nlat_sfc,nlon_sfc,nfldnst))
     if(.not.allocated(z_c_full))     allocate(z_c_full     (nlat_sfc,nlon_sfc,nfldnst))
     if(.not.allocated(dt_warm_full)) allocate(dt_warm_full (nlat_sfc,nlon_sfc,nfldnst))
     if(.not.allocated(z_w_full))     allocate(z_w_full     (nlat_sfc,nlon_sfc,nfldnst))
     if(.not.allocated(c_0_full))     allocate(c_0_full     (nlat_sfc,nlon_sfc,nfldnst))
     if(.not.allocated(c_d_full))     allocate(c_d_full     (nlat_sfc,nlon_sfc,nfldnst))
     if(.not.allocated(w_0_full))     allocate(w_0_full     (nlat_sfc,nlon_sfc,nfldnst))
     if(.not.allocated(w_d_full))     allocate(w_d_full     (nlat_sfc,nlon_sfc,nfldnst))

     if( ntguesnst < 1 .or. ntguesnst > nfldnst ) then
            call perr('nst_init','ntguesnst = ',ntguesnst)
            call  die('nst_init')
     endif

     if(mype == 0)write(6,*)'GETNST: enter with nlat_sfc,nlon_sfc=',nlat_sfc,nlon_sfc,&
                            ' and nlat,nlon=',nlat,nlon

end subroutine nst_init_
!*******************************************************************************************

subroutine nst_read_(mype_io)

     use kinds, only: i_kind
     use gridmod, only: use_gfs_nemsio
     use ncepgfs_io, only: read_gfsnst
     use ncepnems_io, only: read_nemsnst
     use gsi_nstcouplermod, only: tref_full,dt_cool_full,z_c_full,dt_warm_full,z_w_full,&
                                  c_0_full,c_d_full,w_0_full,w_d_full
     implicit none
     integer(i_kind),  intent(in   ) :: mype_io

     if ( use_gfs_nemsio ) then
        call read_nemsnst(mype_io,tref_full,dt_cool_full,z_c_full, &
                          dt_warm_full,z_w_full,c_0_full,c_d_full,w_0_full,w_d_full)
     else
        call read_gfsnst(mype_io,tref_full,dt_cool_full,z_c_full, &
                         dt_warm_full,z_w_full,c_0_full,c_d_full,w_0_full,w_d_full)
     endif

end subroutine nst_read_
!*******************************************************************************************

subroutine nst_final_ ()

     use gsi_nstcouplermod, only: tref_full,dt_cool_full,z_c_full,dt_warm_full,z_w_full,&
                                  c_0_full,c_d_full,w_0_full,w_d_full

     if(allocated(tref_full))    deallocate(tref_full)
     if(allocated(dt_cool_full)) deallocate(dt_cool_full)
     if(allocated(z_c_full))     deallocate(z_c_full)
     if(allocated(dt_warm_full)) deallocate(dt_warm_full)
     if(allocated(z_w_full))     deallocate(z_w_full)
     if(allocated(c_0_full))     deallocate(c_0_full)
     if(allocated(c_d_full))     deallocate(c_d_full)
     if(allocated(w_0_full))     deallocate(w_0_full)
     if(allocated(w_d_full))     deallocate(w_d_full)

end subroutine nst_final_
!*******************************************************************************************

subroutine deter_nst_(dlat_earth,dlon_earth,obstime,zob,tref,dtw,dtc,tz_tr)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    deter_nst                     determine NSST variable at observation location over water
!   prgmmr: Xu Li           org: np2                date: 2011-04-08
!
! abstract:  determines NSST variables over water surface type based on surrounding surface types
!
! program history log:
!   2011-04-08 Li
!   2013-01-23 parrish - change from grdcrd to grdcrd1 (to allow successful
!
!   input argument list:
!     obstime                             - observation time relative to analysis time
!     dlat_earth                          - earth latitude  in radians
!     dlon_earth                          - earth longitude in radians
!     zob                                 - obs. depth in the water
!
!   output argument list:
!     tref                                - oceanic foundation temperature
!      dtw                                - diurnal warming at depth zob
!      dtc                                - sublayer cooling at depth zob
!    tz_tr                                - d(Tz)/d(tr)
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
     use kinds,       only: r_kind,i_kind
     use constants,   only: zero,one,z_w_max
     use gridmod,     only: regional,tll2xy,nlat_sfc,nlon_sfc,rlats_sfc,rlons_sfc
     use guess_grids, only: nfldnst,hrdifnst
     use gsi_nstcouplermod, only: fac_dtl,fac_tsl
     use gsi_nstcouplermod, only: tref_full,dt_cool_full,z_c_full,dt_warm_full,z_w_full,&
                                  c_0_full,c_d_full,w_0_full,w_d_full
     use satthin, only: isli_full
     implicit none

     real(r_kind), intent(in ) :: dlat_earth,dlon_earth,obstime,zob
     real(r_kind), intent(out) :: tref,dtw,dtc,tz_tr

!    local variables
     real(r_kind):: dt_cool,z_c,dt_warm,z_w,c_0,c_d,w_0,w_d
     integer(i_kind) istyp00,istyp01,istyp10,istyp11
     integer(i_kind):: itnst,itnstp
     integer(i_kind):: ix,iy,ixp,iyp,j
     real(r_kind):: dx,dy,dx1,dy1,w00,w10,w01,w11,dtnst,dtnstp
     real(r_kind):: tref_00,tref_01,tref_10,tref_11,tr_tmp
     real(r_kind):: dt_cool_00,dt_cool_01,dt_cool_10,dt_cool_11
     real(r_kind):: z_c_00,z_c_01,z_c_10,z_c_11
     real(r_kind):: dt_warm_00,dt_warm_01,dt_warm_10,dt_warm_11
     real(r_kind):: z_w_00,z_w_01,z_w_10,z_w_11,z_w_tmp
     real(r_kind):: c_0_00,c_0_01,c_0_10,c_0_11
     real(r_kind):: c_d_00,c_d_01,c_d_10,c_d_11
     real(r_kind):: w_0_00,w_0_01,w_0_10,w_0_11
     real(r_kind):: w_d_00,w_d_01,w_d_10,w_d_11
     real(r_kind):: wgtavg,dlat,dlon
     logical outside

     if(regional)then
        call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside)
     else
        dlat=dlat_earth
        dlon=dlon_earth
        call grdcrd1(dlat,rlats_sfc,nlat_sfc,1)
        call grdcrd1(dlon,rlons_sfc,nlon_sfc,1)
     end if

     iy=int(dlon); ix=int(dlat)
     dy  =dlon-iy; dx  =dlat-ix
     dx1 =one-dx;    dy1 =one-dy
     w00=dx1*dy1; w10=dx*dy1; w01=dx1*dy; w11=one-w00-w10-w01

     ix=min(max(1,ix),nlat_sfc); iy=min(max(0,iy),nlon_sfc)
     ixp=min(nlat_sfc,ix+1); iyp=iy+1
     if(iy==0) iy=nlon_sfc
     if(iyp==nlon_sfc+1) iyp=1

!    Get time interpolation factors for nst files
     if(obstime > hrdifnst(1) .and. obstime <= hrdifnst(nfldnst))then
        do j=1,nfldnst-1
           if(obstime > hrdifnst(j) .and. obstime <= hrdifnst(j+1))then
              itnst=j
              itnstp=j+1
              dtnst=(hrdifnst(j+1)-obstime)/(hrdifnst(j+1)-hrdifnst(j))
           end if
        end do
     else if(obstime <=hrdifnst(1))then
        itnst=1
        itnstp=1
        dtnst=one
     else
        itnst=nfldnst
        itnstp=nfldnst
        dtnst=one
     end if
     dtnstp=one-dtnst

!    Set surface type flag.

     istyp00 = isli_full(ix ,iy )
     istyp10 = isli_full(ixp,iy )
     istyp01 = isli_full(ix ,iyp)
     istyp11 = isli_full(ixp,iyp)
!
!    Use the time interpolation factors for nst files
!
     tref_00    = tref_full   (ix ,iy ,itnst)*dtnst + tref_full   (ix ,iy ,itnstp)*dtnstp
     tref_01    = tref_full   (ix ,iyp,itnst)*dtnst + tref_full   (ix ,iyp,itnstp)*dtnstp
     tref_10    = tref_full   (ixp,iy ,itnst)*dtnst + tref_full   (ixp,iy ,itnstp)*dtnstp
     tref_11    = tref_full   (ixp,iyp,itnst)*dtnst + tref_full   (ixp,iyp,itnstp)*dtnstp

     dt_cool_00 = dt_cool_full(ix ,iy ,itnst)*dtnst + dt_cool_full(ix ,iy ,itnstp)*dtnstp
     dt_cool_01 = dt_cool_full(ix ,iyp,itnst)*dtnst + dt_cool_full(ix ,iyp,itnstp)*dtnstp
     dt_cool_10 = dt_cool_full(ixp,iy ,itnst)*dtnst + dt_cool_full(ixp,iy ,itnstp)*dtnstp
     dt_cool_11 = dt_cool_full(ixp,iyp,itnst)*dtnst + dt_cool_full(ixp,iyp,itnstp)*dtnstp

     z_c_00     = z_c_full    (ix ,iy ,itnst)*dtnst + z_c_full    (ix ,iy ,itnstp)*dtnstp
     z_c_01     = z_c_full    (ix ,iyp,itnst)*dtnst + z_c_full    (ix ,iyp,itnstp)*dtnstp
     z_c_10     = z_c_full    (ixp,iy ,itnst)*dtnst + z_c_full    (ixp,iy ,itnstp)*dtnstp
     z_c_11     = z_c_full    (ixp,iyp,itnst)*dtnst + z_c_full    (ixp,iyp,itnstp)*dtnstp

     dt_warm_00 = dt_warm_full(ix ,iy ,itnst)*dtnst + dt_warm_full(ix ,iy ,itnstp)*dtnstp
     dt_warm_01 = dt_warm_full(ix ,iyp,itnst)*dtnst + dt_warm_full(ix ,iyp,itnstp)*dtnstp
     dt_warm_10 = dt_warm_full(ixp,iy ,itnst)*dtnst + dt_warm_full(ixp,iy ,itnstp)*dtnstp
     dt_warm_11 = dt_warm_full(ixp,iyp,itnst)*dtnst + dt_warm_full(ixp,iyp,itnstp)*dtnstp

     z_w_00     = z_w_full    (ix ,iy ,itnst)*dtnst + z_w_full    (ix ,iy ,itnstp)*dtnstp
     z_w_01     = z_w_full    (ix ,iyp,itnst)*dtnst + z_w_full    (ix ,iyp,itnstp)*dtnstp
     z_w_10     = z_w_full    (ixp,iy ,itnst)*dtnst + z_w_full    (ixp,iy ,itnstp)*dtnstp
     z_w_11     = z_w_full    (ixp,iyp,itnst)*dtnst + z_w_full    (ixp,iyp,itnstp)*dtnstp

     c_0_00     = c_0_full    (ix ,iy ,itnst)*dtnst + c_0_full    (ix ,iy ,itnstp)*dtnstp
     c_0_01     = c_0_full    (ix ,iyp,itnst)*dtnst + c_0_full    (ix ,iyp,itnstp)*dtnstp
     c_0_10     = c_0_full    (ixp,iy ,itnst)*dtnst + c_0_full    (ixp,iy ,itnstp)*dtnstp
     c_0_11     = c_0_full    (ixp,iyp,itnst)*dtnst + c_0_full    (ixp,iyp,itnstp)*dtnstp

     c_d_00     = c_d_full    (ix ,iy ,itnst)*dtnst + c_d_full    (ix ,iy ,itnstp)*dtnstp
     c_d_01     = c_d_full    (ix ,iyp,itnst)*dtnst + c_d_full    (ix ,iyp,itnstp)*dtnstp
     c_d_10     = c_d_full    (ixp,iy ,itnst)*dtnst + c_d_full    (ixp,iy ,itnstp)*dtnstp
     c_d_11     = c_d_full    (ixp,iyp,itnst)*dtnst + c_d_full    (ixp,iyp,itnstp)*dtnstp

     w_0_00     = w_0_full    (ix ,iy ,itnst)*dtnst + w_0_full    (ix ,iy ,itnstp)*dtnstp
     w_0_01     = w_0_full    (ix ,iyp,itnst)*dtnst + w_0_full    (ix ,iyp,itnstp)*dtnstp
     w_0_10     = w_0_full    (ixp,iy ,itnst)*dtnst + w_0_full    (ixp,iy ,itnstp)*dtnstp
     w_0_11     = w_0_full    (ixp,iyp,itnst)*dtnst + w_0_full    (ixp,iyp,itnstp)*dtnstp

     w_d_00     = w_d_full    (ix ,iy ,itnst)*dtnst + w_d_full    (ix ,iy ,itnstp)*dtnstp
     w_d_01     = w_d_full    (ix ,iyp,itnst)*dtnst + w_d_full    (ix ,iyp,itnstp)*dtnstp
     w_d_10     = w_d_full    (ixp,iy ,itnst)*dtnst + w_d_full    (ixp,iy ,itnstp)*dtnstp
     w_d_11     = w_d_full    (ixp,iyp,itnst)*dtnst + w_d_full    (ixp,iyp,itnstp)*dtnstp

!    Interpolate nst variables to obs location (water surface only)

     wgtavg  = zero
     tr_tmp  = zero
     dt_cool = zero
     z_c     = zero
     dt_warm = zero
     z_w_tmp = zero
     c_0     = zero
     c_d     = zero
     w_0     = zero
     w_d     = zero

     if (istyp00 == 0)then
        wgtavg  = wgtavg  + w00
        tr_tmp  = tr_tmp  + w00*tref_00
        dt_cool = dt_cool + w00*dt_cool_00
        z_c     = z_c     + w00*z_c_00
        dt_warm = dt_warm + w00*dt_warm_00
        z_w_tmp = z_w_tmp + w00*z_w_00
        c_0     = c_0     + w00*c_0_00
        c_d     = c_d     + w00*c_d_00
        w_0     = w_0     + w00*w_0_00
        w_d     = w_d     + w00*w_d_00
     endif
     if(istyp01 == 0)then
        wgtavg  = wgtavg  + w01
        tr_tmp  = tr_tmp  + w01*tref_01
        dt_cool = dt_cool + w01*dt_cool_01
        z_c     = z_c     + w01*z_c_01
        dt_warm = dt_warm + w01*dt_warm_01
        z_w_tmp = z_w_tmp + w01*z_w_01
        c_0     = c_0     + w01*c_0_01
        c_d     = c_d     + w01*c_d_01
        w_0     = w_0     + w01*w_0_01
        w_d     = w_d     + w01*w_d_01
     end if
     if(istyp10 == 0)then
        wgtavg  = wgtavg  + w10
        tr_tmp  = tr_tmp  + w10*tref_10
        dt_cool = dt_cool + w10*dt_cool_10
        z_c     = z_c     + w10*z_c_10
        dt_warm = dt_warm + w10*dt_warm_10
        z_w_tmp = z_w_tmp + w10*z_w_10
        c_0     = c_0     + w10*c_0_10
        c_d     = c_d     + w10*c_d_10
        w_0     = w_0     + w10*w_0_10
        w_d     = w_d     + w10*w_d_10
     end if
     if(istyp11 == 0)then
        wgtavg  = wgtavg  + w11
        tr_tmp  = tr_tmp  + w11*tref_11
        dt_cool = dt_cool + w11*dt_cool_11
        z_c     = z_c     + w11*z_c_11
        dt_warm = dt_warm + w11*dt_warm_11
        z_w_tmp = z_w_tmp + w11*z_w_11
        c_0     = c_0     + w11*c_0_11
        c_d     = c_d     + w11*c_d_11
        w_0     = w_0     + w11*w_0_11
        w_d     = w_d     + w11*w_d_11
     end if

     if(wgtavg > zero)then
        tr_tmp  = tr_tmp/wgtavg
        tref    = tr_tmp

        z_w_tmp = z_w_tmp/wgtavg
        z_w     = z_w_tmp

        dt_cool = dt_cool/wgtavg
        z_c     = z_c/wgtavg
        dt_warm = dt_warm/wgtavg
        c_0     = c_0/wgtavg
        c_d     = c_d/wgtavg
        w_0     = w_0/wgtavg
        w_d     = w_d/wgtavg

        dtw = fac_dtl*dt_warm*(one-min(zob,z_w)/z_w)
        if ( z_c > zero ) then
          dtc = fac_tsl*dt_cool*(one-min(zob,z_c)/z_c)
        else
          dtc = zero
        endif

        call cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,z_c,z_w,zob,tz_tr)

     end if
end subroutine deter_nst_
!*******************************************************************************************

subroutine cal_tztr_(dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr)
!
! abstract: calculate d(Tz)/d(Ts) with T-Profile info from NSST Model
!
!   prgmmr: li, xu           org: np23                date: 2011-04-08
! input variables
!
! dt_warm :       diurnal warming amount at the surface
! xz      :       DTL depth                           (M)
! c_0     :       coefficint 1 to calculate d(Tc)/d(Ts)
! c_d     :       coefficint 2 to calculate d(Tc)/d(Ts)
! w_0     :       coefficint 1 to calculate d(Tw)/d(Ts)
! w_d     :       coefficint 2 to calculate d(Tw)/d(Ts)
!
! output variables
!
! tztr     :      d(Tz)/d(Tr)

  use kinds, only: r_kind
  use constants, only: one,two,half,zero
  use gsi_nstcouplermod, only: fac_dtl,fac_tsl
  real(kind=r_kind), intent(in)  :: dt_warm,c_0,c_d,w_0,w_d,zc,zw,z
  real(kind=r_kind), intent(out) :: tztr
! local variables
  real(kind=r_kind) :: c1,c2,c3

  c1 = one-two*(fac_dtl*w_0-fac_tsl*c_0)-(fac_dtl*w_d-fac_tsl*c_d)*z
  c2 = one-two*(fac_dtl*w_0-fac_tsl*c_0)-fac_dtl*w_d*z
  c3 = one+fac_tsl*two*c_0+fac_dtl*c_d*z

  tztr = one

  if ( dt_warm > zero ) then
    if ( z <= zc  .and. c1 /= zero ) then
      tztr = (one-fac_dtl*w_0+fac_tsl*c_0)/c1
    elseif ( z > zc .and. z < zw .and. c2 /= zero ) then
      tztr = (one-fac_dtl*w_0+fac_tsl*c_0)/c2
    endif
  elseif ( dt_warm == zero .and. c3 /= zero ) then
    if ( z <= zc ) then
      tztr = (one+fac_tsl*c_0)/c3
    endif
  endif

  if ( tztr <= -1.0_r_kind .or. tztr > 4.0_r_kind ) then
     write(6,100) fac_dtl,fac_tsl,c1,c2,c3,dt_warm,c_0,c_d,w_0,w_d,zc,zw,z,tztr
100  format('CAL_TZTR compute ',2(i2,1x),12(g13.6,1x),' RESET tztr to 1.0')
     tztr = one
  endif

end subroutine cal_tztr_
!*******************************************************************************************

!*******************************************************************************************
subroutine skindepth_(obstype,sd_rad)
!
! abstract: Get skin depth (instrument dependent). Ideally, a skin-depth model calculates the channel dependent sd
!
! program history log:
!   2011-04-08  li

 use kinds, only: r_kind
 implicit none
 character(10),     intent(in)  :: obstype
 real(kind=r_kind), intent(out) :: sd_rad

  sd_rad = 0.000015_r_kind
  if ( obstype == 'amsre' .or. obstype == 'amsr2' .or. obstype == 'gmi' ) then
      sd_rad = 0.03_r_kind
  elseif ( obstype == 'amsua' .or. obstype == 'amsub' .or.  obstype == 'ssmis' .or.  obstype == 'ssmi' .or. &
      obstype == 'mhs' .or.  obstype == 'msu' .or.  obstype == 'hsb' ) then
      sd_rad = 0.001_r_kind
  endif

end subroutine skindepth_
!*******************************************************************************************