      SUBROUTINE RDTNML(DIURNL,SEASNL,RDHOUR)
Status: R

C
#include "slgcm.slgprm"
#include "slgcm.slgprg"
#include "slgcm.slgcon"
#include "slgcm.slclok"
#include "slgcm.slgwrk"
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C********************* SUBROUTINE  RDTNML ****************************
C********************** 7   APRIL  1987 ******************************
C*********************************************************************
C
C
      LOGICAL DIURNL, SEASNL, OZNE
      DIMENSION TSS(RDLEN), SAT(RDLEN), ST4(RDLEN)

      DIMENSION ALB(RDLEN), SLR(RDLEN), ZTH(RDLEN)
      DIMENSION DSX(RDLEN), RSX(RDLEN), FSX(RDLEN,LM)

      DIMENSION TLL(RDLEN,LM), PLE(RDLEN,LM)
      DIMENSION QLL(RDLEN,LM), O3L(RDLEN,LM)

      DIMENSION FLX(RDLEN,LM+1), FLC(RDLEN,LM+1)

      INTEGER   RDHOUR,     DAY0,       SEC0
      dimension o3b(ijm0m0,lm)
      equivalence(o3b(1,1),wkx(1,13))
C
C
      EQUIVALENCE (TLL(1,1), WK1(1))
      EQUIVALENCE (QLL(1,1), WK2(1))
      EQUIVALENCE (O3L(1,1), WK3(1))
      EQUIVALENCE (PLE(1,1), WK4(1))
      EQUIVALENCE (FLX(1,1), WK8(1))
      EQUIVALENCE (FLC(1,1), WK0(1))
      EQUIVALENCE (FSX(1,1), WK8(1))
C
C     SAVE
      CALL CLKON
      IF (RDLEN*(LM+1) .GT. IJM0M0)  THEN
         PRINT *, 'ERROR IN STRIPMINING'
         STOP
      ENDIF
C
C     CALL CHGCLD (CLD, CLN, ICLDL, ICLDC)
C
      DAY0 = DAYOFYR()
      SEC0 = SECOFDY()
      CALL SOLAR(DIURNL,SEASNL,DAY0,SEC0,WK1,WK2)
      CALL WRAP(1, IJM0M0, WK1)
      CALL WRAP(1, IJM0M0, WK2)
      DO 10 I=1,IJM0M0
      SLRIJ(I) = WK2(I)
   10 CONTINUE
C
      IF (DIURNL) THEN
         SEC0 = SEC0+RDHOUR*3600
         IF (SEC0 .GT. 86399) THEN
            DAY0 = DAY0 + 1
            SEC0 = SEC0 - 86400
            IF (DAY0 .GT. 365) THEN
               DAY0 = DAY0 - 365
            ENDIF
         ENDIF
         CALL SOLAR(DIURNL,SEASNL,DAY0,SEC0,WK3,WK2)
         CALL WRAP(1, IJM0M0, WK2)
         CALL WRAP(1, IJM0M0, WK3)
C
         DO 20 I=1,IJM0M0
         WK2(I) = WK1(I) * WK3(I)
         WK1(I) = WK1(I) + WK3(I)
   20    CONTINUE
         DO 30 I=1,IJM0M0
         IF (WK1(I) .NE. ZERO) WK2(I) = WK2(I) / WK1(I)
   30    CONTINUE
         DO 40 I=1,IJM0M0
         ZTHIJ(I)   = (WK1(I) - WK2(I)) * (TWO/THREE)
   40    CONTINUE
      ELSE
         DO 50 I=1,IJM0M0
         ZTHIJ(I) = WK1(I)
   50    CONTINUE
      ENDIF

      OZNE = .FALSE.
C     IF (.NOT. OZONE) THEN
c        OZNE = .FALSE.
c        DO 65 L=1,LM
c        DO 60 I=1,IJM0M0
c        O3B(I,1,L,1) = ZERO
c        O3B(I,1,L,2) = ZERO
c  60    CONTINUE
c  65    CONTINUE
c     ENDIF
      IF (FIXOZE) THEN
         CALL GETOZN(O3B, SEASNL)
         OZNE = .TRUE.
      ENDIF
c
c
 
      DO 100  K=1,NSTRIPS
C

c     print *,' k=',k,' pib=',pib(1),' tn0=',(tn0(1,l),l=1,lm)
c     print *,' Qn0=',(qn0(1,l),l=1,lm)

      CALL STRIP(PIB, WK7,  1 ,K)
      CALL STRIP(TN0, TLL, LM, K)
      CALL STRIP(QN0, QLL, LM, K)
      CALL STRIP(O3B, O3L, LM, K)
      CALL STRIP(CLD, WK5, LM, K)
      CALL STRIP(CLN, WK9, LM, K)
      CALL STRIP(TSF, TSS,  1, K)
c     O3L(:,:) = 0.0
C
         IF (ICLDL .NE. 0) THEN
            DO 70 I=1,RDLEN*LM
            WK5(I) = WK5(I)/FLOAT(ICLDL)
   70       CONTINUE
         ELSE
            DO 75 I=1,RDLEN*LM
            WK5(I) = 0.0
   75       CONTINUE
         ENDIF
         IF (ICLDC .NE. 0) THEN
            DO 80 I=1,RDLEN*LM
            WK9(I) = WK9(I) / FLOAT(ICLDC)
   80       CONTINUE
         ELSE
            DO 85 I=1,RDLEN*LM
            WK9(I) = 0.0
   85       CONTINUE
         ENDIF
C
      DO 150 L=1,LM
      DO 90 I=1,RDLEN
      PLE(I,L) = WK7(I) * SIG(L+1)
   90 CONTINUE
150   CONTINUE

      DO 95 I=1,RDLEN
      WK8(I) = WK7(I) ** RKAP
   95 CONTINUE

      DO 200 L=1,LM
      DO 110 I=1,RDLEN
      TLL(I,L) = TLL(I,L) * WK8(I) * PRH(L)
  110 CONTINUE
200   CONTINUE

      DO 210 I=1,RDLEN
      SAT(I) = TLL(I,LM) * (PRJ(LM+1)/PRH(LM))
  210 CONTINUE
c     print *,' tll=',(tll(1,l),l=1,lm), ' sat=',sat(1)
C
      CALL LONGWAVE(RDLEN, LM,  RDLEN
     *,             TLL,   QLL, O3L, PLE, WK5, WK9, SAT, TSS, OZNE
     *,             FLX,   FLC, ST4, WKX(1,13+LM)  )
C
c     print *,' flx=',(flx(1,l),l=1,lmp1)

      DO 220 I=1,RDLEN
      SAT(I) = - FLX(I,1)
  220 CONTINUE
      CALL PASTE (SAT, OLW,  1, K)
C
      DO 230 I=1,RDLEN
      SAT(I) = - FLC(I,1)
  230 CONTINUE
      CALL PASTE (SAT, OLC,  1, K)
C
      DO 240 I=1,RDLEN*LM
      FLX(I,1) = FLX(I,1) - FLX(I,2)
      FLC(I,1) = FLC(I,1) - FLC(I,2)
  240 CONTINUE
      DO 310 L=1,LM
      DO 250 I=1,RDLEN
      FLX(I,L) = FLX(I,L) * (GRAV/(DSG(L)*CP*CMB2PA))
      FLC(I,L) = FLC(I,L) * (GRAV/(DSG(L)*CP*CMB2PA))
  250 CONTINUE
310   CONTINUE
      DO 320 I=1,RDLEN
      FLX(I,LM+1) = FLX(I,LM+1) + ST4(I)
      FLC(I,LM+1) = FLC(I,LM+1) + ST4(I)
  320 CONTINUE
C
      CALL PASTE (FLX      , FLW, LM, K)
      CALL PASTE (FLX(1,LM+1), DLW,  1, K)
C
      CALL PASTE (FLC      , CFL, LM, K)
      CALL PASTE (FLC(1,LM+1), DLC,  1, K)

C******  START SHORTWAVE  *************

      CALL STRIP (ALBIJ, ALB, 1, K)
C     CALL STRIP (SLRIJ, SLR, 1, K)
      DO 330 I=1,RDLEN
      SLR(I) = ONE
  330 CONTINUE
      CALL STRIP (ZTHIJ, ZTH, 1, K)

C
C                       VT1 VT2 VT3 VT4 CLD CLN
      CALL SHRTWAVE(SIG,TLL,QLL,O3L,PLE,WK5,WK9
C                                        VT6 VT6 VT6  VT7  VT8  VT7
     *,                                  SLR,ALB,ZTH, DSX, FSX, RSX)

C
C
      CALL PASTE (DSX, DSW,  1, K)
      CALL PASTE (FSX, FSW, LM, K)
      CALL PASTE (RSX, RSW,  1, K)
C
C*********
C ADDED ON 12/05/89 TO CALCULATE CLOUD FORCING IN SHRTWAVE
C*********
C
      DO 350 I=1,IJM0M0
      WK5(I) = 0.0
      WK9(I) = 0.0
  350 CONTINUE
C                       VT1 VT2 VT3 VT4 CLD CLN
      CALL SHRTWAVE(SIG,TLL,QLL,O3L,PLE,WK5,WK9
C                                        VT6 VT6 VT6  VT7  VT8  VT7
     *,                                  SLR,ALB,ZTH, DSX, FSX, RSX)

C
C
      CALL PASTE (DSX, DSC,  1, K)
      CALL PASTE (FSX, CFS, LM, K)
      CALL PASTE (RSX, RSC,  1, K)
C******************************************
C
100   CONTINUE
C
C     CALL  CHGRAD(CFS,DSC,FSW,DSW)
C
      DO 300 L=1,LM
      DO 360 I=1,IJM0M0
      FLW(I,L) = FLW(I,L) / PIB(I)
c     FSW(I,L) = FSW(I,L) * PIB(I)
  360 CONTINUE
  300 CONTINUE
C
      WRITE(6,333) MONTH(), DAY(), HOUR(), MINUTE()
333   FORMAT(' RADIATION UPDATED AT     ',I3,'/',I2,'  ',I2,':',I2)
C
C     CALL CDRIFT(J1)
C
      CALL CLKOFF(RDTNTIME)
C
      RETURN
      END
      SUBROUTINE CLRCLD
C
#include "slgcm.slgprm"
#include "slgcm.slgprg"
C
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C********************* SUBROUTINE  CLRCLD ****************************
C********************** 7   APRIL  1987 ******************************
C*********************************************************************
C
C
c     IF (.NOT. FIXCLD) THEN
         DO 20 L=1,LM
         DO 10 I=1,IJM0M0
         CLD(I,L) = ZERO
         CLN(I,L) = ZERO
   10    CONTINUE
   20    CONTINUE
         ICLDL = 0
         ICLDC = 0
c     ENDIF
C
      RETURN
      END
      SUBROUTINE ASTRO(C,S,TH,SS,CZ,SLAT,COSZ)
C
#include "slgcm.slgprm"
C
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C********************* SUBROUTINE  ASTRO  ****************************
C********************** 7   APRIL  1987 ******************************
C*********************************************************************
C
C
      DIMENSION  C(JM),           S(JM)
      DIMENSION  TH(DAYSPRYR),    SLAT(JM),       COSZ(JM)
     *,          SS(JM,DAYSPRYR), CZ(JM,DAYSPRYR)
C
C     SAVE
      PYTH(X) = SQRT(ONE-X*X)
      FUN(Y)  = (TWO*PI/(PYTH(ECC)**3))*(ONE/DAYSPRYR)
     *          *(ONE - ECC*COS(Y-PER*PI/ONE80) ) ** 2
C
      KM     = EQNX
      TH(KM) = ZERO
      DO 200 K=2,DAYSPRYR
C
      T1 = FUN(TH(KM)       )
      T2 = FUN(TH(KM)+T1/TWO)
      T3 = FUN(TH(KM)+T2/TWO)
      T4 = FUN(TH(KM)+T3    )
