      SUBROUTINE INPUT
Status: R

C
#include "slgcm.slgprm"
#include "slgcm.slgwrk"
#include "slgcm.slgprg"
#include "slgcm.slgcon"
#include "slgcm.slgout"
C
C*********************************************************************
C*********************** SLAG    MODEL *******************************
C********************* SUBROUTINE INPUT ******************************
C********************** 11 AUGUST  1989 ******************************
C*********************************************************************
C
      PARAMETER (LR=14, IEM=145, JEM=90)
c     PARAMETER (LR=15, IEM=73, JEM=45)
      PARAMETER (NSK1=4*LR+1, NSK2=3*LM+4)
C
      COMMON /DFLTR/ DTFL, ITAUF, KRSFO, NDG
      COMMON /INOUT/ DT, INITC
C
      DIMENSION US(IJM0M0,LR), VS(IJM0M0,LR), GS(IJM0M0,LR)
     *,         PS(IJM0M0),    RS(IJM0M0,LR), UEC(IEM,JEM)
     *,         GTP(IJM0M0,LM)
C
      EXTERNAL OUTPUT, OUTBAK, OUTFOR
C
      DOUBLE PRECISION TAU
      REAL             HEADER(50), PSTR(LR)
      INTEGER DAYS(12)
      DATA DAYS/ 0, 31, 59, 90,120,151,181,212,243,273,304,334/
C
      EQUIVALENCE (WKX(1,13),       PS(1))
     *,           (WKX(1,14),       US(1,1))
     *,           (WKX(1,14+LR),    VS(1,1))
     *,           (WKX(1,14+LR+LR), GS(1,1))
     *,           (WKX(1,14+LR*3),  UEC(1,1))
     *,           (WKY(1,1),        GTP(1,1))
C
      INTEGER           DT, RDHOUR, DTFL
      LOGICAL           ABNNMI, GEOSYM, RHWAVE, RESTRT, GEOPL, NOTOP
      LOGICAL           RSTRW, SEASNL, DIURNL, RSFLG
      LOGICAL           ADIBT, DIGFLT, SHFTR, FORWAD, DDI, ADJMS
C
      DATA              ADIBT/.FALSE./, DIGFLT/.FALSE./, SHFTR/.FALSE./
     *,                 DDI/.FALSE./, ADJMS/.FALSE./, NOTOP/.FALSE./
      DATA              ABNNMI/.FALSE./, KVEX/13/
     *,                 GEOSYM/.FALSE./, RHWAVE/.FALSE./
     *,                 GEOPL/.FALSE./,  RESTRT/.FALSE./
C
      DATA              DELT,  RDHOUR, NCRAND/3600.0,   24, 6/
      DATA              RSTRW, SEASNL, DIURNL/.FALSE.,.TRUE.,.FALSE./
      DATA              KPR/46/, KRSI/80/
      DATA              TAUC/6.0/, KRSF/0/, FORWAD/.TRUE./
      DATA              KRMN/0/, KRMX/0/, NDIG/1/
      DATA              RSFLG/.FALSE./, DIVDMP/0.0/, DDMPB/0.0/
     *,                 DDMPF/0.0/, LAVRX/0/
C
      DATA              TEXTT/0.0/,TEXTN/0.0/,TEXPT/0.0/,TEXPN/0.0/
C
      NAMELIST /INLIST/ DELT,  RDHOUR, SEASNL, DIURNL, KPR, KRSI
     *,                 IYR, IMN,    IDY,    IHR, RESTRT, NCRAND
     *,                 ADIBT, DIGFLT, TAUC, KRSF, FORWAD
     *,                 KRMN, KRMX, DIVDMP, DDMPB, DDMPF, DDI,  NDIG
     *,                 ADJMS, GEOPL, NOTOP, LAVRX
     *,                 TEXTT, TEXTN, TEXPT, TEXPN
C
C
      DO 33441 L=1,20
      CHECK = SETALARM(L,10000000000)
33441 CONTINUE
      CHECK = TICK(0.0)
C
      ISTEP = 0
      IMCA  = 0
      INITC = 1
      CDF   = 1.0
      DO 28 N=1,IOVARS
      DO 23 I=1,IJM0M0
      VAR(I,N)=ZERO
   23 CONTINUE
28    CONTINUE
      DO 24 L=1,LM
      DO 24 I=1,IJM0M0
      FLW(I,L) = 0.0
      CFL(I,L) = 0.0
      FSW(I,L) = 0.0
      CFS(I,L) = 0.0
   24 CONTINUE
      DO 25 I=1,IJM0M0
      SLRIJ(I) = 0.0
C
      DSW(I) = 0.0
      RSW(I) = 0.0
      DSC(I) = 0.0
      RSC(I) = 0.0
C
      DLW(I) = 0.0
      OLW(I) = 0.0
      DLC(I) = 0.0
      OLC(I) = 0.0
   25 CONTINUE
C
c     DO 29 N=1,IOVMCA
c     DO 88900 I=1,IJM0M0
c        VMC(I,N)=ZERO
c88900 CONTINUE
c29    CONTINUE
      PCHANG = 0.0
      III = SETALARM(1,3600)
C
      READ(51,INLIST)
      WRITE(6,INLIST)
C
      DT = DELT + 0.0001
      ADIBAT = ADIBT
      FORWRD = FORWAD
      ITAUC  = TAUC + 0.001
      DIGFIL = DIGFLT
      NCRND  = NCRAND
      KRMIN  = KRMN
      KRMAX  = KRMX
      CDAMP  = DIVDMP
      ADMASS = ADJMS
      LMAVRX = LAVRX
C
      TEXF1  = TEXTT
      TEXF2  = TEXTN
      TEXFa  = TEXPT
      TEXFb  = TEXPN
C
      IF (.NOT. FORWRD) THEN
         DT = - DT
         ADIBAT = .TRUE.
         DIGFIL = .FALSE.
      ENDIF
      IF (GEOPL) THEN
         NOTOPG = .TRUE.
      ELSE
         NOTOPG = NOTOP
      ENDIF
C
      ITAUI = (IYR*365 + DAYS(IMN) + IDY - 1) * 24 + IHR
      TAU   = ITAUI * 3600.0
      ITAU = (TAU+0.1)/3600.
C
C
      DO 19 N=1,NPT
      ISEL(N) = (IMP3 * (N-1) * JMM1)/12 + 1
   19 CONTINUE
C
      DO 20 L=1,LM
c     TBR(L) = 273.16
      DO 10 I=1,IJM0M0
       UN0(I,L) = 10.0
       VN0(I,L) =  0.0
       TN0(I,L) =  0.0
       SGD(I,L) =  0.0
       GTP(I,L) =  0.0
       DIV(I,L) =  0.0
   10  CONTINUE
   20  CONTINUE
      DO 30 I=1,IJM0M0
      LGP(I) = 1000.0
   30  CONTINUE
C
      IF (RESTRT) GO TO 1001
      IF (GEOSYM) THEN
         CALL GEOCN(UN0, VN0, TN0, SGD, DIV, GTP, LGP, DT)
         GO TO 99
      ELSEIF (RHWAVE) THEN
