C MEMBER FROST2
C REPLACEMENT OF OLD FROST1
C
      SUBROUTINE FROST2_1(PX,TA,WE,AESC,SH,FRZPAR,SACPAR,FRZST,SACST,
     +            SACST_PRV,SMC,SH2O,DTFRZ,IDT,NSOIL,NUPL,NSAC,IVERS,
c     +            FRZDUP,FRZDBT,FROST)
     +            FRZDUP,FRZDBT,FROST,SMAX, SMCDRY, HRAPX,HRAPY)

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CC    PURPOSE:  TO CALCULATE SOIL TEMPERATURE & ICE CONTENT
C     WRITTEN BY VICTOR KOREN - HRL   JANUARY 2000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C  DEFAULT CONSTANTS
      PARAMETER (T0 = 273.16)
      PARAMETER (FRST_FACT = 5.0)

C  VARIABLE IVERS CONTROLL FROZEN GROUND OPTION:
C  IVERS = 0 FULLY NON-FROZEN GROUND
C  IVERS = 1 FULLY FROZEN GROUND (NEW VERSION)
C  IVERS = 4 WILL RUN SOIL TEMPERATURE BUT NOT FREEZ SOIL MOISTURE

      REAL FRZPAR(*),SACPAR(*),FRZST(*),SACST(*),SACST_PRV(*)
      REAL SMC(*), SH2O(*)
      REAL SAND(12),CLAY(12)

C--      REAL SMC   ( 10 )
C--      REAL SH2O  ( 10 )
      REAL RHSTS ( 10 )
      REAL STC   ( 10 )
      REAL STCOUT ( 10 )
      REAL ZSOIL ( 10 )
C--      REAL DSW   ( 10 )
C--      INTEGER IDSW (10)

cc      SAVE NSOIL,ZSOIL,TBOT,ZBOT
C--      SAVE NSOIL,ZSOIL,TBOT
C--      SAVE UZTWC0,UZFWC0,LZTWC0,LZFSC0,LZFPC0
C--      SAVE SMC,SH2O
C--      SAVE DTFRZ,ISTART,IDT,NLOOP

C--      INTEGER ISTART/0/,NLOOP/0/
C--      REAL SMAX,PSISAT,BRT,QUARTZ,STYPE
C--      REAL DT,PX,TA,WE,AESC
      REAL LZTWM,LZFSM,LZFPM,LZSK,LZPK,LZTWC,LZFSC,LZFPC
      REAL LZTWH,LZFSH,LZFPH,LZTWC0,LZFSC0,LZFPC0

CVK_02  NEW COMMON STATEMENT FOR DESIRED SOIL LAYERS
C--      INTEGER NINT/5/,NINTW/5/
C--      REAL TSINT(10),SWINT(10),SWHINT(10)
C--      REAL DSINT(10)/0.05,0.1,0.2,0.5,1.0,1.5,2.0,0.,0.,0./
C--      REAL DSINTW(10)/0.05,0.1,0.2,0.5,1.0,1.5,2.0,0.,0.,0./
C--      REAL TSTMP(10),DSMOD(10),SWTMP(10),SWHTMP(10)
C--      SAVE DSINT,DSINTW
C--      COMMON/TSLINT/TSINT,NINT,SWINT,SWHINT,NINTW

      DATA SAND/0.92,0.82,0.58,0.17,0.09,0.43,0.58,0.10,0.32,0.52,
     +          0.06,0.22/
      DATA CLAY/0.03,0.06,0.10,0.13,0.05,0.18,0.27,0.34,0.34,0.42,
     +          0.47,0.58/