C
      KP     = MOD(EQNX-2+K,DAYSPRYR) + 1
      TH(KP) = TH(KM) + (T1 + TWO*(T2 + T3) + T4) / SIX
      KM     = KP
C
200   CONTINUE
C
      SLAT(:) = ZERO
      COSZ(:) = ZERO
C
      DO 500 K=1,DAYSPRYR
      ZS = SIN(TH(K)) * SIN(OB*PI/ONE80)
      ZC = PYTH(ZS)
      PP = ((1.-ECC*COS(TH(K) - PER*PI/ONE80 )) / (1.-ECC*ECC))**2
C
      DO 501 J=1,JMM1
      Y   =  MAX(-ONE,-(S(J)*ZS) / (C(J)*ZC))
C
      IF (Y .LT. ONE) THEN
         H = ACOS(Y)
         SS(J,K) = (FOUR/PI) * (H*S(J)*ZS+SIN(H)*C(J)*ZC) * PP
         CZ(J,K) = SS(J,K)*PI / (FOUR*H)
      ELSE
         SS(J,K) = ZERO
         CZ(J,K) = ZERO
      ENDIF
C
 501  CONTINUE
C
      DO 20 I=1,JMM1
      SS(I,K) = SS(I,K)*SO/FOUR
      SLAT(I) = SLAT(I) + SS(I,K)
      COSZ(I) = COSZ(I) + SS(I,K)*CZ(I,K)
   20 CONTINUE
C
 500  CONTINUE
C
      DO 30 I=1,JMM1
      COSZ(I) = COSZ(I) / SLAT(I)
      SLAT(I) = SLAT(I) / FLOAT(DAYSPRYR)
   30 CONTINUE
C
      RETURN
      END
      SUBROUTINE STRIP(A,B,L,K)
C
#include "slgcm.slgprm"
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C********************* SUBROUTINE  STRIP  ****************************
C********************** 7   APRIL  1987 ******************************
C*********************************************************************
C
C
      DIMENSION A(IJM0M0,L), B(RDLEN,L)
      INTEGER   OFFSET
C
C     SAVE
      OFFSET = RDLEN*(K-1) + 1
C
      IF (K .EQ. NSTRIPS) THEN
         LEN = MOD(IJM0M1,RDLEN)+1
      ELSE
         LEN = RDLEN
      ENDIF
c     print *,' lens=',len,' l=',l,' offset=',offset
C
      DO 100 J=1,L
      DO 10 I=1,RDLEN
      B(I,J) = A(OFFSET,J)
10    CONTINUE
      DO 20 I=1,LEN
      B(I,J) = A(OFFSET+I-1,J)
20    CONTINUE
100   CONTINUE
C
      RETURN
      END
      SUBROUTINE PASTE(B,A,L,K)
C
#include "slgcm.slgprm"
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C********************* SUBROUTINE  PASTE  ****************************
C********************** 7   APRIL  1987 ******************************
C*********************************************************************
C
C
      DIMENSION A(IJM0M0,L), B(RDLEN,L)
      INTEGER   OFFSET
C
C     SAVE
      OFFSET = RDLEN*(K-1) + 1
C
      IF (K .EQ. NSTRIPS) THEN
         LEN = MOD(IJM0M1,RDLEN)+1
      ELSE
         LEN = RDLEN
      ENDIF
c     print *,' lenp=',len,' l=',l,' offset=',offset'
C
      DO 100 J=1,L
      DO 10 I=1,LEN
      A(OFFSET+I-1,J) = B(I,J)
10    CONTINUE
100   CONTINUE
C
      RETURN
      END
      SUBROUTINE POLY(P,X,B,N,LEN)
C
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C********************* SUBROUTINE  POLY  *****************************
C********************** 16  APRIL  1987 ******************************
C*********************************************************************
C
C
      DIMENSION P(LEN), X(LEN), B(N)
C
C     SAVE
      DO 10 I=1,LEN
      P(I) = B(N)
   10 CONTINUE
      IF (N .GT. 1) THEN
         DO 100 L=N,2,-1
         DO 20 I=1,LEN
         P(I) = P(I)*X(I) + B(L-1)
   20    CONTINUE
  100    CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE SOLAR(DIURNL,SEASNL,DAY0,SEC0,ZTH,SLR)
C
#include "slgcm.slgprm"
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C********************* SUBROUTINE SOLAR   ****************************
C********************** 7   APRIL  1987 ******************************
C*********************************************************************
C
C
C     ARGUMENTS
C
      PARAMETER (JMDPY=JM*DAYSPRYR)
      LOGICAL   DIURNL,       SEASNL
      INTEGER   DAY0,         SEC0
      DIMENSION ZTH(IMP3,JM), SLR(IMP3,JM)
C
C     LOCALS
C
      DIMENSION HC(IM),        C(JM),    S(JM)
      DIMENSION TH(DAYSPRYR),    SLAT(JM), COSZ(JM)
     *,         SS(JM,DAYSPRYR), CZ(JM,DAYSPRYR)
      LOGICAL   FIRST
      DATA      FIRST/ .TRUE. /
      DATA     C/JM*0.0/, S/JM*0.0/, HC/IM*0.0/
      DATA     SLAT/JM*0.0/, COSZ/JM*0.0/, TH/DAYSPRYR*0.0/
      DATA     SS/JMDPY*0.0/, CZ/JMDPY*0.0/
C
C     SAVE
C
      IF (FIRST) THEN
         FIRST = .FALSE.
         DO 100 J=1,JMH
         TEM        = -PI*0.5 + DPHI*(J-1)
         C(J)       = COS(TEM)
         C(JM-J+1)  = C(J)
         S(J)       = SIN(TEM)
         S(JM-J+1)  =-S(J)
  100    CONTINUE
         C(JMH+1)   = 1.0
         S(JMH+1)   = 0.0
C
C
         CALL ASTRO(C,S,TH,SS,CZ,SLAT,COSZ)
      ENDIF
C
      IDAY  = DAY0
      IDYP1 = MOD(IDAY,DAYSPRYR) + 1
      FAC   = FLOAT(SEC0)/DAYLEN
C
      IF (DIURNL) THEN
C
         DO 400 I=1,IM
         HC(I) =  COS( (FAC + (I-ONE)/FLOAT(IM)) * TWO*PI)
400      CONTINUE
         THNOW = TH(IDAY)*(ONE-FAC) + TH(IDYP1)*FAC
C
         ZS = SIN(THNOW) * SIN(OB*PI/ONE80)
         ZC = SQRT(ONE-ZS*ZS)
         PP = (ONE-ECC*COS(THNOW - PER*PI/ONE80 )) / (1.-ECC*ECC)
         PP = PP * PP
C
         DO 500 J=1,JM
         DO 420 I=1,IM
         ZTH(I,J) = S(J)*ZS + C(J)*ZC*HC(I)
420      CONTINUE
500      CONTINUE
         CALL WRAP(1,IJM0M0,ZTH)
C
         DO 520 I=1,IJM0M0
         SLR(I,1) = PP*ZTH(I,1)*SO
  520    CONTINUE
         DO 530 I=1,IJM0M0
         IF (ZTH(I,1) .LT. .0001) THEN
            ZTH(I,1) = ZERO
            SLR(I,1) = ZERO
         ENDIF
  530    CONTINUE
      ELSE
         IF(SEASNL) THEN
            DO 600 J=1,JM
            DO 550 I=1,IM
            ZTH(I,J)=CZ(J,IDAY)*(ONE-FAC)+CZ(J,IDYP1)*FAC
            SLR(I,J)=SS(J,IDAY)*(ONE-FAC)+SS(J,IDYP1)*FAC
  550       CONTINUE
  600       CONTINUE
         ELSE
            DO 700 J=1,JM
            DO 650 I=1,IM
            ZTH(I,J) = COSZ(J)
            SLR(I,J) = SLAT(J)
  650       CONTINUE
  700       CONTINUE
         ENDIF
      ENDIF
C
      RETURN
      END
      SUBROUTINE SHRTWAVE(SIG,TLO,QLO,O3O,PL2,CLU,CLC
     *,                                       SLR,ALB,ZTH,SWD,SWF,SWN)
C
#include "slgcm.slgprm"
#include "slgcm.slgwrk"
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C******************** SUBROUTINE SHRTWAVE ****************************
C********************** 5  AUGUST  1987 ******************************
C*********************************************************************
C
C
      PARAMETER (M=RDLEN, MLMM0=M*LM, MLMM1=M*LMM1, MLMP1=M*LMP1)
      PARAMETER (G0=.85, GP=G0*THREE/(ONE+G0))
      PARAMETER (PNOOZ=500.,WASTR=3.E-6,WAMIN=1.E-10,O3MIN=1.E-10)
      PARAMETER (TUMIN=1.E-6)
      PARAMETER (EXPMIN=-10.)
      PARAMETER (A1=35.,   A2=1224., A3=120.1612, A4=476.)
      PARAMETER (B1=.1299, B2=.2775, B3=.45,      B4=.866, B5=.118)
      PARAMETER (C1=.99,   C2=1.9,   C3=.647)
      PARAMETER (SEVEN=7.)
C
      PARAMETER (AZ1=.042,    AZ2=.000323, AZ3=.02118, AZ4=138.57)
      PARAMETER (AZ5=1.08173, AZ6=103.63,  AZ7=.0658,  EZ1=-.805)
C
      DIMENSION SIG(LMP1)
      DIMENSION TLO(M,LM), QLO(M,LM), O3O(M,LM), PL2(M,LM), CLU(M,LM)
     *,         ALB(M   ), SLR(M   ), ZTH(M   ), CLC(M,LM)
     *,         SWD(M   ), SWF(M,LM), SWN(M   )
C
      DIMENSION TX1(M,LMP2), TX2(M,LMP2), TX3(M,LMP2)
     *,         TX4(M,LMP2), TX5(M,LMP2), TX6(M,LMP2)
     *,         TX7(M,LMP2), TX8(M,LMP2), TX9(M,LMP2)
C
      DIMENSION CSM(M+1), GLL(M+1), ECN(M+1), ACN(M+1)
     *,         RC1(M+1), RCO(M+1), RCG(M+1), TUT(M)
      DIMENSION TZ1(M+1), TZ2(M+1), TZ3(M+1), TZ4(M+1)
      DIMENSION TZ5(M+1), TZ6(M+1)
C
      DIMENSION DPO(M,LMP2), SWI(M,LMP2), OZL(M,LMP2)
     *,         DNN(M,LMP2), UPP(M,LMP2), ACC(M,LMP2), SSC(M,LMP2)
     *,         RLL(M,LMP2), TLL(M,LMP2), TAU(M,LMP2), SOL(M,LMP2)
     *,         GM1(M,LMP2), GM2(M,LMP2), AL1(M,LMP2), AL2(M,LMP2)
     *,         ALL(M,LMP2), AAL(M,LMP2), BBL(M,LMP2), CLL(M,LMP2)
     *,         DLL(M,LMP2), ELL(M,LMP2), FLL(M,LMP2), ELO(M,LMP2)
     *,         ULL(M,LMP2), TAC(M,LMP2)