C        CALL RHWTZ(UN0, VN0, TN0, SGD, DIV, GTP, LGP, DT)
         GO TO 99
      ELSEIF (GEOPL) THEN
         CALL GEOPOL(UN0, VN0, TN0, QN0, SGD, DIV, GTP, LGP, PIB, TSF)
         CALL GLMNP2(IMP3, JM, LGP(1), DX(1,2), DY, ARE2, DX(1,1), TEM)
         PRINT *,' INPUT : TEM = ',TEM
         PRINT *,' INITIAL STATE'
         PRINT *,'LGP:',(LGP(I),I=1,IMB2)
         PRINT *,'LGP:',(LGP(I+I1),I=1,IMB2)
         PRINT *,'UN0:',(UN0(I1+I,LM),I=1,IMB2)
         PRINT *,'UN0:',(UN0(I2+I,LM),I=1,IMB2)
         PRINT *,'VN0:',(VN0(I,LM),I=1,IMB2)
         PRINT *,'VN0:',(VN0(I1+I,LM),I=1,IMB2)
         PRINT *,'TN0:',(TN0(I,LM),I=1,IMB2)
         PRINT *,'TN0:',(TN0(I1+I,LM),I=1,IMB2)
         GO TO 99
      ENDIF
C
      REWIND KPR
   95 READ (KPR,END=1001,ERR=1001) IYMD, IHMS, NL
C
      IYEAR = IYMD/10000
      IYMD = IYMD - (IYMD/10000)*10000
      IMON = IYMD/100
      IDAY = IYMD-IMON*100
      IHOUR = IHMS/10000
      IHMS = IHMS - IHOUR*10000
      IMIN = IHMS/100
      TAU  = IHMS - IMIN*100
      TAU  = TAU + (((DAYS(IMON) +IDAY-1)*24+IHOUR)*60.+IMIN)*60.
     *           + IYEAR * 365 * 86400
      ITAUI = (TAU+0.001)/3600.0 + 0.001
C
      WRITE(6,586) IYEAR, IMON, IDAY, IHOUR, IMIN
 586  FORMAT(' READ PRESSURE HEADER FOR ',2I3,'/',I2,'  ',I2,':',I2)
C
      IF (NL .NE. LR) THEN
         PRINT *,' NL=',NL,' NOT EQUAL TO LR=',LR,'  : RUN STOPPED'
         STOP
       ENDIF
C
C READ RESTART
C
      IF (ITAU .NE. ITAUI) THEN
         READ(KPR) PSTR
         DO 96 NSK=1,NSK1
         READ(KPR) UEC
   96    CONTINUE
         GO TO 95
      ENDIF
C
      TAU = ITAU * 3600.0
C
      READ (KPR) PSTR
      PRINT *,' FOUND PSTR=',PSTR
C
      READ (KPR) UEC
      CALL INTER(IEM, JEM, IMP3, JM, UEC, PS, WK1)
C
      DO 32 L=1,LR
      READ (KPR) UEC
      CALL INTER(IEM, JEM, IMP3, JM, UEC, US(1,L), WK1)
   32 CONTINUE
      DO 33 L=1,LR
      READ (KPR) UEC
      CALL INTER(IEM, JEM, IMP3, JM, UEC, VS(1,L), WK1)
   33 CONTINUE
C
      DO 34 L=1,LR
      READ (KPR) UEC
      CALL INTER(IEM, JEM, IMP3, JM, UEC, GS(1,L), WK1)
   34 CONTINUE
C
      DO 35 L=1,LR
      READ (KPR) UEC
      CALL INTER(IEM, JEM, IMP3, JM, UEC, RS(1,L), WK1)
   35 CONTINUE
C
c*    CALL CONSL(DT)
      CALL GETBCS(SEASNL)
      CALL PTOSIG(US,  VS,  GS,  RS, PS,  PSTR, LR
     *,           UN0, VN0, TN0, QN0, PIB, TSF
     *,           WK1, WK2, WK3, WK4, WK5)
C
C
      IF (ABNNMI .AND. KVEX .GT. 0) THEN
         PRINT *,' CALLING NORMAL MODE INITIALIZATION ROUTINE'
C        CALL NNMI(KRSI)
      ENDIF
C
      DO 765 I=1,IJM0M0
      LGP(I) = ALOG(PIB(I)*100.0)
      PIB(I) = PIB(I)
      PIK(I) = PIB(I) ** RKAP
  765 CONTINUE
      CALL GLMNP2(IMP3, JM, LGP(1), DX(1,2), DY, ARE2, DX(1,1), PBR)
C     
c     PBR = 0.0
      DO 770 I=1,IJM0M0
      LGP(I) = LGP(I) - PBR
  770 CONTINUE
C
      PRINT *,' PBR=',PBR,' PHAT=',PHAT
C
      GBR(:) = 0.0
C
C
C SOLID BODY ROTATION
C
C     CALL GEOC(UN0, VN0, TN0, SGD, DIV, GTP, LGP, DT)
C     CALL GEOSTR(UN0, VN0, TN0, SGD, DIV, GTP, LGP, DT, WK1, WK2)

C
C WRITE INITIAL STATE
C
   99 CONTINUE
C
      HEADER(1) = PBR
      DO 5110 L=1,LM
      HEADER(L+1) = GBR(L)
 5110 CONTINUE
      icldc = 0
      icldn = 0
      cld(:,:) = 0.0
      cln(:,:) = 0.0
      REWIND (KRSI)
      WRITE(KRSI) TAU, ICLDC, ICLDL, HEADER
C
      DO 2120 L=1,LM
      WRITE (KRSI) (UN0(I,L),I=1,IJM0M0)
     *,            (VN0(I,L),I=1,IJM0M0)
     *,            (TN0(I,L),I=1,IJM0M0)
     *,            (SGD(I,L),I=1,IJM0M0)
     *,            (DIV(I,L),I=1,IJM0M0)
 2120 CONTINUE
      WRITE (KRSI) (LGP(I),I=1,IJM0M0)
C
      DO 2130 L=1,LM
      WRITE (KRSI) (UN0(I,L),I=1,IJM0M0)
     *,            (VN0(I,L),I=1,IJM0M0)
     *,            (TN0(I,L),I=1,IJM0M0)
     *,            (SGD(I,L),I=1,IJM0M0)
     *,            (DIV(I,L),I=1,IJM0M0)
     *,            (QN0(I,L),I=1,IJM0M0)
 2130 CONTINUE
C
      WRITE (KRSI) (LGP(I),I=1,IJM0M0)
C
C
      DO 2140 L=1,LM
      WRITE (KRSI) (CLD(I,L),I=1,IJM0M0)
     *,            (CLN(I,L),I=1,IJM0M0)
 2140 CONTINUE
C
      WRITE (KRSI) (TSF(I),I=1,IJM0M0)
C
      WRITE (KRSI) (PIB(I),I=1,IJM0M0)
C
C
      REWIND KRSI
      RSFLG = .FALSE.
C
      IF (DIGFIL .OR. DDI) THEN
         IF (KRSF .LE. 0 .OR. KRSF .GT. 99) THEN 
            PRINT *,' KRSF HAS VALUE', KRSF,' RUN STOPPED' 
            STOP 
         ENDIF 
c        ADMASS = .TRUE.
C
         KRSTEM = KRSI
         DO 3003 NDG=1,NDIG
         REWIND KRSI
         ADIBAT = .TRUE.
         III = SETALARM(1,DT)
         ITAUF = TAU - ITAUC * 1800
c        KRSFO = KRSF
         KRSFO = KRSI
         DTFL  = DT
         CDAMP = -DDMPB
C
         REWIND KRSFO
         CALL SLGCM(-DT, RDHOUR, SEASNL, DIURNL, KRSI
     *,               ADIBAT, OUTBAK, RSFLG, SHFTR)