C     COMMON BLOCKS
C--      COMMON/IONUM/IN,IPR,IPU
cc      COMMON/FSMPM1/UZTWM,UZFWM,UZK,PCTIM,ADIMP,RIVA,ZPERC,REXP,LZTWM,
cc     1              LZFSM,LZFPM,LZSK,LZPK,PFREE,SIDE,SAVED,PAREA
C--      COMMON/FSMCO1/UZTWC,UZFWC,LZTWC,LZFSC,LZFPC,ADIMC,FGCO(6),RSUM(7),
C--     1           PPE,PSC,PTA,PWE,PSH,TSOIL(8)
cc      COMMON/FPMFG1/FGPM(15)
C--      COMMON/FPMFG1/itta,FGPM(15),ivers,ifrze
C--      COMMON/FRDSTFG/SMAX,PSISAT,BRT,SWLT,QUARTZ,STYPE,NUPL,
C--     +               NSAC,RTUZ,RTLZ,DZUP,DZLOW
cc      COMMON/FRZCNST/ FRST_FACT,CKSOIL,ZBOT
C--      COMMON/FRZCNST/ FRST_FACT,ZBOT

      DO I=1,NSOIL
       STC(I)=FRZST(I)+T0
       ZSOIL(I)=FRZPAR(9+I)
      ENDDO

c 2/2012 error in estimation ITXT
c 2/2012 error      ITXT=FRZPAR(1)+0.01
      ITXT=FRZPAR(1)+0.5
      BRT = 15.9*CLAY(ITXT) + 2.91
      SMAX = -0.126*SAND(ITXT) + 0.489
      STYPE = 12

C  CALL SUBROUTINE TO RECALCULATE SAC-SMA STATES INTO FROZEN
C  GROUND MODEL STATES:
C  UPPER ZONE STORAGES
c      WRITE(*, *) 'FROST2_1: SACST(2) = ', SACST(2)
c      WRITE(*, *) 'FROST2_1: SACST_PRV(2) = ', SACST_PRV(2)

      DWT=FRZPAR(6)*(SACST(1)-SACST_PRV(1))
      DWF=FRZPAR(6)*(SACST(2)-SACST_PRV(2))
      NUP=2
cc      IEXIT=0
CVK 12/2005      CALL SAC2FRZ1(DWT,DWF,SMC,SH2O,NUP,NUPL,ZSOIL,SMAX)
      CALL SAC2FRZ1(DWT,DWF,SMC,SH2O,NUP,NUPL,ZSOIL,SMAX,FRZPAR(9))

C  LOWER ZONE STORAGES
      DWT=FRZPAR(7)*(SACST(3)-SACST_PRV(3))
      DWF=FRZPAR(7)*(SACST(4)+SACST(5)-SACST_PRV(4)-SACST_PRV(5))
      NUP=NUPL+1
CVK 12/2005      CALL SAC2FRZ1(DWT,DWF,SMC,SH2O,NUP,NSAC,ZSOIL,SMAX)
      CALL SAC2FRZ1(DWT,DWF,SMC,SH2O,NUP,NSAC,ZSOIL,SMAX,FRZPAR(9))

c      WRITE(*,*) 'FROST2_1: ', (SMC(i), SH2O(i), i=1,NSAC)
C  CALCULATE SNOW DENSITY
C   SH - SNOW DEPTH IN CM
C   SR - SNOW DENSITY IN G/CM3
C   WE - SNOW WATER EQUIVALENT IN MM
      IF(WE .EQ. 0.) THEN
       SHX=0.
       SR=0.2
      ELSE
       SR=0.1*WE/SH
       SHX=0.01*SH
      ENDIF
C  CONVERT AIR TEMPERATURE INTO KALVIN UNITS
      TAIR=TA+T0

C  FROZEN GROUND SIMULATION LOOP
      DO IT=1,IDT
C  HRT1 ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN
       CALL HRT1(RHSTS,STC,SMC,SMAX,NSOIL,ZSOIL,TAIR,FRZPAR(2),
     +           FRZPAR(5),FRZPAR(8),SH2O,DTFRZ,BRT,SHX,SR,AESC,
     +           STYPE,SAND(ITXT),FRZPAR(3),IVERS,FRZPAR(4))