C
      EQUIVALENCE(WKY(1,1),   TX1(1,1))
     *,          (TX1(1,LMP2),TX2(1,1))
     *,          (TX2(1,LMP2),TX3(1,1))
     *,          (TX3(1,LMP2),TX4(1,1))
     *,          (TX4(1,LMP2),TX5(1,1))
     *,          (TX5(1,LMP2),TX6(1,1))
     *,          (TX6(1,LMP2),TX7(1,1))
     *,          (TX7(1,LMP2),TX8(1,1))
     *,          (TX8(1,LMP2),TX9(1,1))
     *,          (TX9(1,LMP2),DPO(1,1))
     *,          (DPO(1,LMP2),SWI(1,1))
     *,          (SWI(1,LMP2),OZL(1,1))
     *,          (OZL(1,LMP2),DNN(1,1))
     *,          (DNN(1,LMP2),UPP(1,1))
     *,          (UPP(1,LMP2),ACC(1,1))
     *,          (ACC(1,LMP2),SSC(1,1))
      EQUIVALENCE(SSC(1,LMP2),RLL(1,1))
     *,          (RLL(1,LMP2),TLL(1,1))
     *,          (TLL(1,LMP2),TAU(1,1))
     *,          (TAU(1,LMP2),GM1(1,1))
     *,          (GM1(1,LMP2),GM2(1,1))
     *,          (GM2(1,LMP2),ALL(1,1))
     *,          (ALL(1,LMP2),AL1(1,1))
     *,          (AL1(1,LMP2),AL2(1,1))
     *,          (AL2(1,LMP2),SOL(1,1))
     *,          (SOL(1,LMP2),AAL(1,1))
     *,          (AAL(1,LMP2),BBL(1,1))
     *,          (BBL(1,LMP2),FLL(1,1))
     *,          (FLL(1,LMP2),ELL(1,1))
     *,          (ELL(1,LMP2),CLL(1,1))
     *,          (CLL(1,LMP2),DLL(1,1))
     *,          (DLL(1,LMP2),TAC(1,1))
     *,          (TAC(1,LMP2),TZ1(1  ))
     *,          (TZ1(M+1   ),TZ2(1  ))
      EQUIVALENCE(TZ2(M+1   ),TZ3(1  ))
     *,          (TZ3(M+1   ),TZ4(1  ))
     *,          (TZ4(M+1   ),TZ5(1  ))
     *,          (TZ5(M+1   ),TZ6(1  ))
     *,          (TZ6(M+1   ),CSM(1  ))
     *,          (CSM(M+1   ),GLL(1  ))
     *,          (GLL(M+1   ),ECN(1  ))
     *,          (ECN(M+1   ),ACN(1  ))
     *,          (ACN(M+1   ),RC1(1  ))
     *,          (RC1(M+1   ),RCO(1  ))
     *,          (RCO(M+1   ),RCG(1  ))
     *,          (RCG(M+1   ),TUT(1  ))
C
      DIMENSION FK(5), XK(5)
      DATA FK/0.107,0.104,0.073,0.044,0.025/
      DATA XK/0.005,0.041,0.416,4.752,72.459/
      DATA IAX/2705/
C
C     SAVE
c     IF((SCRSIZE-10)*IJM0M0 .LT. M*(LMP1*32 + 14) ) THEN
      IF(WKSIZ2*IJM0M0 .LT. M*(LMP1*32 + 14) ) THEN
         PRINT *,'ALLOCATION ERROR IN SOLAR'
         STOP
      ENDIF
      IF (M*LMP1 .GT.   IJM0M0 ) THEN
         PRINT *,'ALLOCATION ERROR IN SHRTWAVE'
         STOP
      ENDIF
C
      DO 10 I=1,M
      TX2(I,1) = PL2(I,1) * (SIG(1)/SIG(2))
      TX1(I,1) = TX2(I,1) * TX2(I,1)
10    CONTINUE
      DO 15 I=1,MLMM0
      TX2(I,2) = PL2(I,1)
      DPO(I,1) = TX2(I,2) - TX2(I,1)
      TX1(I,2) = TX2(I,2) * TX2(I,2)
      SWI(I,1) = TX1(I,2) - TX1(I,1)
15    CONTINUE
C
      DO 30 I=1,MLMM0
      TX2(I,1) = AMAX1(QLO(I,1),WAMIN)
C     WHERE(TX2(1,1;M*LS ).GT.WASTR) TX2(1,1;M*LS ) = WASTR

      SWI(I,1) = SWI(I,1) * TX2(I,1) / (A3*SQRT(TLO(I,1)))
C
      TX1(I,1) = AMAX1(O3O(I,1),O3MIN)
      IF (PL2(I,1) .GT. PNOOZ) TX1(I,1) = ZERO
      TX1(I,1) = A4 * TX1(I,1) * DPO(I,1)
30    CONTINUE
C
      CALL CLDTHK(MLMM0, TLO(1,1), TX2(1,1))
C
      DO 60 I=1,MLMM0
      IF (CLC(I,1).GT.ZERO) TX2(I,1) = CIRTHK
      TAC(I,1) = TX2(I,1) * DPO(I,1)
     *         * (ONE - (ONE - CLC(I,1)) * (ONE - CLU(I,1)))
60    CONTINUE
C
      DO 65 I=1,M
      TUT(I)   = ZERO
      OZL(I,1) = ZERO
65    CONTINUE
      DO 75 L=1,LM
      DO 70 I=1,M
      TUT(I)     = TUT(I)   + TAC(I,L)
      OZL(I,L+1) = OZL(I,L) + TX1(I,L)
70    CONTINUE
75    CONTINUE
C
      DO 100 I=1,M
      CSM(I) = A1 / SQRT(A2*ZTH(I)*ZTH(I) + ONE)
      TZ4(I) = TWO + THREE*ZTH(I)
      TZ5(I) = TWO - THREE*ZTH(I)
C
      TZ2(I) = ALB(I) / (ONE + TUT(I)*B1)
      ECN(I) = -B2 * TUT(I) * CSM(I)
      IF (ECN(I) .LE. EXPMIN) ECN(I) = EXPMIN
C
      ACN(I) = (TZ4(I) + TZ5(I) * EXP(ECN(I))) / (FOUR + TUT(I)*B3)
      RC1(I) = ONE - ACN(I) + ACN(I)*TZ2(I) / (ONE - ALB(I) + TZ2(I))
C
      TZ3(I) = TUT(I) + G0
      GLL(I) = G0 * TUT(I) / TZ3(I)
      TZ3(I) = (ONE-GLL(I)) * TZ3(I)
      TZ2(I) = ALB(I)  / (ONE + TZ3(I) * B4)
      ECN(I) = -TZ3(I) * (ONE+GLL(I)) * CSM(I)
      IF (ECN(I) .LE. EXPMIN) ECN(I) = EXPMIN
C
      ACN(I) = (TZ5(I) * EXP(ECN(I)) + TZ4(I)) / (FOUR + TZ3(I)*THREE)
      RCO(I) = (ONE - ACN(I) + RC1(I)*TWO + ACN(I) * TZ2(I)
     *                       / (ONE - ALB(I) + TZ2(I)) ) * (ONE/THREE)
C
      TZ3(I) =  TUT(I) + B5
      GLL(I) =  G0 * TUT(I) / TZ3(I)
      TZ3(I) =  (ONE-GLL(I)) * TZ3(I)
      TZ2(I) =  ALB(I) / (ONE + TZ3(I)*B4)
      ECN(I) = -TZ3(I) * (ONE+GLL(I)) * CSM(I)
      IF (ECN(I) .LE. EXPMIN) ECN(I) = EXPMIN
C
      ACN(I) = (TZ5(I) * EXP(ECN(I)) + TZ4(I)) / (FOUR + TZ3(I)*THREE)
C
      RCG(I) = ONE - ACN(I) + ACN(I) * TZ2(I) / (ONE - ALB(I) + TZ2(I))
C
      TZ1(I) = RCO(I) * SLR(I)
      TZ2(I) = OZL(I,LMP1) * (C2+CSM(I))

100   CONTINUE
C
      DO 190 L=1,LM
      DO 190 I=1,M
      TX5(I,L) = SLR(I)
      TX6(I,L) = CSM(I)
      TX7(I,L) = TZ2(I)
      TX8(I,L) = TZ1(I)
      TX9(I,L) = ZTH(I)
190   CONTINUE
C
      DO 195 I=1,M
      DNN(I,1) = ZERO
195   CONTINUE
      DO 200 I=1,MLMM0
      TM1      = OZL(I,2) * TX6(I,1)
      TM2      = AZ6*TM1
      DNN(I,2) = TM1 * (AZ3 / (ONE + (AZ1+AZ2*TM1)*TM1)
     *         + AZ5*(ONE + AZ4*TM1) ** EZ1 + AZ7/(ONE + TM2*TM2*TM2))
200   CONTINUE
C
      DO 205 I=1,M
      UPP(I,LMP1) = DNN(I,LMP1)
205   CONTINUE
      DO 210 I=1,MLMM0
      TM1      = TX7(I,1) - OZL(I,1)*C2
      TM2      = AZ6*TM1
      UPP(I,1) = TM1 * (AZ3 / (ONE + (AZ1+AZ2*TM1)*TM1)
     *         + AZ5*(ONE + AZ4*TM1) ** EZ1 + AZ7/(ONE + TM2*TM2*TM2))
210   CONTINUE
C
      DO 215 I=1,MLMM0
      ACC(I,1) = (DNN(I,2) - DNN(I,1)) * TX5(I,1)
     *         + (UPP(I,1) - UPP(I,2)) * TX8(I,1)
      IF (ACC(I,1) .LT. ZERO) ACC(I,1) = ZERO
215   CONTINUE
C
C
      DO 230 I=1,M
      ACC(I,LMP1) = ZERO
      SWD(I) = (ONE - RCG(I))  * SLR(I) * (C3 - DNN(I,LMP1))
      TZ1(I) = (TWO - ZTH(I)*GP) * FOURTH
      TZ2(I) = ONE    - TZ1(I)
230   CONTINUE
C
      DO 1000 IK=1,5
C
      DO 250 I=1,MLMM0
      TAU(I,1) = TAC(I,1) + SWI(I,1)*XK(IK)
      SSC(I,1) = C1*TAC(I,1) / TAU(I,1)
C
      TX1(I,1) = SQRT(ONE-SSC(I,1)*G0)
      TX2(I,1) = SQRT(ONE-SSC(I,1))
C
      TX3(I,1) = TX1(I,1) / TX2(I,1)
      TX1(I,1) = - TX1(I,1) * TX2(I,1) * TAU(I,1) * SQRT(THREE)
250   CONTINUE
C
      CALL EXPMINE(MLMM0, TX1, TX4)
C
      DO 270 I=1,MLMM0
      TX1(I,1) = TX3(I,1) + ONE
      TX2(I,1) = TX3(I,1) - ONE
      TX1(I,1) = TX1(I,1) * TX1(I,1)
      TX2(I,1) = TX2(I,1) * TX2(I,1) * TX4(I,1) * TX4(I,1)
      TX1(I,1) = ONE / (TX1(I,1) - TX2(I,1))
C
      RLL(I,1) = - (TX3(I,1) * TX3(I,1) - ONE)
     *           * (TX4(I,1) * TX4(I,1) - ONE) * TX1(I,1)
      TLL(I,1) = TX3(I,1) * TX4(I,1) * TX1(I,1) * FOUR
C
      TX1(I,1) = ONE - (G0*G0) * SSC(I,1)
      TAU(I,1) = TAU(I,1)  * TX1(I,1)
      SSC(I,1) = SSC(I,1)  * (ONE-G0*G0) / TX1(I,1)
      TX1(I,1) = -TAU(I,1) * TX6(I,1)
270   CONTINUE
C
      CALL EXPMINE(MLMM0, TX1, ELO)
C
      DO 285 I=1,MLMM0
      GM1(I,1) = (SEVEN - SSC(I,1)*(FOUR+GP)) * FOURTH
      GM2(I,1) = -(ONE  - SSC(I,1)*(FOUR-GP)) * FOURTH
      ALL(I,1) = SQRT(GM1(I,1) * GM1(I,1) - GM2(I,1) * GM2(I,1))
285   CONTINUE
C
      DO 295 I=1,M
      SOL(I,1) = SLR(I) * FK(IK)
295   CONTINUE
C
      DO 300 L=1,LM
      DO 300 I=1,M
      SOL(I,L+1) = SOL(I,L) * ELO(I,L)
      TX1(I,L)   = TZ1(I)
      TX2(I,L)   = TZ2(I)