C
         REWIND KRSFO
         IF (.NOT. ADIBT) ADIBAT = .FALSE.
         NSTEP = 0
         ISTEP = 0
         SHFTR = .TRUE.
         RSFLG = .TRUE.
         CDAMP = DDMPF
C
c        ADMASS = ADJMS
         IF (DIGFIL .OR. (NDG .EQ. 1)) THEN
            ITAUF = ITAUF + ITAUC * 3600
            CALL RESTRD(KRSFO, SHFTR)
            CALL OUTFOR(*101)
  101       REWIND KRSFO
            CALL SLGCM(DT, RDHOUR, SEASNL, DIURNL, KRSFO
     *,                 ADIBAT, OUTFOR, RSFLG, SHFTR)
         ELSE
            ITAUF = ITAUF + ITAUC * 1800
            CALL SLGCM(DT, RDHOUR, SEASNL, DIURNL, KRSFO
     *,                ADIBAT, OUTBAK, RSFLG, SHFTR)
         ENDIF
C
         KRSI = KRSFO
         REWIND KRSI
         III = SETALARM(1,3600)
         NSTEP = 0
         ISTEP = 0
         SHFTR = .TRUE.
C
         REWIND KRSI
         CALL RESTRD(KRSI, SHFTR)
C
         TEM1 = 0.0
         TEM2 = 0.0
         DO 2003 I=1,IJM0M0
         WK1(I) = 0.01 * EXP(LGPO(I)+PBR)
 2003    CONTINUE
C
         CALL ADJMAS(IMP3, JM, PIB, LGP,  DX, DY, ARE2,   PBR
     *,                                           SRFPRS, TEM1)
         CALL ADJMAS(IMP3, JM, WK1, LGPO, DX, DY, ARE2,   PBR
     *,                                           SRFPRS, TEM2)
         print *,' mass adjustment after',ndg,' cycle of '
     *,          ' initialization:',tem2,tem1
     *,  ' ndg=',ndg
C
         IF (DIGFIL .OR. (NDG .EQ. 1)) THEN
            DO 2035 I=1,IJM0M0
            WK1(I) = 1.0 / (WK1(I) ** RKAP)
            WK2(I) = 1.0 / (PIB(I) ** RKAP)
 2035       CONTINUE
            DO 2040 L=1,LM 
            DO 2040 I=1,IJM0M0 
            TN1(I,L) = (1.0 + TN1(I,L)) * WK1(I) * (TBR(L) / PRH(L)) 
            TN0(I,L) = (1.0 + TN0(I,L)) * WK2(I) * (TBR(L) / PRH(L))
 2040       CONTINUE 
         ENDIF
C
C
         KRSI = KRSTEM
         REWIND KRSI
         CALL RESTWT(KRSI)
 3003    CONTINUE
         CDAMP = DIVDMP
      ENDIF
C
      REWIND KRSI
      CALL RESTRD(KRSI, SHFTR)
      ADMASS = ADJMS
C
      DO 110 N=1,IOVARS
      DO 110 I=1,IJM0M0
      VAR(I,N)=ZERO
  110 CONTINUE
C
      INITC = 0
      CALL OUTPUT(*102)
  102 REWIND KRSI
      INITC = 1
C
C
      CALL SLGCM(DT, RDHOUR, SEASNL, DIURNL, KRSI
     *,              ADIBAT, OUTPUT, RSFLG, SHFTR)

C
      RETURN
C
1001  CONTINUE
      PRINT *, '  COULD NOT FIND A PRESSURE RESTART : WILL READ RESTART'
     *, ' ON UNIT = ',KRSI   
C     CALL CONSL(DT)
C     CALL GETBCS(SEASNL)
C     REWIND KRSI
C     CALL RESTRD(KRSI)
C     CALL OUTPUT(*103)
  103 REWIND KRSI
      IIIK = 0
1005  READ(KRSI,END=1008,ERR=1008) TAU, ICLDC, ICLDL, HEADER
1004  ITAU = (TAU+0.1) / 3600.0
      PRINT *,' FOUND TAU = ', TAU, ' AND TAUI = ', ITAUI
      PRINT *,' FOUND TAU = ', ITAU,' LOOKING FOR TAU = ',ITAUI
      IF (ITAU .LT. ITAUI) THEN
         DO 1006 NSK=1,NSK2
         READ(KRSI)
1006     CONTINUE
         GO TO 1005
      ELSEIF (ITAU .GT. ITAUI) THEN
         PRINT *,' RESTART NOT AVAILABLE : EXECUTION STOPPING'
         STOP
      ENDIF
C
      BACKSPACE KRSI
      PRINT *, '  REST OF INPUT WAS SKIPPED         '
C
c     CALL SLGCM(DT,KRSI,OUTPUT,TAU, .TRUE., SEASNL, RDHOUR, DIURNL)
      CALL SLGCM(DT, RDHOUR, SEASNL, DIURNL, KRSI
     *,              ADIBAT, OUTPUT, .TRUE., SHFTR)
C
      RETURN
C
1008  CONTINUE
      IIIK = IIIK + 1
      IF (IIIK .LT. 2) GO TO 1004
      PRINT *,' END OF RESTART REACHED : NO GOOD RESTART -- RUN STOPPED'
      STOP
      END
C
C*********************************************************************
C*********************** SLAG    MODEL *******************************
C********************* SUBROUTINE OUTPUT *****************************
C********************** 11 AUGUST 1989  ******************************
C*********************************************************************
C
      SUBROUTINE OUTPUT(*)
C
#include "slgcm.slgprm"
#include "slgcm.slgprg"
#include "slgcm.slgcon"
#include "slgcm.slgout"
#include "slgcm.slgwrk"
C
      COMMON /INOUT/ DT, INITC
C
      DOUBLE PRECISION TAU
      DIMENSION      POB(IJM0M0,LM), PHI(IJM0M0,LM)
     *,              OMG(IJM0M0,LM)
C
      DIMENSION      PSTR(20), HDC(50)
      INTEGER        RSREFD,   RSDAY, DAYS(12), DT
      LOGICAL        FIRST, RSTRW, SIGHST, PHYHST, unitre
      CHARACTER * 184 dispfl
      CHARACTER * 70 dispf2
      CHARACTER * 57 dispsl
      CHARACTER * 3   EXPN
      CHARACTER * 46  DCBP
      CHARACTER * 29  RESTA
      CHARACTER * 20  RESTB
C
      DATA DAYS/ 0, 31, 59, 90,120,151,181,212,243,273,304,334/
      DATA FIRST/ .TRUE. /, SIGHST/ .FALSE. /, RSTRW/.FALSE./
     *,    unitre/.false./
      DATA KYR/0/,KMN/0/,KDY/0/,KHR/0/, KRSO/83/, KHSD/91/, KHSP/92/
      DATA RSREFD/01/, RSDAY/31/, IOREFH/0/
C
      DATA DCBP/',DCB=(RECFM=U,LRECL=X,BLKSIZE=23476,DSORG=PS),'/
      DATA RESTA/'DISP=(NEW,CATLG),SPACE=(CYL,('/
      DATA RESTB/'),RLSE),UNIT=USERDA"'/
C
      DATA IBMON/0/, IBDAY/0/, IBYER/0/, IFAIL/0/, IFAILC/2/
      DATA ICDB/100/, ICDI/10/, ICPB/100/, ICPI/10/ 
     *,    ICRB/100/, ICRI/10/