C     HSTEP ROUTINE CALCS/UPDATES SOIL TEMPS BASED ON RHSTS
       CALL HSTEP ( STCOUT,STC,RHSTS,DTFRZ,NSOIL)

C   DOUBLE CALLING HRT1 & HSTEP TO REDUCE NOISE.
C   IT RUNS ONLY IF THERE IS AN ICE IN ONE SOIL LAYER AT LEAST
       IFRZ = 0
       DO I = 1,NSOIL
        XXS=SMC(I) - SH2O(I)
        IF( XXS .GT. 0.0 ) IFRZ = 1
       ENDDO
       IF ( IFRZ .EQ. 1 ) THEN

C  SECOND CALL OF HRT1 AND HSTEP
        DO I = 1,NSOIL
         STC(I) = 0.5 * ( STCOUT(I) + STC(I) )
        ENDDO
        CALL HRT1(RHSTS,STC,SMC,SMAX,NSOIL,ZSOIL,TAIR,FRZPAR(2),
     +            FRZPAR(5),FRZPAR(8),SH2O,DTFRZ,BRT,SHX,SR,AESC,
     +            STYPE,SAND(ITXT),FRZPAR(3),IVERS,FRZPAR(4))

C     HSTEP ROUTINE CALCS/UPDATES SOIL TEMPS BASED ON RHSTS
        CALL HSTEP ( STC,STC,RHSTS,DTFRZ,NSOIL)
       ELSE

C  SKIP SECOND CALL OF HRT1 AND HSTEP
        DO I = 1,NSOIL
          STC(I) = STCOUT(I)
        ENDDO
       ENDIF

      ENDDO

C  STORE SOIL TEMPERATURE STATES IN CELSIUS
      ITFRZ=0
      DO I=1,NSOIL
       FRZST(I)=STC(I)-T0
       IF(FRZST(I) .LT. 0.) ITFRZ=ITFRZ+1
      ENDDO
      FRZDUP=0.
      FRZDBT=0.
      FROST=0.

C  RECALCULATE UNFROZEN MOISTURE STATES INTO SAC-SMA STORAGES
      ISFRZ=0
      DO J=1,5
       IF(SACST(J) .NE. FRZST(J+5)) ISFRZ=ISFRZ+1
      ENDDO
      IF(ISFRZ .NE. 0 .OR. ITFRZ .NE. 0) THEN
       CALL FRZ2SAC1(PX,ZSOIL,SMC,SH2O,NUPL,NSAC,FRZPAR(9),FRZPAR(6),
     +      FRZPAR(7),FRZST,SACST,FROST, HRAPX,HRAPY)
       IF(NSAC .NE. NSOIL) FROST=FROST-1000.*(SMC(NSOIL)-
     +    SH2O(NSOIL))*(ZSOIL(NSOIL-1)-ZSOIL(NSOIL))/FRST_FACT

C  FROST DEPTH CALCULATION
C--       FIND=FRZIND1(SMC,SH2O,TSOIL,ZSOIL,NSOIL,NUP,NSAC,RTUZ,RTLZ,
C--     +             FROST,SWLT,FRZ)
       CALL FRZIND1(SMC,SH2O,FRZST,ZSOIL,NSOIL,FRZPAR(9),FRZDUP,FRZDBT)
      ENDIF

C  REMEMBER SAC-SMA PREVIOUS STATES
      DO J=1,5
       SACST_PRV(J) = SACST(J)
      ENDDO
C--      UZTWC0=UZTWC
C--      UZFWC0=UZFWC
C--      LZTWC0=LZTWC
C--      LZFSC0=LZFSC
C--      LZFPC0=LZFPC