300   CONTINUE
C
      DO 310 I=1,MLMM0
      AL1(I,1) = GM2(I,1) * TX1(I,1) + GM1(I,1) * TX2(I,1)
      AL2(I,1) = GM2(I,1) * TX2(I,1) + GM1(I,1) * TX1(I,1)
      TX3(I,1) = AL2(I,1) * TX9(I,1)
      AAL(I,1) = (TX1(I,1) - TX3(I,1)) * ALL(I,1) * ELO(I,1) * TWO
      BBL(I,1) = (TX2(I,1) + AL1(I,1)*TX9(I,1)) * ALL(I,1) * TWO
C
      TX3(I,1) = ALL(I,1) * TX9(I,1)
      TX7(I,1) = ONE - TX3(I,1)
      TX8(I,1) = ONE + TX3(I,1)
C
      TX3(I,1) = ALL(I,1) * TX1(I,1)
      CLL(I,1) = (AL2(I,1) + TX3(I,1)) * TX7(I,1)
      DLL(I,1) = (AL2(I,1) - TX3(I,1)) * TX8(I,1)
C
      TX3(I,1) =  ALL(I,1) * TX2(I,1)
      FLL(I,1) = (AL1(I,1) + TX3(I,1)) * TX8(I,1)
      ELL(I,1) = (AL1(I,1) - TX3(I,1)) * TX7(I,1)
C
      TX3(I,1) = ALL(I,1) * TX9(I,1)
      TX3(I,1) = ONE - TX3(I,1) * TX3(I,1)
      IF (ABS(TX3(I,1)) .LT. TUMIN) TX3(I,1) = TUMIN
C
      TX1(I,1) = - ALL(I,1) * TAU(I,1)
310   CONTINUE
C
      CALL EXPMINE(MLMM0, TX1, TX2)
C
      DO 365 I=1,MLMM0
      TX4(I,1) = TX2(I,1) * TX2(I,1)
      TX1(I,1) = (ALL(I,1) - GM1(I,1)) * TX4(I,1) + ALL(I,1) + GM1(I,1)
      TX1(I,1) = SOL(I,1) * SSC(I,1) / (TX1(I,1) * TX3(I,1))
C
      TX7(I,1) = (CLL(I,1) - DLL(I,1) * TX4(I,1) - AAL(I,1) * TX2(I,1))
     *                                           * TX1(I,1)
C
      TX3(I,1) = BBL(I,1)*TX2(I,1)
      TX8(I,2) = -TX1(I,1)
     *         * ((FLL(I,1) - ELL(I,1)*TX4(I,1)) * ELO(I,1) - TX3(I,1))
365   CONTINUE
C
      DO 380 I=1,M
      TX7(I,LMP1) = ALB(I)*SOL(I,LMP1)
      RLL(I,LMP1) = ALB(I)
      TX8(I,1)    = ZERO
380   CONTINUE
C
      DO 385 I=1,MLMP1
      IF (RLL(I,1) .LT. ZERO) RLL(I,1) = ZERO
      IF (TLL(I,1) .LT. ZERO) TLL(I,1) = ZERO
      IF (TX7(I,1) .LT. ZERO) TX7(I,1) = ZERO
      IF (TX8(I,1) .LT. ZERO) TX8(I,1) = ZERO
      IF (SOL(I,1) .LT. ZERO) SOL(I,1) = ZERO
385   CONTINUE
C
      DO 390 I=1,M
      AL1(I,1) = ZERO
      AL2(I,1) = ONE
      BBL(I,1) = ZERO
      AAL(I,1) = TX7(I,1)
390   CONTINUE
      DO 395 I=1,MLMM0
      TX1(I,1) = TLL(I,1)*TLL(I,1)
395   CONTINUE
C
      DO 400 L=1,LM
      DO 400 I=1,M
      AL1(I,L+1) = AL1(I,L) * AL2(I,L) * TX1(I,L) + RLL(I,L)
      AL2(I,L+1) = ONE / (ONE - AL1(I,L+1) * RLL(I,L+1))
400   CONTINUE
C
      DO 550 I=1,MLMM0
      TX2(I,1) = AL1(I,1) * TX7(I,1)
      TX3(I,1) = AL2(I,1) * TLL(I,1)
550   CONTINUE
C
      DO 600 L=1,LM
      DO 600 I=1,M
      BBL(I,L+1) = (BBL(I,L) + TX2(I,L)) * TX3(I,L) + TX8(I,L+1)
600   CONTINUE
C
      DO 610 I=1,MLMM0
      AAL(I,2) = AL2(I,2) * (BBL(I,2) * RLL(I,2) + TX7(I,2))
610   CONTINUE
C
      DO 620 I=1,M
      ULL(I,LMP1) = AAL(I,LMP1)
      DLL(I,LMP1) = AL1(I,LMP1)*ULL(I,LMP1) + BBL(I,LMP1) + SOL(I,LMP1)
      ACC(I,LMP1) = ACC(I,LMP1) +  DLL(I,LMP1) - ULL(I,LMP1)
620   CONTINUE
C
      DO 630 I=1,MLMM0
      TX1(I,1) = TLL(I,1) * AL2(I,1)
630   CONTINUE
      DO 700 L=LM,1,-1
      DO 700 I=1,M
      ULL(I,L) = ULL(I,L+1) * TX1(I,L) + AAL(I,L)
700   CONTINUE
C
      DO 710 I=1,MLMM0
      TX1(I,1) = AL1(I,1) * ULL(I,1)
      DLL(I,1) = SOL(I,1) + TX1(I,1) + BBL(I,1)
710   CONTINUE
C
      DO 720 I=1,MLMP1
      TX1(I,1) = DLL(I,1) - ULL(I,1)
720   CONTINUE
      DO 730 I=1,MLMM0
      ACC(I,1) = ACC(I,1) + TX1(I,1) - TX1(I,2)
730   CONTINUE
C
1000  CONTINUE
C
      DO 1010 I=1,M
      SWD(I) = SWD(I) + ACC(I,LMP1)
      SWN(I) = SWD(I)
1010  CONTINUE
      DO 1020 L=1,LM
      DO 1020 I=1,M
      SWN(I) = SWN(I) + ACC(I,L)
1020  CONTINUE
      DO 1050 I=1,MLMM0
      SWF(I,1) = ACC(I,1) / DPO(I,1) * (GRAV/(CMB2PA*CP))
1050  CONTINUE
C
      RETURN
      END
      SUBROUTINE EXPMINE(LEN, FIN, FOU)
C
C
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C******************* SUBROUTINE EXPMINE  *****************************
C**********************   NOVEMBER 1990 ******************************
C*********************************************************************
C
C
      PARAMETER (ONE=1.0, EXPMIN=-10.0)
      DIMENSION ECOF(4)
      DATA ECOF/1., -2.507213E-1, 2.92732E-2, -3.8278E-3/
      DIMENSION FIN(LEN), FOU(LEN)
C
      DO 10 I=1,LEN
      IF (FIN(I) .LT. EXPMIN) FIN(I) = EXPMIN
      FOU(I) = ((ECOF(4)*FIN(I) + ECOF(3)) * FIN(I) + ECOF(2))
     *                                              * FIN(I) + ECOF(1)
      FOU(I) = FOU(I) * FOU(I)
      FOU(I) = ONE / (FOU(I) * FOU(I))
   10 CONTINUE
C
      RETURN
      END
      SUBROUTINE CLDTHK(LEN, TLO, CLDT)
C
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C******************** FUNCTION    CLDTHK  ****************************
C********************** 26 AUGUST  1987 ******************************
C*********************************************************************
C
C
C*** COMMENTED ON 02/22/89
      PARAMETER (ZERO=0.0,      TICE=273.16)
      PARAMETER (TC1=TICE-82.5, TC2=TICE-10.0, TC3=TICE)
      PARAMETER (CFC=2.E-6,     BFC=8.E-2)
      PARAMETER (EMX=CFC*(TC1-TC2)*(TC1-TC2))
      PARAMETER (CC1=EMX/(TC2-TC3), CC2=BFC/(TC2-TC3))
      DIMENSION TLO(LEN), CLDT(LEN)
C
C     SAVE
C
      DO 10 I=1,LEN
      CLDT(I) = TLO(I) - TC1
      IF (CLDT(I) .LT. ZERO) CLDT(I) = ZERO
      CLDT(I) = CLDT(I)*CLDT(I)*CFC
      IF (CLDT(I) .GT. EMX)
     *    CLDT(I) = (TLO(I)-TC3)*CC1 + (TC2-TLO(I))*CC2
      IF (CLDT(I) .GT. BFC) CLDT(I) = BFC
   10 CONTINUE
C
C***CHANGED ON 04/14/89
C
C     PARAMETER (TC1=263.0, TC2=253.0)
C     PARAMETER (CMX=0.08,  CMM=0.010, CBT=(CMX-CMM)/(TC1-TC2))
C
C     DESCRIPTOR TLO, CLDTHK
C
C     SAVE
C
C     CLDTHK = CMM + (TLO - TC2) * CBT
C     WHERE (CLDTHK .GT. CMX) CLDTHK = CMX
C     WHERE (CLDTHK .LT. CMM) CLDTHK = CMM
C
      RETURN
      END
      SUBROUTINE LONGWAVE(
C  RUN, RISE, AND INNER DIMENSION
     *       M,LL,IDIM
C  INPUTS
     *,      TLO, QLO, O3O, PLE, CLR, CLL
     *,      SAT,SFT,OZNE
C  OUTPUTS
     *,       FLX, FLC, ST4
C  SCRATCH
     *,      WORK)
C **********************************************************************
C    This cover for LONGIN facilitates the passing of scratch space.
C **********************************************************************


      DIMENSION TLO(IDIM,LL), QLO(IDIM,LL), O3O(IDIM,LL), SAT(M)
      DIMENSION PLE(IDIM,LL), CLR(IDIM,LL), CLL(IDIM,LL), SFT(M)
      LOGICAL   OZNE

      DIMENSION FLX(IDIM,LL+1), FLC(IDIM,LL+1), ST4(M)

      DIMENSION  WORK(M,LL+2,25)

      CALL LONGIN(M, LL, IDIM
     *,      TLO, QLO, O3O, PLE, CLR, CLL
     *,      SAT, SFT, OZNE
     *,      FLX, FLC, ST4
     *,      WORK(1,1, 1), WORK(1,1, 2), WORK(1,1, 3), WORK(1,1, 4)
     *,      WORK(1,1, 5), WORK(1,1, 6), WORK(1,1, 7), WORK(1,1, 8)
     *,      WORK(1,1, 9), WORK(1,1,10), WORK(1,1,11), WORK(1,1,12)
     *,      WORK(1,1,13), WORK(1,1,14), WORK(1,1,15), WORK(1,1,16)
     *,      WORK(1,1,17), WORK(1,1,18), WORK(1,1,19), WORK(1,1,20)
     *,      WORK(1,1,21), WORK(1,1,22), WORK(1,1,23), WORK(1,1,24)
     *,      WORK(1,1,25)  )

      RETURN
      END

      SUBROUTINE LONGIN (M, LL, IDIM
     *,          TLO, QLO, O3O, PLE, CLR, CLL
     *,          SAT, SFT, OZNE
     *,          FLX, FLC, ST4
     *,          TLE, TV1, TV2, TV3, TV4, TY1, TY2, TY3, TY4, TY5
     *,          TY6, X1,  X2,  X3,  X4,  UBR, VBR, WBR, PCV, PCW
     *,          WVO, OUR, OVR, CLU, CLO)

C*********************************************************************
C******************* SUBROUTINE   LONGWAVE ***************************
C********************** 13  MARCH  1989 ******************************
C*********************************************************************

C  INPUTS--These are not modified by the package.