C
      DATA PSTR/20*0.0/, HDC/50*0.0/
      DATA ISTGH/240/, ISTGR/1/, IHSTW/24/, IRSTW/240/, EXPN/'000'/
      DATA SIGHST/.FALSE./, LMI/01/,  RSTRW/.FALSE./, IOREFH/0/
C
      NAMELIST/OUTLST/ SIGHST, LMI, IOHOUR, PSTR, RSTRW, KRSO
     *,        KHSD, KHSP,    KYR,    KMN, KDY,    KHR, IOREFH
     *,        PHYHST, ISTGH, ISTGR, IHSTW, IRSTW, IFAILC, EXPN
     *,        ICDB, ICDI, ICPB, ICPI, ICRB, ICRI, unitre
c    *,        RSREFD, RSDAY, PHYHST, ISTGH
C
      EQUIVALENCE (WKX(1,13),       POB(1,1))
     *,           (WKX(1,13+LM),    PHI(1,1))
     *,           (WKX(1,13+LM+LM), OMG(1,1))
C
      IF (FIRST) THEN
         FIRST = .FALSE.
         READ (51,OUTLST)
         WRITE(6,OUTLST)
         IF (ADIBAT) PHYHST = .FALSE.
         ITAUE = (KYR*365+DAYS(KMN)+KDY-1)*24+KHR
C
         DO 333 I=1,50
         HDC(I) = UNDF
  333    CONTINUE
C        CALL RESTWT(KRSO)
         rewind khsd
         rewind khsp
C
         IHST1  = IHSTW * 3600
         IRST1  = IRSTW * 3600
         ISTAGH = ISTGH * 3600
         ISTAGR = ISTAGH * ISTGR
C
         III = SETALARM(11,IHST1)
         III = SETALARM(12,IRST1)
         III = SETALARM(19,ISTAGR)
         III = SETALARM(20,ISTAGH)
         IBMON = MONTH()
         IBDAY = DAY()
         IBYER = YEAR()
      ENDIF
C
C
      IHOUR = CTIME() / 3600.0  + 0.001
c     IF ((MOD(IHOUR,IOHOUR) .EQ. 0 .AND. IHOUR .GT. 0)
c    *                              .OR. IHOUR .EQ. 0)  THEN
         if (alarm(11) .or. (initc .eq. 0)) then
C
         HDC(1) = YEAR()
         HDC(2) = MONTH()
         HDC(3) = DAY()
         HDC(4) = HOUR()
C
         WRITE(KHSD) HDC
         WRITE(KHSP) HDC
C
c        PRINT *,' INOUTPUT: PBR=',PBR
C
         CALL GLMNP2(IMP3, JM, PIB, DX(1,2), DY, ARE2, DX(1,1), GLBM)
C
         PRINT *,' GLOBAL MEAN PRESSURE = ', GLBM
C
         DO 134 I=1,IJM0M0
         WK1(I) = PHIS(I)
  134    CONTINUE
         DO 50 L=LM,1,-1
         CALL FILPU(UN0(1,L))
         CALL FILPV(VN0(1,L))
C
C
         DO 135 I=1,IJM0M0
         POB(I,L) = TN0(I,L) * (PIK(I)*PRH(L))
         WK2(I  ) = POB(I,L) * (DSL(L)*RGAS)
         PHI(I,L) = WK1(I  ) + WK2(I)*0.5
         WK1(I  ) = WK1(I  ) + WK2(I)
  135    CONTINUE
C
C
         PRINT *,' GLOBAL MEANS AT IHOUR=',IHOUR,' AND LEVEL=',L
C
         CALL GLBMN(IMP3,JM,UN0(1,L),VN0(1,L),POB(1,L),SGD(1,L), CPH)
   50    CONTINUE
c        CALL CHKENG(IMP3, JM, LM, UN0, VN0, POB, PIB, CPH, DSG)
C
C
C
         IF (SIGHST) THEN
            DO 100 L=1,LM
C
C ***  U WIND ***
            CALL TRNSDA(IM, IMP3, JM, UN0(1,L), WK4)
            CALL WRITE1 (KHSD, IM*JM, WK4)
C ***  V WIND ***
            CALL TRNSDA(IM, IMP3, JM, VN0(1,L), WK4)
            CALL WRITE1 (KHSD, IMJM, WK4)
C
C *** TEMPERATURE ***
            CALL TRNSDA(IM, IMP3, JM, POB(1,L), WK4)
            CALL WRITE1 (KHSD, IMJM, WK4)
C
C *** SPECIFIC HUMIDITY ***
            CALL TRNSDA(IM, IMP3, JM, QN0(1,L), WK4)
            CALL WRITE1 (KHSD, IMJM, WK4)
C
C *** GEOPOTENTIAL***
            CALL TRNSDA(IM, IMP3, JM, PHI(1,L), WK4)
            CALL WRITE1 (KHSD, IMJM, WK4)
CDIV
c           CALL TRNSDA(IM, IMP3, JM, DIV(1,L), WK4)
c           CALL WRITE1 (KHSD, IMJM, WK4)
CSGD
            CALL TRNSDA(IM, IMP3, JM, SGD(1,L), WK4)
            CALL WRITE1 (KHSD, IMJM, WK4)
  100       CONTINUE
         ELSE
C
            DO 185 I=1,IJM0M0
            WK1(I) = 0.0
  185       CONTINUE
            DO 190 L=1,LM
            DO 190 I=1,IJM0M0
            WK1(I) = WK1(I) + DIV(I,L) * DSG(L)
  190       CONTINUE
            DO 194 I=1,IJM0M0
            WK1(I) = WK1(I) * (1.0/(SIG(LMP1)-SIG(1)))
  194       CONTINUE
            DO 199 L=1,LM
            if (L .eq. 1) then
               do 196 I=1,IJM0M0
               OMG(I,L) = 0.5 * PIB(I) * SGD(I,L)    + SGB(L) * WK1(I)
  196          continue
            elseif (L .LT. LM) then
               do 197 I=1,IJM0M0
               OMG(I,L) = 0.5 * PIB(I) * (SGD(I,L-1) + SGD(I,L))
     *                                               + SGB(L) * WK1(I)
  197          continue
            else
               do 198 I=1,IJM0M0
               OMG(I,L) = 0.5 * PIB(I) * SGD(I,L-1)  + SGB(L) * WK1(I)
  198          continue
            endif
  199       continue
C
C
            DO 200 L=1,LMI
C
C ***  U WIND ***
C
c           PRINT *,' PSTR(L)=',PSTR(L)
            CALL INTERU (UN0, PIK, WK7, PSTR(L))
            CALL TRNSDA(IM, IMP3, JM, WK7, WK4)
            CALL WRITE1 (KHSD, IMJM, WK4)
C           IF (L .GT. 10)
C
C ***  V WIND ***
C
            CALL INTERV (VN0, PIK, WK8, PSTR(L))
            CALL TRNSDA(IM, IMP3, JM, WK8, WK4)
            CALL WRITE1 (KHSD, IMJM, WK4)
C
C *** TEMPERATURE ***
C
            CALL INTERP (POB, PIK, WK7, PSTR(L))
            CALL TRNSDA(IM, IMP3, JM, WK7, WK4)
            CALL WRITE1 (KHSD, IMJM, WK4)
C
C *** GEOPOTENTIAL***
C
            CALL INTERP (PHI, PIK, WK7, PSTR(L))
            CALL TRNSDA(IM, IMP3, JM, WK7, WK4)
            CALL WRITE1 (KHSD, IMJM, WK4)