CVK_02  NEW OPTION TO INTERPOLATE MODEL SOIL LAYER TEMP. INTO DESIRED LAYERS
C--      NMOD=NSOIL+1
CCC      DSMOD(1)=0.
C--      DSMOD(1)=-0.5*ZSOIL(1)
C--      TSTMP(1)=TSOIL(1)
C--      SWTMP(1)=SMC(2)
C--      SWHTMP(1)=SH2O(2)
C--      DSMOD(NMOD)=-ZBOT
C--      TSTMP(NMOD)=TBOT-T0
C--      SWTMP(NMOD)=SMAX
C--      SWHTMP(NMOD)=SMAX
C--      DO I=2,NMOD-1
C--       DSMOD(I)=-0.5*(ZSOIL(I-1)+ZSOIL(I))
C--       TSTMP(I)=TSOIL(I)
C--       SWTMP(I)=SMC(I)
C--       SWHTMP(I)=SH2O(I)
C--      ENDDO
C--      CALL SOIL_INT1(TSTMP,NMOD,DSMOD,DSINT,NINT,TSINT)
C--      CALL SOIL_INT1(SWTMP,NMOD,DSMOD,DSINTW,NINTW,SWINT)
C--      CALL SOIL_INT1(SWHTMP,NMOD,DSMOD,DSINTW,NINTW,SWHINT)
C--      DO I=1,NINTW
C--       IF(I .EQ. 1) THEN
C--        SWINT(I)=SWINT(I)*DSINTW(I)*1000.
C--        SWHINT(I)=SWHINT(I)*DSINTW(I)*1000
C--       ELSE
C--        SWINT(I)=SWINT(I)*(DSINTW(I)-DSINTW(I-1))*1000.
C--        SWHINT(I)=SWHINT(I)*(DSINTW(I)-DSINTW(I-1))*1000
C--       ENDIF
C--      ENDDO

      RETURN
      END


	SUBROUTINE RD_FCTM ( segmnt, lens, isstar, idtarr, idp,
     +			     mxfctm, ispnt, gemftm, lfchr, kpshr,
     +			     jftmst, jftmen, iret )
C************************************************************************
C* RD_FCTM								*
C*									*
C* This subroutine finds and decodes the forecast time string and	*
C* converts it into GEMPAK format.					*
C*									*
C* RD_FCTM  ( SEGMNT, LENS, ISSTAR, IDTARR, IDP, MXFCTM, ISPNT, GEMFTM,	*
C*	      LFCHR, KPSHR, JFTMST, JFTMEN, IRET )			*
C*									*
C* Input parameters:							*
C*      SEGMNT		CHAR*		Bulletin segment		*
C*      LENS		INTEGER		Length of segment		*
C*	ISSTAR (5)	INTEGER		Integer issue time array	*
C*	IDTARR (5)	INTEGER		Integer time array for 1st date	*
C*	IDP		INTEGER		Position of 1st date in dateline*
C*					 or if <= 0, then using pos of	*
C*					 1st fct hr and idtarr has last	*
C*					 date and |idp| is local fcst hr*
C*	MXFCTM		INTEGER		Maximum number of forecast times*
C*									*
C* Input and output parameters:						*
C*	ISPNT		INTEGER		Segment pointer			*
C*									*
C* Output parameters:							*
C*      GEMFTM (*)	CHAR*		GEMPAK date/time		*
C*      LFCHR (*)	INTEGER		Local forecast hours		*
C*      KPSHR (*)	INTEGER		Positions of forecast hours	*
C*      JFTMST		INTEGER		Index of first valid GEMFTM	*
C*      JFTMEN		INTEGER		Index of last GEMFTM		*
C*	IRET		INTEGER		Return code			*
C*					   0 = normal return		*
C*					  -1 = no time line found	*
C*					  -2 = error in time line	*
C*					  -3 = no more report lines	*
C**									*
C* Log:									*
C* F. J. Yen/NCEP	 9/02						*
C* F. J. Yen/NCEP	11/02	Handle "3HRLY" & "6HRLY" and 2 timelines*
C************************************************************************
	INCLUDE         'GEMPRM.PRM'
C*
	CHARACTER*(*)	segmnt, gemftm (*)
	INTEGER		isstar(*), idtarr (*)
	INTEGER		lfchr(*), kpshr(*)