C    TLO(IDIM,LL)   :  Layer temperatures (K)
C    QLO(IDIM,LL)   :  Layer specific humidities
C    O3O(IDIM,LL)   :  Layer ozone mixing ratios. Ignored if OZNE=FALSE.
C    OZNE           :  Logical flag.
C    PLE(IDIM,LL)   :  Pressure at the base of each layer. (mb)
C                         The code assumes the top pressure is zero.
C                         PLE(*,LL) is the surface pressure.
C    CLR(IDIM,LL)   :  Random overlap cloud fraction at each layer.
C    CLL(IDIM,LL)   :  Maximum overlap cloud fraction at each layer.
C    SAT(M)         :  Surface-air temperature (K).
C    SFT(M)         :  Surface temperature (K).

C    M              :  Number of soundings done on each call. (run)
C    LL             :  Number of layers in each sounding.     (rise)
C    IDIM           :  Inner dimension of arguments.          (>=M)


C SCRATCH SPACE--

C   TLE - CLO    : 25 work arrays DIMENSIONed (M,LL+1) OR (M,LL+2)


C  OUTPUT--These are fully defined by LONGWAVE.


C    FLX(IDIM,LL+1) :  Net downward flux. Cloudy. (1=top)  (w/m**2)
C    FLC(IDIM,LL+1) :  Net downward flux. Clear.  (1=top)  (w/m**2)
C    ST4(M)         :  Upward flux at the surface          (w/m**2)


      PARAMETER (ZERO=0., ONE=1., HALF=.5)

      PARAMETER (CO2=330.,         CIRTHK=.16             )
      PARAMETER (CNV=10.0/9.81,    CMB2PA=100.            )
      PARAMETER (QMIN=1.E-20,      O3MIN=1.E-20           )
      PARAMETER (TREF=250.,        TREFCO2=240.           )
      PARAMETER (TRCNT=225.,       RCNT=.005,  PRCNT=275. )
      PARAMETER (TRWNG=256.,       RWNG=.016,  PRWNG=550. )
      PARAMETER (D1=1800.,         D2=6.08,     D3=642.   )
c     PARAMETER (D4=(2.32143E-4*TREF**0.5)*0.5            )
      PARAMETER (R1=.0089,         R2=.025                )
      PARAMETER (P1=ONE/30.,       P2=ONE/300., PC=2.0    )
      PARAMETER (PCH2C=ONE,        PCH2W=15.              )
      PARAMETER (FCO2=.26*CO2/330.                        )
      PARAMETER (CLBET=.75,        ATM=1013.25            )

C  INPUTS

      DIMENSION TLO(IDIM,LL), QLO(IDIM,LL), O3O(IDIM,LL), SAT(M)
      DIMENSION PLE(IDIM,LL), CLR(IDIM,LL), CLL(IDIM,LL), SFT(M)
      LOGICAL   OZNE

C  OUTPUTS

      DIMENSION FLX(IDIM,LL+1), FLC(IDIM,LL+1), ST4(M)

C  SCARTCH SIZE = (25*(LL+1)+2)*M

      DIMENSION
     *  TLE(M,LL+2), TV1(M,LL+2), TV2(M,LL+2), TV3(M,LL+2), TV4(M,LL+2)
     *, TY1(M,LL+1), TY2(M,LL+1), TY3(M,LL+1), TY4(M,LL+1), TY5(M,LL+1)
     *, TY6(M,LL+1),  X1(M,LL+1),  X2(M,LL+1),  X3(M,LL+1),  X4(M,LL+1)
     *, UBR(M,LL+1), VBR(M,LL+1), WBR(M,LL+1), PCV(M,LL+1), PCW(M,LL+1)
     *, WVO(M,LL+1), OUR(M,LL+1), OVR(M,LL+1), CLU(M,LL  ), CLO(M,LL  )


      COMMON/TM/ TIME, GFUT, TRCT,TCO3, PREP
      REAL TIME, GFUT, TRCT,TCO3, PREP

      DIMENSION B1(5),B2(5),B3(5),B4(5)

      DATA B1 /4.6255E1, 5.7048E-1, 4.2093E-3, 2.4271E-5, 5.708E-8/
      DATA B2 /9.9988E1, 1.6930E-0, 1.0623E-2, 2.9373E-5, 3.046E-8/
      DATA B3 /1.2791E1, 3.0606E-1, 2.4403E-3, 4.9731E-6,-1.475E-8/
      DATA B4 /6.2523E1, 9.7524E-1, 3.9791E-3,-2.4060E-6,-1.996E-8/

C     SAVE

C     CALL CLKON
      D4 = (2.32143E-4*TREF**0.5)*0.5

      MLLM0 = M *  LL
      MLLM1 = M * (LL-1)
      MLLP1 = M * (LL+1)
      MLLP2 = M * (LL+2)

C********************************************************************
C***** PRELIMINARIES  ***********************************************
C********************************************************************

      DO 10 L=1,LL
      DO 10 I=1,M
      TY5(I,L) = QLO(I,L)
      TY6(I,L) = O3O(I,L)
      X1(I,L)  = TLO(I,L)
10    CONTINUE
C
      DO 15 I=1,MLLM0
      IF (TY5(I,1) .LT. QMIN)  TY5(I,1) = QMIN
      IF (TY6(I,1) .LT. O3MIN) TY6(I,1) = O3MIN
15    CONTINUE

C  PLO==> X2    AND   DPO==> X3,  TEMPORARILY.

      DO 20 I=1,M
      X2(I,1) = PLE(I,1)*HALF
      X3(I,1) = PLE(I,1)*CNV
C
      TLE(I,1)    = X1(I,1)
      TLE(I,LL+1) = SAT(I)
      TLE(I,LL+2) = SFT(I)
20    CONTINUE
C
      DO 30 L=1,LL-1
      DO 25 I=1,M
      X2(I,L+1) = (PLE(I,L+1) + PLE(I,L)) * HALF
      X3(I,L+1) = (PLE(I,L+1) - PLE(I,L)) * CNV
C     TY1(I,L)  =   X2(I,L)   / PLE(I,L)
C
C**** TEMPERATURE INTERPOLATION - IN P  ***********
C
      TLE(I,L+1) = ( (X2(I,L) - PLE(I,L))    * TLO(I,L+1)
     *             + (PLE(I,L) -  X2(I,L+1)) * TLO(I,L) )
     *                                       / (X2(I,L) - X2(I,L+1))
25    CONTINUE
30    CONTINUE
C
C
C**** TEMPERATURE INTERPOLATION - IN LOGP  **********
C
C     TY1(1,1;MLLM1) = VLOG(TY1(1,1;MLLM1);MLLM1)
C     TY2(1,1;MLLM1) = X2(1,1;MLLM1) / X2(1,2;MLLM1)
C     TY2(1,1;MLLM1) = VLOG(TY2(1,1;MLLM1);MLLM1)
C     TY1(1,1;MLLM1) = TY1(1,1;MLLM1) / TY2(1,1;MLLM1)
C     TY2(1,1;MLLM1) = ONE            - TY1(1,1;MLLM1)
C
C     TY1(1,1;MLLM1) = TY1(1,1;MLLM1) *  X1(1,2;MLLM1)
C     TY2(1,1;MLLM1) = TY2(1,1;MLLM1) *  X1(1,1;MLLM1)
C     TLE(1,2;MLLM1) = TY1(1,1;MLLM1) + TY2(1,1;MLLM1)
C
      DO 40 I=1,MLLP2
      TLE(I,1) = TLE(I,1) - TREF
40    CONTINUE
C
C****** CLOUD EMISSIVITIES *******************
C
      CALL CLDTHK(MLLM0, X1(1,1), TY1(1,1))
      DO 45 I=1,MLLM0
      TY1(I,1) = TY1(I,1) * CLBET
45    CONTINUE

      DO 50 L=1,LL
      DO 50 I=1,M
      IF (CLL(I,L) .GT. ZERO) TY1(I,L) = CIRTHK*CLBET
50    CONTINUE

      DO 55 I=1,MLLM0
      TY1(I,1) = ONE - EXP(- TY1(I,1)*X3(I,1))
55    CONTINUE

      DO 60 L=1,LL
      DO 60 I=1,M
      CLU(I,L) = ONE - CLR(I,L) * TY1(I,L)
      CLO(I,L) = ONE - CLL(I,L) * TY1(I,L)
60    CONTINUE

C***** SCALED ABSORBER AMOUNTS *****************

C
C  CO2
C
      DO 100 I=1,MLLM0
      TY4(I,1) = X3(I,1) * FCO2
C
C  CENTER
C
      TY1(I,1) = AMAX1(X2(I,1),PC) * P1
      PCV(I,2) = EXP((X1(I,1) - TREFCO2) * R1)
     *         * TY4(I,1) * TY1(I,1) ** 0.85
C
C  WINGS
C
      TY1(I,1) = AMAX1(X2(I,1),PC) * P2
      PCW(I,2) = EXP((X1(I,1) - TREFCO2)*R2) * SQRT(TY1(I,1)) * TY4(I,1)
70    CONTINUE
C
C   H2O
C
      TY4(I,1) = TY5(I,1)*X3(I,1)
C
C   CENTER
C
      TY1(I,1) = AMAX1(X2(I,1),PCH2C)
C
      VBR(I,2) = EXP((X1(I,1) - TRCNT) * RCNT)
     *         * TY4(I,1) * TY1(I,1) * (ONE/PRCNT)
C
C   WINGS
C
      TY1(I,1) = AMAX1(X2(I,1),PCH2W)
      WBR(I,2) = EXP((X1(I,1) - TRWNG) * RWNG)
     *         * TY4(I,1) * TY1(I,1) * (ONE/PRWNG)
C
C   E-TYPE
C
      UBR(I,2) = EXP(D1 / X1(I,1) - D2) * TY4(I,1) * TY5(I,1)
     *                                  * X2(I,1) * (ONE/D3)
100   CONTINUE

C
C   OZONE
C
      IF (OZNE) THEN
         DO 135 I=1,MLLM0
         TY1(I,1) = D4 + X1(I,1)*(D4/TREF) + X2(I,1)*(ONE/ATM)
         OVR(I,2) = TY6(I,1) * X3(I,1)
         OUR(I,2) = OVR(I,2) * TY1(I,1)
135      CONTINUE
      ELSE
         DO 140 I=1,MLLM0
         OUR(I,2) = O3MIN
         OVR(I,2) = O3MIN
140      CONTINUE
      ENDIF

C***** INTEGRATE SCALED ABSORBER AMOUNTS FROM T.O.A. TO LAYER BASES ***

      DO 145 I=1,M
      UBR(I,1) = ZERO
      VBR(I,1) = ZERO
      WBR(I,1) = ZERO
      PCV(I,1) = ZERO
      PCW(I,1) = ZERO
      OUR(I,1) = ZERO
      OVR(I,1) = ZERO
145   CONTINUE
C

      DO 160 L=3,LL+1
      DO 150 I=1,M
      UBR(I,L) = UBR(I,L-1) + UBR(I,L)
      VBR(I,L) = VBR(I,L-1) + VBR(I,L)
      WBR(I,L) = WBR(I,L-1) + WBR(I,L)
      PCV(I,L) = PCV(I,L-1) + PCV(I,L)
      PCW(I,L) = PCW(I,L-1) + PCW(I,L)
      OUR(I,L) = OUR(I,L-1) + OUR(I,L)
      OVR(I,L) = OVR(I,L-1) + OVR(I,L)