C
C *** SPECIFIC HUMIDITY
C
            CALL INTERP (QN0, PIK, WK7, PSTR(L))
            CALL TRNSDA(IM, IMP3, JM, WK7, WK4)
            CALL WRITE1 (KHSD, IMJM, WK4)
C
CDIV
C
c           CALL INTERP (DIV, PIK, WK7, PSTR(L))
c           CALL TRNSDA(IM, IMP3, JM, WK7, WK4)
C           CALL WRITE1 (KHSD, IMJM, WK4)
C
COMEGA
C
            CALL INTERP (OMG, PIK, WK7, PSTR(L))
            CALL TRNSDA(IM, IMP3, JM, WK7, WK4)
            CALL WRITE1 (KHSD, IMJM, WK4)
C
  200       CONTINUE
         ENDIF
C
C SURFACE PRESSURE
C
         CALL TRNSDA(IM, IMP3, JM, PIB, WK4)
         CALL WRITE1 (KHSD, IMJM, WK4)
C
C SEA LEVEL PRESSURE
C
C
         DO 220 I=1,IJM0M0
         POB(I,LM) = POB(I,LM) / (PIK(I) * PRH(LM))
  220    CONTINUE
         CALL GETSLP(PIK,POB(1,LM),WK1)
         CALL TRNSDA(IM, IMP3, JM, WK1, WK4)
         CALL WRITE1 (KHSD, IMJM, WK4)
C
         PRINT *,' WROTE HISTORY AT HOUR =',IHOUR
C
         IF (PHYHST) CALL PHYOUT(KHSP, WK1, WK2, WK3, WK4, WK5)
C
      ENDIF
C
      IF (RSTRW) THEN
c        ist = mod(day()-rsrefd,rsday)
c        print *,' ist=',ist,' day=',day(),' rsrefd=',rsrefd
c    *,          ' rsday=',rsday,' hour=',hour()

c        IF ( (MOD(DAY()-RSREFD,RSDAY) .EQ. 0 .AND. HOUR() .EQ. 0)
c    *      .OR. (FORWRD .AND. IHOUR .GE. ITAUE)
c    *      .OR. (.NOT. FORWRD .AND. IHOUR .LE. ITAUE)) THEN
C
            if (alarm(12)) then
c
            DO 223 I=1,IJM0M0 
            WK1(I) = ((0.01 * EXP(LGPO(I)+PBR))) ** RKAP 
  223       CONTINUE
C 
            DO 224 L=1,LM
            DO 224 I=1,IJM0M0
            TN1(I,L) = (TN1(I,L) + 1.0) * (TBR(L)/ (WK1(I)*PRH(L))) 
  224       CONTINUE
C
            CALL RESTWT(KRSO)

            DO 225 L=1,LM
            DO 225 I=1,IJM0M0
            TN1(I,L) = TN1(I,L) * WK1(I)*(PRH(L)/TBR(L)) - 1.0
  225       CONTINUE
C
            PRINT *,' WROTE RESTART AT HOUR =',IHOUR
            PRINT *,' total change of mass=',pchang
         ENDIF
      ENDIF
C
c        WRITE(41) NSTEP
c        WRITE(41) ((PSAV(I,J),J=1,NSTEP), I=1,NPT)
c    *,            ((DSAV(I,J),J=1,NSTEP), I=1,NPT)
C
      if (alarm(20)) then
c
         HDC(1) = -YEAR()
         HDC(2) = -MONTH()
         HDC(3) = -DAY()
         HDC(4) = -HOUR()
C
         WRITE(KHSD) HDC
         WRITE(KHSP) HDC
C
         IEMON = MONTH()
         IEDAY = DAY()
         IEYER = YEAR()
C
         write(dispsl,3001) EXPN, IBMON, IBDAY, IBYER
     *,                           IEMON, IEDAY, IEYER
 3001    format('cp slgcm.dynhst /silo/yfsma/slgruns/E',A3,'D.B'
     *,             3I2.2,'.E',3I2.2)

         if (unitre) then 
         write(dispf2,4001) LM, IM, EXPN, DT, IBMON, IBDAY, IBYER
     *,                     IEMON, IEDAY, IEYER
 4001    format('dirac.ftp slgcm.runs L',I2.2,'R',I3.3,' E',A3
     *,         'D DT',I4.4,' slgcm.dynhst B',3I2.2,'.E',3I2.2)
         print *,' dispf2=',dispf2

         else

         write(dispfl,5001) EXPN, LM, IM, DT, IBMON, IBDAY, IBYER
     *,                     IEMON, IEDAY, IEYER, DCBP, RESTA
     *,                     ICDB, ICDI, RESTB
C
 5001    format('dispose slgcm.dynhst -m ES -f TR -t '
     *,  '"DSN=YFSMA.E',A3,'D.L',I2.2,'R',I3.3,'.DT',I4.4
     *,  '.B',3I2.2,'.E',3I2.2
     *,   A46, A29,I3.3,',',I2.2,A20)
         endif
C
         endfile khsd
         backspace khsd
         rewind khsd
C
         if (unitre) then
            ISTAT = ISHELL(dispf2)
            print *,' istat=',istat
         else
            ISTAT = ISHELL(dispfl)
         endif
         ISTAT = ISHELL(dispsl)
C
         if (ISTAT .NE. 0) then
            print *,' dispose of dynamics history file failed -- will'
     *,     ' continue the run'
            ifail = ifail + 1
         else
            print *,' dynamics history successfully disposed at year='
     *,     year(),' mon=',month(),' day=',day(),' hour=',hour()
         endif
         rewind khsd
C
         if (phyhst) then

         write(dispsl,3002) EXPN, IBMON, IBDAY, IBYER
     *,                           IEMON, IEDAY, IEYER
 3002    format('cp slgcm.phyhst /silo/yfsma/slgruns/E',A3,'P.B'
     *,             3I2.2,'.E',3I2.2)

         if (unitre) then 
         write(dispf2,4002) LM, IM, EXPN, DT, IBMON, IBDAY, IBYER
     *,                     IEMON, IEDAY, IEYER
 4002    format('dirac.ftp slgcm.runs L',I2.2,'R',I3.3,' E',A3
     *,         'P DT',I4.4,' slgcm.phyhst B',3I2.2,'.E',3I2.2)
         print *,' dispf2=',dispf2

         else

         write(dispfl,5002) EXPN, LM, IM, DT, IBMON, IBDAY, IBYER
     *,                     IEMON, IEDAY, IEYER, DCBP, RESTA
     *,                     ICPB, ICPI, RESTB
C
 5002    format('dispose slgcm.phyhst -m ES -f TR -t '
     *,  '"DSN=YFSMA.E',A3,'P.L',I2.2,'R',I3.3,'.DT',I4.4
     *,  '.B',3I2.2,'.E',3I2.2
     *,   A46, A29,I3.3,',',I2.2,A20)
         endif
C
         endfile khsp
         backspace khsp
         rewind khsp
C
         if (unitre) then
            ISTAT = ISHELL(dispf2)
            print *,' istat=',istat
         else
            ISTAT = ISHELL(dispfl)
         endif
         ISTAT = ISHELL(dispsl)
C
         if (ISTAT .NE. 0) then
            print *,' dispose of physics history file failed --'
     *,     ' will continue the run'
            ifail = ifail + 1
         else
            print *,' physics history successfully disposed at year='
     *,     year(),' mon=',month(),' day=',day(),' hour=',hour()
         endif
         rewind khsp
         endif