C*
        CHARACTER       tznlst(8)*4, znlst(8)*5
        INTEGER         ilens(9), jdar(5), jfdar(5), mdar(5)
        DATA            tznlst / 'EDT ', 'EST ', 'CDT ', 'CST ',
     +				 'MDT ', 'MST ', 'PDT ', 'PST '/
        DATA            ilens / 9*5 /
C------------------------------------------------------------------------
	iret = 0
C
C*	Find the start of time line
C
	DO k = 1, 8
	    znlst (k) = CHLF // tznlst (k)
	END DO

    	CALL ST_NXTS ( segmnt, ispnt, lens, znlst, ilens, 8, ishp,
     +		istrg, ier )
	ishpsv = ishp
	IF ( ier .ne. 0 ) THEN
	    iret = -1
	    RETURN
	END IF
C
C*	Check for possible "3HRLY" and "6HRLY" after time zone
C
	iskip = 4
	iphr = INDEX ( segmnt ( ishp + 3:ishp + 20 ), '3HRLY' )
	IF ( iphr .eq. 0 ) THEN
	    iphr = INDEX ( segmnt ( ishp + 3:ishp + 20 ), '6HRLY' )
	    IF ( iphr .ne. 0 ) THEN
		ishp = iphr + ishp + 2
		iskip = 5
	    END IF
	  ELSE
	    ishp = iphr + ishp + 2
	    iskip = 5
	END IF
C
C*	Get local times and positions
C
    	ishp = ishp + 1
	iehp = INDEX ( segmnt ( ishp:ishp + 80 ), CHCR )
	ispnt = ishp + iehp
	IF ( iehp .eq. 0 ) THEN
	    iret = -1
	    RETURN
	END IF
	jb = ishp + iskip
	ip = 0
	jftmen = 0
	DO WHILE ( jb .lt. ishp + iehp - 1 .and. jftmen .le. mxfctm )
	    DO WHILE ( INDEX ( segmnt ( jb:jb ), ' ' ) .ne. 0
     +			.and. jb .lt. ishp + iehp - 1)
		jb = jb + 1
	    END DO
		js = jb
		jn = jb + 1
	    DO WHILE ( INDEX ( segmnt ( jn:jn ), ' ' ) .eq. 0
     +			.and. jn .lt. ishp + iehp - 1)
		jn = jn + 1
	    END DO
	    IF ( jn - jb .ne. 2 ) THEN
		IF ( segmnt (jb:jb) .ne. CHCR ) THEN
	            iret = -2
	            RETURN
		END IF
	      ELSE
	        jftmen = jftmen + 1
	        CALL ST_NUMB ( segmnt (jb:jn-1), lfchr (jftmen), ier )
		IF ( ier .ne. 0 ) THEN
		    iret = -2
		    RETURN
		END IF
C*
C*		Change hour 24 to 00 for consistency
C*
		IF ( lfchr (jftmen) .eq. 24 ) lfchr (jftmen) = 0
	        kpshr (jftmen) = js - ishpsv
	    END IF
	    jb = jn + 1
	END DO
	IF ( jftmen .eq. 0 ) THEN
	    iret = -2
	    RETURN
	END IF
C
C*	Convert to GEMPAK format
C*
C*	If idp is greater than 0 (not extended fcst time line),
C*	determine the position of the known hour for the first date
C*	(ie, the forecast hour that is closest to the date).
C*
C*	If idp is less than or equal to 0 (extended fcst time line),
C*	then the absolute value of idp is the last fcst hour (local
C*	time) in the first time line and idtarr contains the integer
C*	time array of that forecast hour, which can be used.
C
	IF ( idp .gt. 0 ) THEN
	    jj = 1
	    jfd = 0
	    DO WHILE ( jj .lt. jftmen .and. jfd .eq. 0 )
	        IF ( kpshr (jj) .lt. idp ) THEN
		    jj = jj + 1
	          ELSE
		    jfd = jj
	        END IF
	    END DO