150   CONTINUE
160   CONTINUE
C     PRINT *,' UBR=',(UBR(147,L),L=1,LL)
C     PRINT *,' VBR=',(VBR(147,L),L=1,LL)
C     PRINT *,' WBR=',(WBR(147,L),L=1,LL)
C     PRINT *,' PCV=',(PCV(147,L),L=1,LL)
C     PRINT *,' PCW=',(PCW(147,L),L=1,LL)
C     PRINT *,' OUR=',(OUR(147,L),L=1,LL)
C
C***** PLANCK FUNCTIONS ********************************************
C
Cfeb5 CALL POLY(TV1,TLE,B1,5,MLLP2)
Cfeb5 CALL POLY(TV2,TLE,B2,5,MLLP2)
Cfeb5 CALL POLY(TV3,TLE,B3,5,MLLP2)
Cfeb5 CALL POLY(TV4,TLE,B4,5,MLLP2)
C
      DO 162 I=1,MLLP2
      TV1(I,1) = (((B1(5)*TLE(I,1) + B1(4))*TLE(I,1) + B1(3))*TLE(I,1)
     *                             + B1(2))*TLE(I,1) + B1(1)
      TV2(I,1) = (((B2(5)*TLE(I,1) + B2(4))*TLE(I,1) + B2(3))*TLE(I,1) 
     *                             + B2(2))*TLE(I,1) + B2(1)
      TV3(I,1) = (((B3(5)*TLE(I,1) + B3(4))*TLE(I,1) + B3(3))*TLE(I,1) 
     *                             + B3(2))*TLE(I,1) + B3(1)
      TV4(I,1) = (((B4(5)*TLE(I,1) + B4(4))*TLE(I,1) + B4(3))*TLE(I,1) 
     *                             + B4(2))*TLE(I,1) + B4(1)
  162 CONTINUE

C     CALL CLKOF(PREP)
C
C********************************************************************
C***** START TRANSFER CALCULATION  **********************************
C********************************************************************
C
      DO 170 L=1,LL+1
      DO 165 I=1,M
      FLX(I,L) = ZERO
      FLC(I,L) = ZERO
165   CONTINUE
170   CONTINUE

C****** UPPER BOUNDARY ***************

C   H2O CENTER

      DO 175 I=1,MLLM0
      X2(I,1) = VBR(I,2)
175   CONTINUE

      CALL GFUN2(X2, WVO, X1, X3, TY1, MLLM0)

      DO 22 L=1,LL
      DO 180 I=1,M
      TY2(I,L) = TLE(I,1)
      TY3(I,L) = TV1(I,1)
180   CONTINUE
22    CONTINUE

      DO 185 I=1,MLLM0
      TY1(I,1) = (X3(I,1) * TY2(I,1) + X1(I,1)) * TY2(I,1) + ONE
      TY5(I,1) = TY1(I,1) * TY3(I,1) * WVO(I,1)
185   CONTINUE
C     PRINT *,' 185TY5=',(TY5(147,L),L=1,LL)

C    H2O WINGS

      DO 190 I=1,MLLM0
      X1(I,1) = UBR(I,2)
      X3(I,1) = WBR(I,2)
190   CONTINUE

      CALL GFUN1(X1,X3,WVO, X2, X4, TY1, MLLM0)

      DO 24 L=1,LL
      DO 195 I=1,M
      TY2(I,L) = TLE(I,1)
      TY3(I,L) = TV2(I,1)
195   CONTINUE
24    CONTINUE

      DO 200 I=1,MLLM0
      TY5(I,1) = TY5(I,1) + TY3(I,1) * WVO(I,1)
     *         * ((X4(I,1)  * TY2(I,1) + X2(I,1)) * TY2(I,1) + ONE)
200   CONTINUE
C     PRINT *,' 200TY5=',(TY5(147,L),L=1,LL)

C   9.6 MICRON

      DO 210 I=1,MLLM0
      X2(I,1) = OUR(I,2)
      X4(I,1) = OVR(I,2)
210   CONTINUE

      CALL TRO3(X1,X2,X4,WVO,TY1,OZNE,MLLM0)

      DO 220 L=1,LL
      DO 215 I=1,M
      TY2(I,L) = TV3(I,1) * WVO(I,L)
215   CONTINUE
220   CONTINUE
C     PRINT *,' 220TY2',(TY2(147,L),L=1,LL)
C     PRINT *,' 220TV3',(TV3(147,L),L=1,LL)
C     PRINT *,' 220WVO',(WVO(147,L),L=1,LL)

C   15 MICRON

      DO 225 I=1,MLLM0
      X2(I,1) = PCV(I,2)
      X4(I,1) = PCW(I,2)
225   CONTINUE

      CALL TRCO2(X2,X4,X3,X1,WVO,TY1,MLLM0)

      DO 32 L=1,LL
      DO 230 I=1,M
      TY2(I,L) = TY2(I,L) + TV4(I,1) * WVO(I,L)
230   CONTINUE
32    CONTINUE
C     PRINT *,' 230TY2',(TY2(147,L),L=1,LL)
C     PRINT *,' 230TY4',(TY4(147,L),L=1,LL)
C     PRINT *,' 230WVO',(WVO(147,L),L=1,LL)
C
C  GATHER ALL FOUR CONTRIBUTIONS
C
      DO 235 I=1,MLLM0
      TY2(I,1) = TY2(I,1) + TY5(I,1)
235   CONTINUE
C     PRINT *,' 235TY2',(TY2(147,L),L=1,LL)
C     PRINT *,' 235TY5',(TY5(147,L),L=1,LL)

C  PROBABILITY OF A CLEAR LINE OF SIGHT (TY5)

      DO 240 I=1,M
      TY5(I,1) = ONE
      TY1(I,1) = ONE
240   CONTINUE
C
      DO 250 L=1,LL
      DO 250 I=1,M
      TY5(I,L+1) = TY5(I,L) * CLU(I,L)
      TY1(I,L+1) = TY1(I,L)
      IF (TY1(I,L+1) .GT. CLO(I,L)) TY1(I,L+1) = CLO(I,L)
250   CONTINUE
      DO 260 I=1,MLLM0
      TY5(I,2) = TY5(I,2) * TY1(I,2)
260   CONTINUE
C     PRINT *,' 260TY5',(TY5(147,L),L=1,LL)
C
C   ADD TO FLUXES
C
      DO 265 L=1,LL
      DO 265 I=1,M
      FLC(I,L+1) = FLC(I,L+1) - TY2(I,L)
      FLX(I,L+1) = FLX(I,L+1) - TY2(I,L) * TY5(I,L+1)
265   CONTINUE
C     PRINT *,' 265FLX',(FLX(147,L),L=1,LL)
C
C****** SURFACE *******************
C
C  H20 CENTER

      DO 270 L=1,LL
      DO 270 I=1,M
      X2(I,L) = VBR(I,LL+1) - VBR(I,L)
270   CONTINUE

      CALL GFUN2(X2, WVO, X1, X3, TY1, MLLM0)

C  SKIN TEMPTERATURE CONTRIBUTION

      DO 275 L=1,LL
      DO 275 I=1,M
      TY2(I,L) = TLE(I,LL+2)
      TY1(I,L) = TV1(I,LL+2)
C
      TY3(I,L) = TV1(I,LL+1)
      TY4(I,L) = TLE(I,LL+1)
275   CONTINUE

      DO 280 I=1,MLLM0
      TY6(I,1) = - ((X3(I,1)  * TY2(I,1) + X1(I,1)) * TY2(I,1) + ONE)
     *                                              * TY1(I,1)*WVO(I,1)
C
C  SURFACE AIR TEMPERATURE CONTRIBUTION
C
     *         +  TY3(I,1) * WVO(I,1)
     *         * ((X3(I,1) * TY4(I,1) + X1(I,1)) * TY4(I,1) + ONE)
280   CONTINUE
C
C  H2O WINGS
C
      DO 300 L=1,LL
      DO 300 I=1,M
      X1(I,L) = UBR(I,LL+1) - UBR(I,L)
      X3(I,L) = WBR(I,LL+1) - WBR(I,L)
C
      TY2(I,L) = TLE(I,LL+2)
      TY3(I,L) = TV2(I,LL+2)
C
      TY4(I,L) = TLE(I,LL+1)
      TY5(I,L) = TV2(I,LL+1)
300   CONTINUE

      CALL GFUN1(X1,X3,WVO, X2, X4, TY1, MLLM0)



      DO 320 I=1,MLLM0
C
C  SKIN TEMPTERATURE CONTRIBUTION
C
      TY6(I,1) = TY6(I,1) - TY3(I,1) * WVO(I,1)
     *         * ((X4(I,1) * TY2(I,1) + X2(I,1)) * TY2(I,1) + ONE)
C
C  SURFACE AIR TEMPTERATURE CONTRIBUTION
C
     *         + TY5(I,1) * WVO(I,1)
     *         * ((X4(I,1) * TY4(I,1) + X2(I,1)) * TY4(I,1) + ONE)
320   CONTINUE

C     PRINT *,' 330TY6',(TY6(147,L),L=1,LL)
C
C  9.6 MICRON
C
      DO 335 L=1,LL
      DO 335 I=1,M
      X2(I,L) = OUR(I,LL+1) - OUR(I,L)
      X4(I,L) = OVR(I,LL+1) - OVR(I,L)
335   CONTINUE

      CALL TRO3(X1,X2,X4,WVO,TY1,OZNE,MLLM0)

      DO 340 I=1,M
      TY3(I,LL+1) = TV3(I,LL+2) - TV3(I,LL+1)
340   CONTINUE

      DO 350 L=1,LL
      DO 345 I=1,M
      TY2(I,L) = TY3(I,LL+1) * WVO(I,L)
345   CONTINUE
350   CONTINUE

C   15 MICRON

      DO 355 L=1,LL
      DO 355 I=1,M
      X2(I,L) = PCV(I,LL+1) - PCV(I,L)
      X4(I,L) = PCW(I,LL+1) - PCW(I,L)
355   CONTINUE

      CALL TRCO2(X2,X4,X3,X1,WVO,TY1,MLLM0)

      DO 360 I=1,M
      TY2(I,LL+1) = TV4(I,LL+2) - TV4(I,LL+1)
360   CONTINUE

      DO 365 L=1,LL
      DO 365 I=1,M
      TY2(I,L) = TY2(I,L) + TY2(I,LL+1) * WVO(I,L)
365   CONTINUE

C  GATHER ALL FOUR CONTRIBUTIONS

      DO 370 I=1,MLLM0
      TY6(I,1) = TY6(I,1) - TY2(I,1)
370   CONTINUE

C  PROBABILITY OF A CLEAR LINE OF SIGHT (TY2)

      DO 375 I=1,M
      TY2(I,LL+1) = ONE
      TY1(I,LL+1) = ONE
375   CONTINUE
C
      DO 390 L=1,LL
      DO 380 I=1,M
      TY2(I,LL+1-L) = TY2(I,LL+2-L) * CLU(I,LL+1-L)
      TY1(I,LL+1-L) = TY1(I,LL+2-L)
380   CONTINUE
      DO 385 I=1,M
      IF (TY1(I,LL+1-L) .GT. CLO(I,LL+1-L))
     *    TY1(I,LL+1-L) = CLO(I,LL+1-L)
385   CONTINUE
390   CONTINUE
C
      DO 395 I=1,MLLM0
      TY2(I,1) = TY2(I,1) * TY1(I,1)
395   CONTINUE

C   ADD TO FLUXES

C     PRINT *,' BEF400FLX',(FLX(147,L),L=1,LL)
      DO 400 L=1,LL
      DO 400 I=1,M
      FLC(I,L) = FLC(I,L) + TY6(I,L)
      FLX(I,L) = FLX(I,L) + TY6(I,L) * TY2(I,L)
400   CONTINUE
C     PRINT *,' 400FLX',(FLX(147,L),L=1,LL)
C     PRINT *,' 400TY6',(TY6(147,L),L=1,LL)
C     PRINT *,' 400TY2',(TY2(147,L),L=1,LL)
C
C**** EXCHANGE INTEGRAL **********
C
      DO 600 L=1,LL


C  H20 CENTER

      DO 405 I=1,M
      TY1(I,2) = HALF * (VBR(I,L) + VBR(I,L+1))
405   CONTINUE

      DO 410 K=1,L
      DO 410 I=1,M
      X2(I,K) = TY1(I,2) - VBR(I,K)