C
         if (rstrw .and. alarm(19)) then
 
         write(dispsl,3003) EXPN, IBMON, IBDAY, IBYER
     *,                           IEMON, IEDAY, IEYER
 3003    format('cp slgcm.restrt /silo/yfsma/slgruns/E',A3,'R.B'
     *,             3I2.2,'.E',3I2.2)

         if (unitre) then 
         write(dispf2,4003) LM, IM, EXPN, DT, IBMON, IBDAY, IBYER
     *,                     IEMON, IEDAY, IEYER
 4003    format('dirac.ftp slgcm.runs L',I2.2,'R',I3.3,' E',A3
     *,         'R DT',I4.4,' slgcm.restrt B',3I2.2,'.E',3I2.2)
         print *,' dispf2=',dispf2

         else
C
            write(dispfl,5003) EXPN, LM, IM, DT, IBMON, IBDAY, IBYER
     *,                     IEMON, IEDAY, IEYER, DCBP, RESTA
     *,                     ICRB, ICRI, RESTB
C
 5003    format('dispose slgcm.restrt -m ES -f TR -t '
     *,  '"DSN=YFSMA.E',A3,'R.L',I2.2,'R',I3.3,'.DT',I4.4
     *,  '.B',3I2.2,'.E',3I2.2
     *,   A46, A29,I3.3,',',I2.2,A20)
         endif
C
            endfile krso
            backspace krso
            rewind krso
C
            if (unitre) then
               ISTAT = ISHELL(dispf2)
            else
               ISTAT = ISHELL(dispfl)
            endif
            ISTAT = ISHELL(dispsl)
C
            if (ISTAT .NE. 0) then
               print *,' dispose of restart file failed -- will'
     *,                ' stop the run'
               stop
            else
             print *,' restart file successfully disposed at year='
     *,      year(),' mon=',month(),' day=',day(),' hour=',hour()
            endif
            rewind krso
c
            IF ((FORWRD .AND. (IHOUR .GT. ITAUE-ISTGH*ISTGR)) .OR.
     *          (.NOT.FORWRD .AND. (IHOUR .LT. ITAUE+ISTGH*ISTGR))) THEN
               print *,' IHOUR=',IHOUR,' ITAUE=',ITAUE
     *,                ' ISTGH=',ISTGH,' ISTGR=',ISTGR
               RETURN KSTOP
            ENDIF
         endif
C
         if (ifail .gt. ifailc) then
            print *,' Too many dispose failures -- run stopped'
            stop
         endif
C
         IBMON = IEMON
         IBDAY = IEDAY
         IBYER = IEYER
      endif
C
      IF ((FORWRD .AND. IHOUR .GE. ITAUE)  .OR.
     *    (.NOT. FORWRD .AND. IHOUR .LE. ITAUE)) THEN
         RETURN KSTOP
      ENDIF
C
      RETURN
      END
      SUBROUTINE PHYOUT(KHS,  TX1, TX2, TX3, TX4, TX5)
C
#include "slgcm.slgprm"
      PARAMETER (CLBET=0.75)
      PARAMETER (KEV=1, KCU=2, KLS=20)
c     PARAMETER (KEV=1, KCU=2, KMC=1, KLS=2)
#include "slgcm.slgprg"
#include "slgcm.slgcon"
#include "slgcm.slgout"
C
C
      DIMENSION TX1(IJM0M0), TX2(IJM0M0), TX3(IJM0M0), TX4(IJM0M0)
      REAL  GMET, GMPT, GMCT, GMMT, GMEO, GMPO, GMCO, GMMO
     *,     GMEL, GMPL, GMCL, GMML
C
C     SAVE
      TEM1 = ONE
      IF (ISTEP .NE. 0) TEM1 = ONE/FLOAT(ISTEP)
      DO 10 NV=1,IOVARS
      DO 5 I=1,IJM0M0
      VAR(I,NV) = VAR(I,NV) * TEM1
    5 CONTINUE
      CALL TRNSDA(IM, IMP3, JM, VAR(1,NV), TX1)
      CALL WRITE1 (KHS, IMJM, TX1)
   10 CONTINUE
C
C
c        TEM1 = ONE
c        IF (IMCA .NE. 0) TEM1 = ONE/FLOAT(IMCA)
c        DO 20 NV=1,IOVMCA
c        DO 15 I=1,IJM0M0
c        VMC(I,NV) = VMC(I,NV) * TEM1
c  15    CONTINUE
c  20    CONTINUE
C
C
c     CALL GLBMN(VAR(1,1,KEV), DXYIJ, PHISS, GMET, GMEO, GMEL)
c     CALL GLBMN(VMC(1,1,KLS), DXYIJ, PHISS, GMPT, GMPO, GMPL)
c     CALL GLBMN(VAR(1,1,KCU), DXYIJ, PHISS, GMCT, GMCO, GMCL)
c     CALL GLBMN(VMC(1,1,KMC), DXYIJ, PHISS, GMMT, GMMO, GMML)
C
      CALL GLMNP2(IMP3, JM, VAR(1,KEV), DX(1,2),DY,ARE2,DX(1,1),GMET)
      CALL GLMNP2(IMP3, JM, VAR(1,KLS), DX(1,2),DY,ARE2,DX(1,1),GMPT)
      CALL GLMNP2(IMP3, JM, VAR(1,KCU), DX(1,2),DY,ARE2,DX(1,1),GMCT)
c     CALL GLMNP2(IMP3, JM, VMC(1,KMC), DX(1,2),DY,ARE2,DX(1,1),GMMT)
C
      PRINT *,' GLBAL MEAN EVP, PRE, CUP : TOTAL'
      WRITE(6,3010) GMET, GMPT, GMCT
C
c     PRINT *,' GLBAL MEAN EVP, PRE, CUP : FOR TOTAL, OCEAN AND LAND'
c     WRITE(6,3010) GMET, GMPT, GMCT, GMMT, GMEO, GMPO, GMCO, GMMO
c    *,             GMEL, GMPL, GMCL, GMML
 3010 FORMAT(2X,8E12.4)
C
c     DO 25 I=1,IJM0M0
c     TX4(I) = PIB(I) ** RKAP
c  25 CONTINUE
c     DO 40 L=1,LM
c     DO 30 I=1,IJM0M0
c     TX1(I) = TN0(I,L) * PRH(L) * TX4(I)
c     TX2(I) = PIB(I) * SGB(L)
c  30 CONTINUE
C
c     CALL VQSAT(TX1,TX2,TX3,TX5,IJM0M0,.FALSE.)
c     DO 35 I=1,IJM0M0
c     DTC(I,L) = QN0(I,L)
c     DQC(I,L) = QN0(I,L) / TX3(I)
c  35 CONTINUE
c  40 CONTINUE
c
C
c     DO 45 NV=1,IOVMCA
c     CALL TRNSDA(IM, IMP3, JM, VMC(1,NV), TX1)
c     CALL WRITE1 (KHS, IMJM, TX1)
c  45 CONTINUE
C
C
c     DO 60 L=1,LM
c     DO 50 I=1,IJM0M0
c     TX1(I) = PIB(I)*(DSG(L)*CMB2CGS/GCGS)
c     TX3(I) = (1.0 + TN0(I,L)) * TBR(L)
c     TX1(I) = TN0(I,L) * PRH(L) * TX4(I)
c  50 CONTINUE
c     CALL CLDTHK(IJM0M0, TX3, TX2)
c     DO 55 I=1,IJM0M0
c     TX2(I) = TX2(I)  * CLBET
c     TX1(I) = -TX2(I) * TX1(I)
c     TX2(I) = EXP(TX1(I))
c     TX1(I) = ONE - TX2(I)
c     TX3(I) = VAR(I,20+L) * TX1(I)
c  55 CONTINUE
C     CALL WRITE1 (KHS, IJM0M0, TX3)
c  60 CONTINUE
C
c     DO 70 L=1,LM
c     DO 65 I=1,IJM0M0
c     TX1(I) = PIB(I)*(DSG(L)*CMB2CGS/GCGS)
c     TX1(I) = -(CIRTHK*CLBET)*TX1(I)
c     TX2(I) = EXP(TX1(I))
c     TX1(I) = ONE - TX2(I)
c     TX3(I) = VAR(I,20+LM+L) * TX1(I)
c  65 CONTINUE
C     CALL WRITE1 (KHS, IJM0M0, TX3)
c  70 CONTINUE
C

      ISTEP = 0
      DO 90 NV=1,IOVARS
      DO 85 I=1,IJM0M0
      VAR(I,NV) = ZERO
   85 CONTINUE
   90 CONTINUE