C
C*	    Determine GEMPAK time for the known hour at index jfd
C
	    jdar ( 1 ) = idtarr ( 1 )
	    jdar ( 2 ) = idtarr ( 2 )
	    jdar ( 3 ) = idtarr ( 3 )
	    jdar ( 4 ) = lfchr(jfd)
	    jdar ( 5 ) = 0
	  ELSE IF ( idp .le. 0 ) THEN
            jfd = 0
C
C*	    Convert known time from GMT to local time.
C
	    CALL TI_TZDF ( idtarr, 'GMT', tznlst(istrg)(1:3), jdar,
     +			hr, ier )
	END IF

	IF ( jfd .eq. 0 .and. idp .gt. 0 ) THEN
	    iret = -2
	    RETURN
	END IF
C
C*	Determine GEMPAK time for the known hour at index jfd.
C*	First convert local time to GMT.
C
	CALL TI_TZDF ( jdar, tznlst(istrg)(1:3), 'GMT', jfdar, hr, ier )
C
C*	Convert remaining local times to GEMPAK
C*	First convert times before index jfd.
C
	IF ( idp .gt. 0 ) THEN
C
C*	    Convert to GEMPAK format
C
    	    CALL TI_ITOC ( jfdar, gemftm(jfd), ier )
	    DO jj = 1,5
	        mdar ( jj ) = jfdar ( jj )
	    END DO
	    m2 = jfd
	    m1 = m2 - 1
	    DO WHILE ( m1 .ge. 1 )
	        mdif = lfchr ( m2 ) - lfchr ( m1 )
	        IF ( mdif .lt. 0 ) THEN
		    mdif = ( 24 + mdif )
	        END IF
	        mdif = mdif * 60
	        CALL TI_SUBM ( mdar, mdif, mdar, ier )
C
C*	        Convert to GEMPAK format
C
	        CALL TI_ITOC ( mdar , gemftm( m1 ), ier )
	        m2 = m1
	        m1 = m1 - 1
	    END DO
	END IF
C
C*	Now convert local times after index jfd to GEMPAK
C
        DO jj = 1,5
	    mdar ( jj ) = jfdar ( jj )
        END DO
	m1 = jfd
	m2 = m1 + 1
	DO WHILE ( m2 .le. jftmen )
	    IF ( m1 .eq. 0 ) THEN
		mdif = lfchr ( m2 ) + idp
	      ELSE
	        mdif = lfchr ( m2 ) - lfchr ( m1 )
	    END IF
	    IF ( mdif .lt. 0 ) THEN
		mdif = ( 24 + mdif )
	    END IF
	    mdif = mdif * 60
	    CALL TI_ADDM ( mdar, mdif, mdar, ier )
C
C*	    Convert to GEMPAK format
C
	    CALL TI_ITOC ( mdar, gemftm( m2 ), ier )
	    m1 = m2
	    m2 = m2 + 1
	END DO
C
C*	Find the first valid time index (at or after issue time)
C
	jftmst = 0
	jj = 1
	DO WHILE ( jj .le. jftmen .and. jftmst .eq. 0 )
	    CALL TI_CTOI ( gemftm ( jj ), mdar, ier )
	    CALL TI_MDIF ( isstar, mdar, mdiff, ier )
	    IF ( mdiff .le. 0 ) THEN
		jftmst = jj
	    END IF
	    jj = jj + 1
	END DO
C
C*	If there is a second forecast time string, skip over it.
C*	(UTC time strings are not processed, because local times
C*	are needed for MX/MN.)
C
	CALL ST_NXTS ( segmnt, ispnt, ispnt + 30, znlst, ilens, 8,
     +		       ipos, istrg, ier )
	IF ( ier .eq. 0 ) THEN
	    idx = INDEX ( segmnt ( ipos:ipos + 80 ), CHCR )
	    IF ( idx .gt. 0 ) THEN
		ispnt = ispnt + idx
	      ELSE
	        iret = -3
	    END IF
	END IF
C*
	RETURN
	END