410   CONTINUE
      DO 415 K=L+1,LL+1
      DO 415 I=1,M
      X2(I,K) = VBR(I,K) - TY1(I,2)
415   CONTINUE

      DO 420 K=1,LL+1
      DO 420 I=1,M
      TY2(I,K) = TLE(I,L)
      TY3(I,K) = TLE(I,L+1)
420   CONTINUE

      CALL GFUN2(X2, WVO, X1, X3, TY4, MLLP1)

      DO 430 K=1,LL+1
      DO 430 I=1,M
      TY6(I,K) = TV1(I,L)
      TY5(I,K) = TV1(I,L+1)
430   CONTINUE

      DO 440 I=1,MLLP1
      TY4(I,1) = ((X3(I,1) * TY2(I,1) + X1(I,1)) * TY2(I,1) + ONE)
     *                                           * WVO(I,1) * TY6(I,1)
     *         - ((X3(I,1) * TY3(I,1) + X1(I,1)) * TY3(I,1) + ONE)
     *                                           * WVO(I,1) * TY5(I,1)
440   CONTINUE

C  H2O WINGS

      DO 445 I=1,M
      TY1(I,1) = HALF * (UBR(I,L) + UBR(I,L+1))
      TY1(I,3) = HALF * (WBR(I,L) + WBR(I,L+1))
445   CONTINUE

      DO 450 K=1,L
      DO 450 I=1,M
      X1(I,K) = TY1(I,1) - UBR(I,K)
      X3(I,K) = TY1(I,3) - WBR(I,K)
450   CONTINUE
      DO 460 K=L+1,LL+1
      DO 460 I=1,M
      X1(I,K) = UBR(I,K) - TY1(I,1)
      X3(I,K) = WBR(I,K) - TY1(I,3)
460   CONTINUE

      CALL GFUN1(X1,X3,WVO, X2, X4, TY1, MLLP1)

      DO 475 K=1,LL+1
      DO 475 I=1,M
      TY6(I,K) = TV2(I,L)
      TY5(I,K) = TV2(I,L+1)
475   CONTINUE

      DO 480 I=1,MLLP1
      TY4(I,1) = TY4(I,1)
     *         + ((X4(I,1) * TY2(I,1) + X2(I,1)) * TY2(I,1) + ONE)
     *                                           * WVO(I,1) * TY6(I,1)
     *         - ((X4(I,1) * TY3(I,1) + X2(I,1)) * TY3(I,1) + ONE)
     *                                           * WVO(I,1) * TY5(I,1)
480   CONTINUE

C  9.6 MICRON

      DO 490 I=1,M
      TY2(I,3) = HALF * (OUR(I,L) + OUR(I,L+1))
      TY3(I,1) = HALF * (OVR(I,L) + OVR(I,L+1))
490   CONTINUE

      DO 495 K=1,L
      DO 495 I=1,M
      X2(I,K) = TY2(I,3) - OUR(I,K)
      X4(I,K) = TY3(I,1) - OVR(I,K)
495   CONTINUE
      DO 500 K=L+1,LL+1
      DO 500 I=1,M
      X2(I,K) = OUR(I,K) - TY2(I,3)
      X4(I,K) = OVR(I,K) - TY3(I,1)
500   CONTINUE

      CALL TRO3(X1,X2,X4,WVO,TY1,OZNE,MLLP1)

      DO 505 K=1,LL+1
      DO 505 I=1,M
      TY3(I,K) = TV3(I,L) - TV3(I,L+1)
505   CONTINUE

      DO 510 I=1,MLLP1
      TY4(I,1) = TY4(I,1) + TY3(I,1) * WVO(I,1)
510   CONTINUE

C  15. MICRON

      DO 515 I=1,M
      TY2(I,1) = HALF * (PCV(I,L) + PCV(I,L+1))
      TY2(I,2) = HALF * (PCW(I,L) + PCW(I,L+1))
515   CONTINUE

      DO 520 K=1,L
      DO 520 I=1,M
      X2(I,K) = TY2(I,1) - PCV(I,K)
      X4(I,K) = TY2(I,2) - PCW(I,K)
520   CONTINUE
      DO 525 K=L+1,LL+1
      DO 525 I=1,M
      X2(I,K) = PCV(I,K) - TY2(I,1)
      X4(I,K) = PCW(I,K) - TY2(I,2)
525   CONTINUE

      CALL TRCO2(X2,X4,X3,X1,WVO,TY1,MLLP1)

      DO 530 K=1,LL+1
      DO 530 I=1,M
      TY2(I,K) = TV4(I,L) - TV4(I,L+1)
530   CONTINUE

      DO 540 I=1,MLLP1
      TY4(I,1) = TY4(I,1) + TY2(I,1) * WVO(I,1)
540   CONTINUE

C  PROBABILITY OF A CLEAR LINE OF SIGHT (TY5)

      DO 545 I=1,M
      TY5(I,L) = CLU(I,L)
      TY1(I,L) = CLO(I,L)
545   CONTINUE
      IF (L .GT. 1) THEN
         DO 550 K=L,2,-1
         DO 550 I=1,M
         TY5(I,K-1) = TY5(I,K) * CLU(I,K-1)
         TY1(I,K-1) = TY1(I,K)
         IF (TY1(I,K-1) .GT. CLO(I,K-1)) TY1(I,K-1) = CLO(I,K-1)
550      CONTINUE
      ENDIF

      DO 565 I=1,M
      TY5(I,L+1) = CLU(I,L)
      TY1(I,L+1) = CLO(I,L)
565   CONTINUE
      IF (L .LT. LL) THEN
         DO 570 K=L,LL-1
         DO 570 I=1,M
         TY5(I,K+2) = TY5(I,K+1) * CLU(I,K+1)
         TY1(I,K+2) = TY1(I,K+1)
         IF (TY1(I,K+2) .GT. CLO(I,K+1)) TY1(I,K+2) = CLO(I,K+1)
570      CONTINUE
      ENDIF

      DO 585 I=1,MLLP1
      TY5(I,1) = TY5(I,1) * TY1(I,1)
585   CONTINUE
C     PRINT *,' 585TY5=',(TY5(147,J),J=1,LLP1)

C   ADD TO FLUXES

      DO 590 K=1,LL+1
      DO 590 I=1,M
      FLC(I,K) = FLC(I,K) + TY4(I,K)
      FLX(I,K) = FLX(I,K) + TY4(I,K) * TY5(I,K)
590   CONTINUE
C
600   CONTINUE

      DO 610 I=1,M
      TY1(I,1) = TV1(I,1) + TV2(I,1) + TV3(I,1) + TV4(I,1)
      FLX(I,1) = FLX(I,1) - TY1(I,1)
      FLC(I,1) = FLC(I,1) - TY1(I,1)
610   CONTINUE

      DO 615 I=1,M
      TV1(I,LL+1) = TV1(I,LL+1) - TV1(I,LL+2)
      TV2(I,LL+1) = TV2(I,LL+1) - TV2(I,LL+2)
      TV3(I,LL+1) = TV3(I,LL+1) - TV3(I,LL+2)
      TV4(I,LL+1) = TV4(I,LL+1) - TV4(I,LL+2)
615   CONTINUE

      DO 625 I=1,M
      ST4(I) = TV1(I,LL+1) + TV2(I,LL+1) + TV3(I,LL+1) + TV4(I,LL+1)
      FLX(I,LL+1) = FLX(I,LL+1) + ST4(I)
      FLC(I,LL+1) = FLC(I,LL+1) + ST4(I)
      ST4(I) = TV1(I,LL+2) + TV2(I,LL+2) + TV3(I,LL+2) + TV4(I,LL+2)
625   CONTINUE

C
      RETURN
      END

      SUBROUTINE GFUN1(X1,X3,WW,YW,ZW,TZ,MLEN)

C*********************************************************************
C********************* SUBROUTINE  GFUN1 *****************************
C********************** 13  MARCH  1989 ******************************
C*********************************************************************


      PARAMETER (ZERO=0.,ONE=1.)
      PARAMETER (X1MAX=.06,X3MAX=8.)
C
      PARAMETER
     *  (  B1=32.2095,    B2=52.85,   B3=-1990.63, B4=199., B5=333.244
     *,    B6=.534874,    B7=74.144,  B8=24.7442,  B9=.43368

     *,    C1=-4.92303   , C2= .134927   , C3= 257.949, C4= ZERO
     *,    C5= .315851   , C6= .440720   , C7= 40.2298, C8= 7.79555E-3

     *,    D1= .798951   , D2=-.363684   , D3= 62.5692, D4=-3.81305E-3
     *,    D5=-.285241   , D6= .071006   , D7= 70.2912, D8= 6.21039E-4

     *,    E1=-1.47769E-3, E2= .201563E-3, E3=-4.79279, E4= ZERO
     *,    E5= 10.9460E-3, E6=-2.30007E-3, E7= 63.5190, E8=-2.91325E-5

     *,    F1=-10.1311E-3, F2= 1.80265E-3, F3= 98.4758, F4= 1.43812E-5
     *,    F5= 2.35443E-3, F6=-.371430E-3, F7= 120.228, F8=-2.39016E-6 )

      DIMENSION X1(MLEN), X3(MLEN)
      DIMENSION TZ(MLEN)
      DIMENSION WW(MLEN), YW(MLEN), ZW(MLEN)

      COMMON/TM/ TIME, GFUT, TRCT,TCO3, PREP
      REAL TIME, GFUT, TRCT,TCO3, PREP
C
C     CALL CLOKON

      DO 10 I=1,MLEN
      IF (X1(I) .GT. X1MAX) X1(I) = X1MAX
      IF (X3(I) .GT. X3MAX) X3(I) = X3MAX
10    CONTINUE
      DO 20 I=1,MLEN
      TZ(I) = SQRT(X3(I))
C WW
      WW(I) = ((B1*X1(I) + ONE) / (B2*X1(I) + ONE) + TZ(I) *
     *        ((B3*X1(I) + B4) * X1(I) + B6) / (B5*X1(I) + ONE)) /
     *        ((B7*X1(I) + ONE) / (B8*X1(I) + B9) * TZ(I) + ONE)
C
      IF (WW(I) .LT. ZERO) WW(I) = ZERO
C YW
      YW(I) =         ((C1*X1(I) + C2) * X1(I) + C4) / (C3*X1(I) + ONE)
     *     + TZ(I) *  ((C5*X1(I) + C6) * X1(I) + C8) / (C7*X1(I) + ONE)
     *     + X3(I) * (((D1*X1(I) + D2) * X1(I) + D4) / (D3*X1(I) + ONE)
     *     + TZ(I) *  ((D5*X1(I) + D6) * X1(I) + D8) / (D7*X1(I) + ONE))
C  ZW
      ZW(I) =         ((E1*X1(I) + E2) * X1(I) + E4) / (E3*X1(I) + ONE)
     *     + TZ(I) *  ((E5*X1(I) + E6) * X1(I) + E8) / (E7*X1(I) + ONE)
     *     + X3(I) * (((F1*X1(I) + F2) * X1(I) + F4) / (F3*X1(I) + ONE)
     *     + TZ(I) *  ((F5*X1(I) + F6) * X1(I) + F8) / (F7*X1(I) + ONE))

20    CONTINUE

C     CALL CLOKOF(GFUT)
      RETURN
      END

      SUBROUTINE GFUN2(X2,WV,YV,ZV,TZ,MLEN)

C*********************************************************************
C********************* SUBROUTINE  GFUN2 *****************************
C********************** 13  MARCH  1989 ******************************
C*********************************************************************


      PARAMETER (ZERO=0.,ONE=1.)
      PARAMETER (X2MAX=2.)

      PARAMETER
     *    (A1=  176.396  , A2= .331236E+2, A3=.922411E+1
     *,    A4=-.0187096  , A5= .085107E-1, A6=.323105E-1
     *,    A7=-.016741E-3, A8=-.092229E-3, A9=.239186E-3   )


      DIMENSION X2(MLEN)
      DIMENSION TZ(MLEN)
      DIMENSION WV(MLEN), YV(MLEN), ZV(MLEN)

      COMMON/TM/ TIME, GFUT, TRCT,TCO3, PREP
      REAL TIME, GFUT, TRCT,TCO3, PREP