C
      IMCA  = 0
c     DO 97 NV=1,IOVMCA
c     DO 95 I=1,IJM0M0
c     VMC(I,NV) = ZERO
c  95 CONTINUE
c  97 CONTINUE
C
C     WRITE RADIATION RELATED FIELDS TO KHS
C
      DO 100 I=1,IJM0M0
      TX4(I) = ONE / PIB(I)
  100 CONTINUE
      DO 130 L=1,LM
      DO 120 I=1,IJM0M0
      TX3(I) = FSW(I,L) * SLRIJ(I) * TX4(I)
  120 CONTINUE
      CALL TRNSDA(IM, IMP3, JM, TX3, TX1)
      CALL WRITE1 (KHS, IMJM, TX1)
  130 CONTINUE
      DO 150 L=1,LM
      DO 140 I=1,IJM0M0
      TX3(I) = FLW(I,L) * TX4(I)
  140 CONTINUE
      CALL TRNSDA(IM, IMP3, JM, TX3, TX1)
      CALL WRITE1 (KHS, IMJM, TX1)
  150 CONTINUE
C
C     CLOUD FORCING OUTPUT
C
C     LONGWAVE
C
      DO 210 L=1,LM
      DO 200 I=1,IJM0M0
      TX3(I) = CFL(I,L) * TX4(I)
  200 CONTINUE
      CALL TRNSDA(IM, IMP3, JM, TX3, TX1)
      CALL WRITE1 (KHS, IMJM, TX1)
  210 CONTINUE
      CALL TRNSDA(IM, IMP3, JM, DLW, TX1)
      CALL WRITE1 (KHS, IMJM, TX1)
      CALL TRNSDA(IM, IMP3, JM, OLW, TX1)
      CALL WRITE1 (KHS, IMJM, TX1)
      CALL TRNSDA(IM, IMP3, JM, DLC, TX1)
      CALL WRITE1 (KHS, IMJM, TX1)
      CALL TRNSDA(IM, IMP3, JM, OLC, TX1)
      CALL WRITE1 (KHS, IMJM, TX1)
C
C     SHORTWAVE
C
      DO 230 L=1,LM
      DO 220 I=1,IJM0M0
      TX3(I) = CFS(I,L) * SLRIJ(I)
  220 CONTINUE
      CALL TRNSDA(IM, IMP3, JM, TX3, TX1)
      CALL WRITE1 (KHS, IMJM, TX1)
  230 CONTINUE
      DO 240 I=1,IJM0M0
      TX3(I) = DSW(I) * SLRIJ(I)
  240 CONTINUE
      CALL TRNSDA(IM, IMP3, JM, TX3, TX1)
      CALL WRITE1 (KHS, IMJM, TX1)
      DO 250 I=1,IJM0M0
      TX3(I) = RSW(I) * SLRIJ(I)
  250 CONTINUE
      CALL TRNSDA(IM, IMP3, JM, TX3, TX1)
      CALL WRITE1 (KHS, IMJM, TX1)
      DO 260 I=1,IJM0M0
      TX3(I) = DSC(I) * SLRIJ(I)
  260 CONTINUE
      CALL TRNSDA(IM, IMP3, JM, TX3, TX1)
      CALL WRITE1 (KHS, IMJM, TX1)
      DO 270 I=1,IJM0M0
      TX3(I) = RSC(I) * SLRIJ(I)
  270 CONTINUE
      CALL TRNSDA(IM, IMP3, JM, TX3, TX1)
      CALL WRITE1 (KHS, IMJM, TX1)
C
      RETURN
      END
C
C
      SUBROUTINE OUTBAK(*)
C
#include "slgcm.slgprm"
C
      COMMON /DFLTR/ DTFL, ITAUF, KRSFO, NDG
      INTEGER DTFL
C
      ITAU = CTIME() + 0.001
      IF (ITAU .EQ. ITAUF) THEN
         REWIND KRSFO
         CALL RESTWT(KRSFO)
         PRINT *,' WROTE RESTART AT YEAR =',YEAR(),' MONTH ='
     *,            MONTH(),' DAY = ', DAY(),' HOUR = ', HOUR()
         RETURN KSTOP
      ENDIF
C
      RETURN
      END
      SUBROUTINE OUTFOR(*)
C
#include "slgcm.slgprm"
#include "slgcm.slgwrk"
#include "slgcm.slgprg"
#include "slgcm.slgcon"
C
      COMMON /DFLTR/ DTFL, ITAUF, KRSFO, NDG
      INTEGER DTFL
C
      DOUBLE PRECISION TAU
      REAL   HEADER(50)
      REAL   UOR(IJM0M0), VOR(IJM0M0), TOR(IJM0M0), QOR(IJM0M0)
     *,      SGR(IJM0M0), DVR(IJM0M0)
C
      EQUIVALENCE (WK1(1),UOR(1)), (WK2(1), VOR(1))
     *,           (WK3(1),TOR(1)), (WK4(1), QOR(1))
     *,           (WK5(1),SGR(1)), (WK6(1), DVR(1))
C
      LOGICAL FIRST
      DATA FIRST/.TRUE./, NDGP/0/
      DATA NIN/0/
      SAVE
C
      IF (FIRST .OR. NDG .NE. NDGP) THEN
         FIRST = .FALSE.
         NDGP  = NDG
         NIN   = 0
C
         TAU  = CTIME() + ITAUC * 1800
         KRSF1 = KRST1
         KRSF2 = KRST2
         REWIND (KRSF1)
         HEADER(:) = 0.0
C
         HEADER(1) = PBR
         DO 2 L=1,LM
         HEADER(L+1) = GBR(L)
    2    CONTINUE
C
         WRITE(KRSF1) TAU, ICLDC, ICLDL, HEADER
C
         DO 5 I=1,IJM0M0
         UOR(I) = 0.0
         VOR(I) = 0.0
         TOR(I) = 0.0
         QOR(I) = 0.0
         SGR(I) = 0.0
         DVR(I) = 0.0
    5    CONTINUE
C
         DO 10 L=1,LM
         WRITE(KRSF1) UOR, VOR, TOR, SGR, DVR
   10    CONTINUE
         WRITE(KRSF1) UOR
C
         DO 20 L=1,LM
         WRITE(KRSF1) UOR, VOR, TOR, SGR, DVR, QOR
   20    CONTINUE
         WRITE(KRSF1) UOR