C     SAVE

C     CALL CLOKON
C
      DO 10 I=1,MLEN
      IF (X2(I) .GT. X2MAX) X2(I) = X2MAX
C WV
      TZ(I) = SQRT(X2(I))
      WV(I) = 1.0 / (A3*TZ(I) + (A1*X2(I) + A2) * X2(I) + 1.0)
      IF (WV(I) .LT. ZERO) WV(I) = ZERO
C YV
      YV(I) = (A4*X2(I) + A5) * TZ(I) + A6*X2(I)
C ZV
      ZV(I) = (A7*X2(I) + A9 + A8*TZ(I)) * X2(I)
   10 CONTINUE

C     CALL CLOKOF(GFUT)

      RETURN
      END


      SUBROUTINE TRCO2(X1,X2,X3,X4,TA,TS,MLEN)

C*********************************************************************
C********************* SUBROUTINE TRCO2  *****************************
C********************** 13  MARCH  1989 ******************************
C*********************************************************************


      PARAMETER (ZERO=0.,ONE=1.)

      PARAMETER (A2=15.1, A3=3.1)
      PARAMETER (B2=0.90, B3=.04)
      PARAMETER (C2=16.0, C3=6.7)
      PARAMETER (D1=.83,  D2=27.0)
      PARAMETER (F1=ONE/2.6)

      DIMENSION X1(MLEN), X2(MLEN), X3(MLEN), X4(MLEN)
      DIMENSION TA(MLEN), TS(MLEN)

      COMMON/TM/ TIME, GFUT, TRCT,TCO3, PREP
      REAL TIME, GFUT, TRCT,TCO3, PREP

C     SAVE
C     CALL CLOKON


C******* BEGIN 15 MICRON BAND   *****************
C******  TRANSMITTANCE RETURNED IN TA ***********

      DO 20 I=1,MLEN
C====>  CO2 BAND: CENTER    TRANSMITTANCE

      X1(I) = A3*X1(I) / (ONE + A2 * X1(I) ** 0.56)

C====>  CO2 BAND: WINGS     TRANSMITTANCE
C
      X2(I) = B3*X2(I) / (ONE + B2 * X2(I) ** 0.57)
C
C====>  H2O LINE OVERLAP    TRANSMITTANCE
C
      X3(I) = C3*X3(I) / (ONE + C2 * X3(I) * * 0.6)

C====>  H2O E-TYPE OVERLAP

      X4(I) = X3(I) + D2 * X4(I) ** 0.83
C
C====>  TOTAL TANSMITTANCE
C
      X1(I) = - X1(I) - X4(I)
      X2(I) = - X2(I) - X4(I)
C
   20 CONTINUE

C
      CALL EXPMINE(MLEN, X1, X3)
      CALL EXPMINE(MLEN, X2, X4)

      DO 100 I=1,MLEN
      TA(I) = X4(I) + F1 * (X3(I) - X4(I))
  100 CONTINUE

C     CALL CLOKOF(TRCT)
C******* END 15 MICRON BAND   *****************

      RETURN
      END


      SUBROUTINE TRO3(X4,X6,X5,TX,TS,OZONE,MLEN)

C*********************************************************************
C********************* SUBROUTINE   TRO3 *****************************
C********************** 13  MARCH  1989 ******************************
C*********************************************************************


      PARAMETER (ZERO=0.,ONE=1.)

      PARAMETER (E1=-9.79, O3MIN=1.E-20 )
      PARAMETER (G2=345.28*4./.8796, G4=-4.398, G5=81.21/120.)

      DIMENSION X4(MLEN), X5(MLEN), X6(MLEN), TX(MLEN), TS(MLEN)

      LOGICAL OZONE

      COMMON/TM/ TIME, GFUT, TRCT,TCO3, PREP
      REAL TIME, GFUT, TRCT,TCO3, PREP

C     SAVE
C     CALL CLOKON

C******  BEGIN 9.6 MICRON BAND  *********************
C******  TRANSMITTANCE RETURNED IN TX ***************

C  H2O CONTINUUM OVERLAP

      DO 10 I=1,MLEN
      TS(I) = X4(I) * E1
   10 CONTINUE
      CALL EXPMINE(MLEN, TS, TX)

C  OZONE: EQS(6-8) Rosenfield et al. (1987) JAS pg 862

      IF (OZONE) THEN
         DO 20 I=1,MLEN
         IF (X6(I) .LT. O3MIN) X6(I) = O3MIN
         IF (X5(I) .LT. O3MIN) X5(I) = O3MIN
         TS(I) = ( SQRT(1.0 + G2 * X5(I) * X5(I) / X6(I)) - 1.0)
     *                           * G4 * X6(I) / X5(I)
   20    CONTINUE

         CALL EXPMINE(MLEN, TS, X6)
         DO 40 I=1,MLEN
         TX(I) = TX(I) * (1.0 - (ONE   - X6(I)) * G5)
   40    CONTINUE
      ENDIF

C******  END   9.6 MICRON BAND  *********************
C     CALL CLOKOF(TCO3)

      RETURN
      END
      SUBROUTINE GETOZN(O3B, SEASNL)
C
#include "slgcm.slgprm"
#include "slgcm.slgprg"
#include "slgcm.slgcon"
#include "slgcm.slgwrk"
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C********************* SUBROUTINE GETOZN *****************************
C********************** 3 NOVEMBER 1988 ******************************
C*********************************************************************
C
      parameter (jmr=45)
      PARAMETER (JMLZ13=JM*LOZ*13)
C
C     ARGUMENTS
C
      LOGICAL SEASNL
C
C     LOCALS
C
      INTEGER     DAYS(13)
      DATA        DAYS/31,28,31,30,31,30,31,31,30,31,30,31,30/
C
      REAL  O3r(JMr,LOZ,13), O3B(IJM0M0,LM)
      REAL  O3Z(JM,LOZ,13), O3I(JM,LOZ), PKSTR(LOZ), PSTR(LOZ)
C
      LOGICAL     FIRST, CHANGE
      DATA PTOP/16.75/, FIRST/.TRUE./
      DATA K1/0/, K2/0/, MIDM/0/, MIDP/0/, PKSTR/LOZ*0.0/, PSTR/LOZ*0.0/
      DATA O3Z/JMLZ13*0.0/
C
      SAVE
C
      WRITE (6,989) MONTH(), DAY(), HOUR()
  989 FORMAT(' UPDATING OZONE FOR ', I3,I3,I3)
C
      IDAY   = DAY()
      IMON   = MONTH()
      MIDMON = DAYS(IMON)/2 + 1
      CHANGE = FIRST .OR.
     *        ( (IDAY .EQ. MIDMON) .AND. (HOUR().EQ.0) )
C
      IF (FIRST) THEN
         REWIND KO3
         READ(KO3) PSTR, O3r
C
         PRINT *,' FOUND OZONE DATA FOR LEVELS PSTR=',(PSTR(L),L=1,LOZ)
C
         DO 100 L=1,LOZ
         PKSTR(L) = (PSTR(L)/P00) ** RKAP
  100    CONTINUE
         jmrm1 = jmr - 1
         do 120 nm=1,13
         do 120 l=1,loz
         do 110 j=1,jmrm1
         o3z(2*j+1,l,nm) = o3r(j,l,nm)
         o3z(2*j+2,l,nm) = 0.5 * (o3r(j,l,nm) + o3r(j+1,l,nm))
  110    continue
         o3z(1,l,nm)    = o3r(1,l,nm)
         o3z(2,l,nm)    = o3r(1,l,nm)
         o3z(jmm1,l,nm) = o3r(jmrm1,l,nm)
         o3z(jm,l,nm)   = o3r(jmrm1,l,nm)
  120    continue
c        
         FIRST  = .FALSE.
      ENDIF
C
      IF (CHANGE) THEN
         IF (SEASNL) THEN
            IF (IDAY .LT. MIDMON) THEN
               K1   = MOD(IMON+10,12) + 1
               MIDM = DAYS(K1)/2 + 1
               K2   = IMON
               MIDP = DAYS(K1) + MIDMON
            ELSE
               K1   = IMON
               MIDM = MIDMON
               K2   = MOD(IMON,12) + 1
               MIDP = DAYS(K2)/2 + 1 + DAYS(K1)
            ENDIF
         ELSE
            K1   = 13
            K2   = 13
            MIDM = 15
            MIDP = 45
         ENDIF
      ENDIF
C
      IF (IDAY .LT. MIDMON) THEN
         ID = IDAY + DAYS(K1)
      ELSE
         ID = IDAY
      ENDIF
C
      IF (CPRPTM() .LT. 0.0D0) THEN
         FAC = (REAL(ID  -MIDM)*DAYLEN + SECOFDY()) /
     *         (REAL(MIDP-MIDM)*DAYLEN            )
      ELSE
         FAC = (REAL(ID  -MIDM)*DAYLEN ) /
     *         (REAL(MIDP-MIDM)*DAYLEN            )
      ENDIF
C
      DO 580 I=1,JM*LOZ
      O3I(I,1)=O3Z(I,1,K2)*FAC+O3Z(I,1,K1)*(ONE-FAC)
  580 CONTINUE
      DO 590 I=1,IJM0M0
      WK1(I) = PIB(I)
      WK8(I) = WK1(I) ** RKAP
  590 CONTINUE
      DO 600 J=1,JM
      DO 620 I=1,IMP3
      IJ = (J-1) * IMP3 + I
      WK6(IJ) = O3I(J,LOZ)
      WK7(IJ) = O3I(J,1)
  620 CONTINUE
  600 CONTINUE
C
C     O3T(1;JMM1) =  O3I(1,L;JMM1) * (PSTR(2)+PSTR(1))*HALF
C     TEM         =                  (PSTR(2)+PSTR(1))*HALF
C
C     DO 610 L=2,LOZ
C     IF (PSTR(L) .LE. PTOP) THEN
C        O3T(1;JMM1) = O3T(1;JMM1) + O3I(1,L;JMM1)
C    *               * (PSTR(L+1)-PSTR(L-1))*HALF
C        TEM         = TEM +  (PSTR(L+1)-PSTR(L-1))*HALF
C     ENDIF
C 610 CONTINUE
C     O3T(1;JMM1) = O3T(1;JMM1) / TEM
C
      DO 800 L=1,LM
      DO 810 I=1,IJM0M0
      WK1(I) = WK8(I)*PRH(L)
  810 CONTINUE
      DO 700 K=1,LOZ-1
      DO 650 J=1,JM
      DO 640 I=1,IMP3
      IJ = (J-1)*IMP3 + I
      WK2(IJ) = O3I(J,K)
      WK3(IJ) = O3I(J,K+1)
  640 CONTINUE
  650 CONTINUE
      DO 660 I=1,IJM0M0
      IF (WK1(I).GT.PKSTR(K).AND.WK1(I).LE.PKSTR(K+1)) THEN
         WK4(I)   = PKSTR(K+1) - WK1(I)
         WK4(I)   = WK4(I) * (ONE/(PKSTR(K+1)-PKSTR(K)))
         WK5(I)   = ONE    - WK4(I)
         WK4(I)   = WK2(I) * WK4(I)
         WK5(I)   = WK3(I) * WK5(I)
         O3B(I,L) = WK4(I) + WK5(I)
      ENDIF
  660 CONTINUE
  700 CONTINUE
      DO 710 I=1,IJM0M0
      IF (WK1(I) .GT. PKSTR(LOZ)) O3B(I,L) = WK6(I)
      IF (WK1(I) .LT. PKSTR(1))   O3B(I,L) = WK7(I)
  710 CONTINUE
  800 CONTINUE
C
      RETURN
      END