C
         DO 25  L=1,LM
         WRITE(KRSF1) UOR, VOR
   25    CONTINUE
         WRITE(KRSF1) UOR
         WRITE(KRSF1) UOR
      ENDIF
      TAUC = ITAUC
      NIN  = NIN + 1
C
      CALL DGFILT(DTFL, TAUC, NIN, KRSF1, KRSF2 
     *,                 WK8, WK9, UOR, VOR, TOR, SGR, DVR, QOR)
C
      ITAU = CTIME() + 0.001
      IF (ITAU .LT. ITAUF) THEN
         ITEM = KRSF1
         KRSF1 = KRSF2
         KRSF2 = ITEM
      ELSE
         REWIND KRSF2
         CALL RESTRD(KRSF2, .FALSE.)
         REWIND KRSFO
         CALL RESTWT(KRSFO)
c        KRSFO = KRSF2
         PRINT *,' WROTE FILTERED RESTART AT YEAR =',YEAR()
     *,  ' MONTH =',MONTH(),' DAY = ', DAY(),' HOUR = ', HOUR()
         RETURN KSTOP
      ENDIF
C
      RETURN
      END
      SUBROUTINE DFILTR(LEN, DT, TAUCH, NIN, FIN, FOU)
C
C
      PARAMETER (PI=3.1415926535898)
      DIMENSION HF(200), HF2(401)
      DIMENSION FIN(LEN), FOU(LEN)
      INTEGER DT
      LOGICAL FIRST
      DATA FIRST/.TRUE./
      SAVE
C
C     DATA HF/0.0383, 0.1219, 0.2132, 0.2531, 0.2132, 0.1219, 0.0383/
C     DATA HF/0.2531, 0.2132, 0.1219, 0.0383/
C
      IF (FIRST) THEN
         FIRST = .FALSE.
         TAUC  = TAUCH * 3600.0
         NN = (TAUC + 0.001) / (DT*2)
         NNP1 = NN + 1
         NN21 = 2*NN + 1
C
         HF(1) = 2.0 * DT / TAUC
         THETAC = PI * HF(1)
         TEMH = HF(1)
         DO 5 N=1,NN
         TEM = N * PI / FLOAT(NNP1)
         HF(N+1) = SIN(TEM) * SIN(N*THETAC) / (TEM*PI*N)
C     HF(N+1) =            SIN(N*THETAC) / (    PI*N)
         TEMH = TEMH + HF(N+1) + HF(N+1)
    5    CONTINUE
         DO 6 N=1,NNP1
         HF(N) = HF(N) / TEMH
    6    CONTINUE
C
         HF2(NNP1) = HF(1)
         DO 7 N=1,NN
         HF2(NNP1+N) = HF(N+1)
         HF2(NNP1-N) = HF(N+1)
    7    CONTINUE
C
         PRINT *,' NN=',NN,' DT=',DT,' TAUC=',TAUC
         WRITE(6,8) (HF2(N),N=1,NN21)
    8    format(' hf2=',10e12.4)
      ENDIF
C
C
      DO 20 I=1,LEN
       FOU(I) = FOU(I) + FIN(I)*HF2(NIN)
   20 CONTINUE
C
      RETURN
      END
      SUBROUTINE DGFILT(DT, TAUC, NIN, KRSF1, KRSF2 
     *,                 WK1, WK2, UOR, VOR, TOR, SGR, DVR, QOR)
C
#include "slgcm.slgprm"
#include "slgcm.slgprg"
#include "slgcm.slgcon"
C
C
      DOUBLE PRECISION TAU
      REAL   HEADER(50)
      INTEGER DT
      REAL    UOR(IJM0M0), VOR(IJM0M0), TOR(IJM0M0), SGR(IJM0M0)
     *,       DVR(IJM0M0), QOR(IJM0M0)
     *,       WK1(IJM0M0), WK2(IJM0M0)
C
C
      rewind krsf1
      rewind krsf2
C
C
      READ(KRSF1,END=100,ERR=100) TAU, ICL1, ICL2, HEADER
      WRITE(KRSF2,ERR=100) TAU, ICL1, ICL2, HEADER
C
      DO 5 I=1,IJM0M0
      WK1(I) = (0.01 * EXP(LGPO(I)+PBR)) ** RKAP
      WK2(I) = (0.01 * EXP(LGP (I)+PBR)) ** RKAP
   5  CONTINUE
C
      DO 10  L=1,LM
c
      DO 7 I=1,IJM0M0
      TN1(I,L) = TN1(I,L) * WK1(I)*(PRH(L)/TBR(L)) - 1.0
   7  CONTINUE
C
      READ(KRSF1) UOR, VOR, TOR, SGR, DVR
C
C
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, UN1(1,L), UOR)
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, VN1(1,L), VOR)
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, TN1(1,L), TOR)
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, SGDO(1,L), SGR)
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, DIVO(1,L), DVR)
C
      WRITE(KRSF2) UOR, VOR, TOR, SGR, DVR
C
   10 CONTINUE
      READ(KRSF1) UOR
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, LGPO, UOR)
      WRITE(KRSF2) UOR
C
      DO 20  L=1,LM
C
      DO 15 I=1,IJM0M0
      TN0(I,L) = TN0(I,L) * WK2(I)*(PRH(L)/TBR(L)) - 1.0
  15  CONTINUE
C
      READ(KRSF1) UOR, VOR, TOR, SGR, DVR, QOR
C
C
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, UN0(1,L), UOR)
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, VN0(1,L), VOR)
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, TN0(1,L), TOR)
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, SGD(1,L), SGR)
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, DIV(1,L), DVR)
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, QN0(1,L), QOR)
C
      WRITE(KRSF2) UOR, VOR, TOR, SGR, DVR, QOR
C
   20 CONTINUE
      READ(KRSF1) UOR
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, LGP, UOR)
      WRITE(KRSF2) UOR
C
C
      DO 25  L=1,LM
      READ(KRSf1) UOR, VOR
      if (icldl .gt. 0) then
         TOR(:) = CLD(:,L) / float(icldl)
         CALL DFILTR(IJM0M0, DT, TAUC, NIN, TOR, UOR)
      endif
      if (icldc .gt. 0) then
         QOR(:) = CLN(:,L) / float(icldc)
         CALL DFILTR(IJM0M0, DT, TAUC, NIN, QOR, VOR)
      endif
      WRITE(KRSF2) UOR, VOR
   25 CONTINUE
C
      READ(KRSf1) UOR
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, TSF, UOR)   
      WRITE(KRSF2) UOR
C
      READ(KRSf1) UOR
      CALL DFILTR(IJM0M0, DT, TAUC, NIN, PIB, UOR)   
      WRITE(KRSF2) UOR
C
      DO 35 I=1,IJM0M0
      WK1(I) = 1.0 / ((0.01 * EXP(LGPO(I)+PBR)) ** RKAP)
      WK2(I) = 1.0 / ((0.01 * EXP(LGP (I)+PBR)) ** RKAP)
  35  CONTINUE
      DO 40 L=1,LM
      DO 40 I=1,IJM0M0
      TN1(I,L) = (1.0 + TN1(I,L)) * WK1(I) * (TBR(L) / PRH(L))
      TN0(I,L) = (1.0 + TN0(I,L)) * WK2(I) * (TBR(L) / PRH(L))
   40 CONTINUE
C
      RETURN
100   CONTINUE
      PRINT *, ' NO DATA AVAILABLE : STOPPING IN DGFILT   '
      STOP
C
      END
C

