      SUBROUTINE RASV (LEN, LENC,   K,   DT
Status: R

     *,                ISEED, NCRND, KRMIN, KRMAX, FRAC, RASAL, BOTOP
     *,                CP,  ALHL, GRAV, CRMSFX
C
     *,                SGO, ONBDSG, PRH, PRJ, FPK, HPK, SGE
     *,                PII, PIK,    PKI, ALF, BET, GAM
     *,                UOI, VOI,    POI, QOI
     *,                PCU, CLN,    Q1,  Q2
C
     *,                HOL, QOL,    ETA, HST, GMH
     *,                TX1, TX2,    TX3, TX4, TX5, TX6, TX7, TX8
     *,                TX9, TXA,    TXB, TXC, TXD, TXE, TXF, TXG 
     *,                IA, I1, I2)
C
C
C
C
C*********************************************************************
C*********************************************************************
C******************** Relaxed Arakawa-Schubert ***********************
C************************ Parameterization ***************************
C********************* Plug Compatible Version  **********************
C*********************  for sigma=p/ps models  ***********************
C************************* 04 August 1992 ****************************
C*********************************************************************
C************************** Developed By *****************************
C**************************              *****************************
C************************ Shrinivas Moorthi **************************
C************************       and         **************************
C************************  Max J. Suarez *****************************
C************************                *****************************
C******************** Laboratory for Atmospheres *********************
C****************** NASA/GSFC, Greenbelt, MD 20771 *******************
C*********************************************************************
C*********************************************************************
C
C
C
      PARAMETER (ICM=100, ONE=1.0)
C
      DIMENSION PII(LEN),   PIK(LEN),   PKI(LEN), RASAL(K-1)
     *,         UOI(LEN,K), VOI(LEN,K), POI(LEN,K), QOI(LEN,K)
C
      DIMENSION Q1(LEN,K), Q2(LEN,K),  CLN(LEN,K), PCU(LEN)
C
      REAL  ALF(LEN,K),  BET(LEN,K), GAM(LEN,K)
      DIMENSION  HOL(LEN ,K), QOL(LEN,K), ETA(LEN,K), HST(LEN,K)
     *,          GMH(LEN,K)
C
      DIMENSION TX1(LENC), TX2(LENC), TX3(LENC), TX4(LENC), TX5(LENC)
     *,         TX6(LENC), TX7(LENC), TX8(LENC), TX9(LENC), TXA(LENC)
     *,         TXB(LENC), TXC(LENC), TXD(LENC), TXE(LENC), TXF(LENC)
     *,         TXG(LENC)
     *,         IA(LENC),  I1(LENC),  I2(LENC)
C
      DIMENSION SGO(K),    PRJ(K),    PRH(K),    FPK(K),    HPK(K)
     *,         SGE(K),    EPS(ICM),  DEL(ICM),  SDU(ICM),  SDD(ICM)
      DIMENSION ONBDSG(K), IC(ICM)
      LOGICAL   BOTOP
C
      DATA KPRV/0/
      DATA EPS/ICM*0.0/, DEL/ICM*0.0/, SDU/ICM*0.0/, SDD/ICM*0.0/
      data ix/2000/
C
      SAVE
C
      KM1   = K  - 1
C
      IF (KM1 .NE. KPRV) THEN
         KPRV  = KM1
C
         DO 10 L=1,KM1
         EPS(L)   = (PRJ(L+1)-PRH(L  ))/PRH(L  )
         DEL(L+1) = (PRH(L+1)-PRJ(L+1))/PRH(L+1)
C
         SDU(L+1) = CP * PRH(L+1) * (PRJ(L+1)-PRH(L  ))
     *                            / (PRH(L+1)-PRH(L))
         SDD(L  ) = CP * PRH(L  ) * (PRH(L+1)-PRJ(L+1))
     *                            / (PRH(L+1)-PRH(L))
  10     CONTINUE
      ENDIF
      KCR   = MIN(KM1,KRMAX)
      KFX   = KM1 - KCR
      NCMX  = KFX + NCRND
C
      IF (KFX .GT. 0) THEN
         IF (BOTOP) THEN
            DO 20 NC=1,KFX
            IC(NC) = K - NC
   20       CONTINUE
         ELSE
            DO 25 NC=KFX,1,-1
            IC(NC) = K - NC
   25       CONTINUE
         ENDIF
      ENDIF
C
      IF (NCRND .GT. 0) THEN
         CALL RANSET(ISEED)
         DO 30 I=1,NCRND
         IRND = (RANF()-0.0005)*(KCR-KRMIN+1)
         IC(KFX+I) = IRND + KRMIN
   30    CONTINUE
      ENDIF
C
C
      FRACS  = (SGE(K) - SGE(K-1)) * FRAC
c     print *,' FRACS=',FRACS
      DO 100 NC=1,NCMX
C
      IB = IC(NC)
c     print *,' calling cloud type ib=',ib
C
      CALL CLOUD(LEN,       LENC,       K-IB+1,    DT, RASAL(IB), FRACS
     *,      CP,  ALHL, GRAV, CRMSFX
C
     *,      SGO(IB),   ONBDSG(IB), PRH(IB),   FPK(IB), HPK(IB), SGE(IB)
     *,      EPS(IB),   DEL(IB),    SDU(IB),   SDD(IB)
     *,      PII,       PIK,     PKI, ALF(1,IB), BET(1,IB), GAM(1,IB)
     *,      UOI(1,IB), VOI(1,IB),  POI(1,IB), QOI(1,IB)
     *,      PCU,       CLN(1,IB),  Q1(1,IB),  Q2(1,IB)
C
     *,      HOL(1,IB), QOL(1,IB), ETA(1,IB), HST(1,IB), GMH(1,IB)
     *,      TX1, TX2, TX3, TX4, TX5, TX6, TX7, TX8 
     *,      TX9, TXA, TXB, TXC, TXD, TXE, TXF, TXG 
     *,      IA, I1, I2)
C
c     print *,' poi=',(poi(ix,l),l=1,K)
c     print *,' qoi=',(qoi(ix,l),l=1,K)
  100 CONTINUE
C
      RETURN
      END
      SUBROUTINE CLOUD (LEN, LENC, K, DT, RASAL, FRAC
     *,                 CP,  ALHL, GRAV, CRMSFX
C
     *,                 SGO, ONBDSG, PRH,  FPK, HPK, SGE
     *,                 EPS, DEL,    SDU,  SDD
     *,                 PII, PIK, PKI, ALF, BET, GAM
     *,                 UOI, VOI, POI, QOI
     *,                 PCU, CLN, TCU, QCU
C
     *,                 HOL, QOL, ETA, HST, GMH
     *,                 TX1, TX2, TX3, TX4, TX5, TX6, ALM, WLQ
     *,                 WFN, AKM, TXC, TXE, CLF, UHT, VHT, QS1
     *,                 IA, I1, I2)
C
cinclude "atmosv1.mlparm"
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C********************* SUBROUTINE CLOUD  *****************************
C********************** 16 MARCH   1988 ******************************
C*********************************************************************
C
C
      PARAMETER (ZERO=0.0, ONE=1.0, HALF=0.5, CMB2PA=100.0)
      PARAMETER (IC=1,     DAYLEN=86400.0)
C
      DIMENSION ALF(LEN,K),  BET(LEN,K),  GAM(LEN,K)
      DIMENSION PII(LEN),    PIK(LEN),    PKI(LEN)
      DIMENSION UOI(LEN,K),  VOI(LEN,K),  POI(LEN,K),  QOI(LEN,K)
C
      DIMENSION TCU(LEN,K),  QCU(LEN,K),  CLN(LEN), PCU(LEN)
      DIMENSION AKM(LENC),   WFN(LENC),   QS1(LENC)
      DIMENSION HOL(LENC,K), QOL(LENC,K), ETA(LENC,K), HST(LENC,K)
     *,         GMH(LENC,K), TX1(LENC),   TX2(LENC)
     *,         TX3(LENC),   TX4(LENC),   TX5(LENC),  TX6(LENC)
     *,         ALM(LENC),  WLQ(LENC)
C
      DIMENSION ONBDSG(K), FPK(K),   HPK(K),   PRH(K),  SGO(K), SGE(K)
     *,         EPS(K),    DEL(K),   SDU(K),   SDD(K),  BTA(100)
      DIMENSION IA(LENC),  I1(LENC),  I2(LENC)
C
      DIMENSION TXC(LENC), CLF(LENC), TXE(LENC), UHT(LENC), VHT(LENC)
C
C
      KM1 = K  - 1
      IC1 = IC + 1
C
      ONEBG  = 1.0  / GRAV
      TWOBAL = 2.0 / ALHL

C
      DO 10 I=1,K
      BTA(I) = FPK(I) * ONEBG
   10 CONTINUE
      BTA(IC)  = HPK(IC)  * ONEBG
C
C
      DO 30 I=1,LENC
      TEM      = PIK(I) * POI(I,K)
      QS1(I)   = ALF(I,K) + BET(I,K)*POI(I,K)
      QOL(I,K) = AMIN1(QS1(I),QOI(I,K))
      HOL(I,K) = TEM * (HPK(K)+CP*PRH(K)) + QOL(I,K)*ALHL
      TX2(I)   = TEM * FPK(K)
      ETA(I,K) = ZERO
   30 CONTINUE
C
      DO 50 L=KM1,IC,-1
      DO 50 I=1,LENC
      QS1(I)   = ALF(I,L) + BET(I,L)*POI(I,L)
      QOL(I,L) = AMIN1(QS1(I),QOI(I,L))
C
      TEM      = PIK(I) * POI(I,L)
      TEM1     = TX2(I) + TEM * (HPK(L)+CP*PRH(L))
C
      HOL(I,L) = TEM1   + QOL(I,L) * ALHL
      HST(I,L) = TEM1   + QS1(I)   * ALHL
C
      ETA(I,L) = ETA(I,L+1) + TEM * BTA(L)
      TX2(I)   = TX2(I)     + TEM * FPK(L)
   50 CONTINUE
C
      DO 130 I=1,LENC
      TX2(I) = HOL(I,K)  - HST(I,IC)
C
      TX1(I) = ZERO
  130 CONTINUE
C
C     ENTRAINMENT PARAMETER ALM
C
      DO 160 L=IC,KM1
      DO 160 I=1,LENC
      TX1(I) = TX1(I) + (HST(I,IC) - HOL(I,L)) * (ETA(I,L) - ETA(I,L+1))
  160 CONTINUE
C
      LEN1 = 0
      LEN2 = 0
      ISAV = 0
      DO 195 I=1,LENC
      IF (TX1(I) .GT. ZERO .AND. TX2(I) .GT. ZERO) THEN
         LEN1      = LEN1 + 1
         IA(LEN1)  = I
         ALM(LEN1) = TX2(I) / TX1(I)
      ENDIF
  195 CONTINUE
      LEN2 = LEN1
      if (K .gt. 2) then
         DO 196 I=1,LENC
         IF (TX2(I) .LE. 0.0 .AND. (HOL(I,K) .GT. HST(I,IC1))) THEN
            LEN2      = LEN2 + 1
            IA(LEN2)  = I
            ALM(LEN2) = 0.0
         ENDIF
  196 CONTINUE
      endif
C
c     IF (NST .GT. NSTX) THEN
c     IF (ISAV .GT. 0 .AND. ISAV .LE. LEN2) THEN
c     PRINT *,' ISAV=',ISAV,' IA=',IA(ISAV)
c     IP1 = ISAV
c     ELSE
c     IP1 = 1
c     PRINT *,' IGNORE THIS CASE ISAV=',ISAV,' IP1=',IP1,' ia=',ia(ip1)
c     ENDIF
c     ENDIF
C
      IF (LEN2 .EQ. 0) RETURN
      LEN11 = LEN1 + 1
C
C     NORMALIZED MASSFLUX
C
      DO 250 I=1,LEN1
      ETA(I,K) = 1.0
      TX2(I) = PII(IA(I)) * SGO(IC)
      TXC(I) = 1.0
  250 CONTINUE
C
      DO 252 I=LEN11,LEN2
      ETA(I,K) = 1.0
      WFN(I)   = 0.0
      II       = IA(I)
      IF (HST(II,IC1) .LT. HST(II,IC)) THEN
         TXC(I) = (HST(II,IC1)-HOL(II,K))/(HST(II,IC1)-HST(II,IC))
      ELSE
         TXC(I) = 0.0
      ENDIF
      TX2(I) = PII(II) * (SGO(IC1) - TXC(I) * (SGO(IC1)-SGO(IC)))
  252 CONTINUE
C
      CALL ACRITN(LEN2, TX2, TX3)
C
      DO 260 L=KM1,IC,-1
      DO 255 I=1,LEN2
      TX1(I) = ETA(IA(I),L)
  255 CONTINUE
      DO 260 I=1,LEN2
      ETA(I,L) = 1.0 + ALM(I) * TX1(I)
  260 CONTINUE
C
C     CLOUD WORKFUNCTION
C
      IF (LEN1 .GT. 0) THEN
         DO 270 I=1,LEN1
         WFN(I) = - GAM(IA(I),IC) * EPS(IC) * HST(IA(I),IC) * ETA(I,IC1)
  270    CONTINUE
      ENDIF
C
C
      DO 290 I=1,LEN2
      TX1(I) = HOL(IA(I),K)
      TEM    = SGO(IC1) - TXC(I) * (SGO(IC1)-SGO(IC))
      TX3(I) = TX3(I) * PII(IA(I)) * (SGE(KM1)-TEM)
  290 CONTINUE
C
      IF (IC1 .LE. KM1) THEN
         DO 380 L=KM1,IC1,-1
         DO 380 I=1,LEN2
         TEM    = TX1(I) + (ETA(I,L) - ETA(I,L+1)) * HOL(IA(I),L)
C
         WFN(I) = WFN(I) + GAM(IA(I),L) * (TX1(I)*EPS(L) + TEM*DEL(L)
     *          - (ETA(I,L+1)*EPS(L) + ETA(I,L)*DEL(L)) * HST(IA(I),L))
C
         TX1(I) = TEM
  380    CONTINUE
      ENDIF
C
      LENA = 0
      IF (LEN1 .GT. 0) THEN
         DO 512 I=1,LEN1
         WFN(I) = WFN(I) + TX1(I) * GAM(IA(I),IC) * EPS(IC) - TX3(I)
         IF (WFN(I) .GT. 0.0) THEN
            LENA = LENA + 1
            I1(LENA) = IA(I)
            I2(LENA) = I
            TX1(LENA) = WFN(I)
            TX2(LENA) = QS1(IA(I))
            TXC(LENA) = 1.0
         ENDIF
  512    CONTINUE
      ENDIF
      LENB = LENA
      DO 515 I=LEN11,LEN2
      WFN(I) = WFN(I) - TX3(I)
      IF (WFN(I) .GT. 0.0 .AND. TXC(I) .GT. 0.0) THEN
         LENB = LENB + 1
         I1(LENB)  = IA(I)
         I2(LENB)  = I
         TX1(LENB) = WFN(I)
         TX2(LENB) = QS1(IA(I))
         TX4(LENB) = TXC(I)
      ENDIF
  515 CONTINUE
C
c     IF (NST .GT. NSTX) THEN
c     PRINT *,' WFN=',WFN(IP1),' ACR=',TX3(IP1),'TXC=',TXC(IP1),IP1
c     IF (ISAV .GT. 0 .AND. ISAV .LE. LENB) THEN
c     PRINT *,' ISAV=',ISAV,' I1=',I1(ISAV)
c     IP1 = ISAV
c     ELSE
c     IP1 = 1
c     PRINT *,' IGNORE THIS CASE ISAV=',ISAV,' IP1=',IP1,'I1=',i1(ip1)
c     ENDIF
c     ENDIF
C
      IF (LENB .LE. 0) RETURN
C
      DO 516 I=1,LENB
      WFN(I) = TX1(I)
      QS1(I) = TX2(I)
  516 CONTINUE
C
      DO 520 L=IC,K
      DO 517 I=1,LENB
      TX1(I) = ETA(I2(I),L)
  517 CONTINUE
      DO 520 I=1,LENB
      ETA(I,L) = TX1(I)
520   CONTINUE
C
      LENA1 = LENA + 1
C
      DO 510 I=1,LENA
      II = I1(I)
      TX6(I) = HST(II,IC) - HOL(II,IC)
  510 CONTINUE
      DO 530 I=LENA1,LENB
      II = I1(I)
      TXC(I) = TX4(I)
      TEM    = TXC(I) * (HOL(II,IC)-HOL(II,IC1)) + HOL(II,IC1)
      TX6(I) = HOL(II,K) - TEM
C
      TEM1   = TXC(I) * (QOL(II,IC)-QOL(II,IC1)) + QOL(II,IC1)
      TX5(I) = TEM    - TEM1 * ALHL
      QS1(I) = TEM1   + TX6(I)*(ONE/ALHL)
      TX3(I) = HOL(II,IC)
  530 CONTINUE
C
C
      DO 620 I=1,LENB
      II = I1(I)
      WLQ(I) = QOL(II,K) - QS1(I)     * ETA(I,IC)
      UHT(I) = UOI(II,K) - UOI(II,IC) * ETA(I,IC)
      VHT(I) = VOI(II,K) - VOI(II,IC) * ETA(I,IC)
      TXE(I) = HOL(II,K)
  620 CONTINUE
C
      DO 635 L=KM1,IC,-1
      DO 630 I=1,LENB
      II = I1(I)
      TEM    = ETA(I,L) - ETA(I,L+1)
      WLQ(I) = WLQ(I) + TEM * QOL(II,L)
      UHT(I) = UHT(I) + TEM * UOI(II,L)
      VHT(I) = VHT(I) + TEM * VOI(II,L)
  630 CONTINUE
  635 CONTINUE
C
C     CALCULATE GS AND PART OF AKM (THAT REQUIRES ETA)
C
      DO 690 I=1,LENB
      II = I1(I)
      TEM        = (POI(II,KM1) - POI(II,K)) * PIK(II)
      HOL(I,K)   = TEM    * (SDU(K)*ONBDSG(K))
      HOL(I,KM1) = TEM    * (SDD(KM1)*ONBDSG(KM1))

      AKM(I)     = ZERO
      TX2(I)     = PII(II)*SGO(IC)
  690 CONTINUE
C

      IF (IC1 .LE. KM1) THEN
         DO 750 L=KM1,IC1,-1
         DO 750 I=1,LENB
         II = I1(I)
         TEM        = (POI(II,L-1) - POI(II,L)) * PIK(II) * ETA(I,L)
C
         HOL(I,L)   = TEM * (SDU(L  )*ONBDSG(L))  + HOL(I,L)
         HOL(I,L-1) = TEM * (SDD(L-1)*ONBDSG(L-1))
C
         AKM(I) = AKM(I) - HOL(I,L)*(ETA(I,L)*DEL(L)+ETA(I,L+1)*EPS(L))
  750    CONTINUE
C
      ENDIF
C
      CALL RNCL(LENB, TX2, TX1, CLF)
C
      DO 770 I=1,LENB
      TX2(I) = (ONE - TX1(I)) * WLQ(I)
      WLQ(I) = TX1(I) * WLQ(I)
C
      TX1(I) = HOL(I,IC)
  770 CONTINUE
C
      DO 790 I=LENA1,LENB
      II = I1(I)
      TX1(I) = TX1(I) + (TX5(I) - TX3(I) + QOL(II,IC)*ALHL) * ONBDSG(IC)
  790 CONTINUE

      DO 800 I=1,LENB
      HOL(I,IC) = TX1(I) - TX2(I) * (ALHL*ONBDSG(IC))
  800 CONTINUE
C
C
      IF (LENA .GT. 0) THEN
         DO 810 I=1,LENA
         AKM(I) = AKM(I) - ETA(I,IC1) * EPS(IC) * TX1(I)
  810    CONTINUE
      ENDIF
C
C     CALCULATE GH
C
      DO 830 I=1,LENB
      II = I1(I)
      TX3(I)   =  QOL(II,KM1) - QOL(II,K)
      GMH(I,K) = HOL(I,K) + TX3(I) * (ALHL*HALF*ONBDSG(K))
      AKM(I) = AKM(I) + GAM(II,KM1)*EPS(KM1) * GMH(I,K)
  830 CONTINUE
C
      IF (IC1 .LE. KM1) THEN
         DO 840 L=KM1,IC1,-1
         DO 840 I=1,LENB
         II = I1(I)
         TX2(I) = TX3(I)
         TX3(I) = (QOL(II,L-1) - QOL(II,L)) * ETA(I,L)
         TX2(I) = TX2(I) + TX3(I)
C
         GMH(I,L) = HOL(I,L) + TX2(I)   * (ALHL*HALF*ONBDSG(L))
  840    CONTINUE
      ENDIF
C
      DO 850 I=LENA1,LENB
      TX3(I) = TX3(I) + TWOBAL
     *       * (TXE(I) - TX6(I) - TX5(I) - QOL(I1(I),IC)*ALHL)
  850 CONTINUE
      DO 860 I=1,LENB
      GMH(I,IC) = TX1(I) + ONBDSG(IC)
     *          * (TX3(I)*(ALHL*HALF) + ETA(I,IC) * TX6(I))
  860 CONTINUE
C
C     CALCULATE HC PART OF AKM
C
      IF (IC1 .LE. KM1) THEN
         DO 870 I=1,LENB
         TX1(I) = GMH(I,K)
  870    CONTINUE
         DO 3725 L=KM1,IC1,-1
         DO 880 I=1,LENB
         II = I1(I)
         TX1(I) = TX1(I) + (ETA(I,L) - ETA(I,L+1)) * GMH(I,L)
         TX2(I) = GAM(II,L-1) * EPS(L-1)
  880    CONTINUE
C
         IF (L .EQ. IC1) THEN
            DO 890 I=LENA1,LENB
            TX2(I) = ZERO
  890       CONTINUE
         ENDIF
C
         DO 900 I=1,LENB
         AKM(I) = AKM(I) + (TX2(I) + GAM(I1(I),L)*DEL(L)) * TX1(I)
  900    CONTINUE
 3725    CONTINUE
      ENDIF
C
C
      DO 920 I=LENA1,LENB
      TX1(I) = SGO(IC) + (SGO(IC1) - SGO(IC)) * (ONE-TXC(I))
      IF ((TX1(I) .GE. SGE(IC)) .AND. (TX1(I) .LE. SGO(IC1))) THEN
         TXC(I)     = ONE - (TX1(I) - SGE(IC)) / (SGO(IC1) - SGE(IC))
C
         HOL(I,IC1) = HOL(I,IC1) + HOL(I,IC) * (ONBDSG(IC1)/ONBDSG(IC))
         HOL(I,IC)  = ZERO
C
         GMH(I,IC1) = GMH(I,IC1) + GMH(I,IC)*(ONBDSG(IC1)/ONBDSG(IC))
         GMH(I,IC)  = ZERO
      ELSEIF (TX1(I) .LT. SGE(IC)) THEN
         TXC(I) = 1.0
      ELSE
         TXC(I) = 0.0
      ENDIF
  920 CONTINUE
C
C
      TEM0 = PCU(I1(IP1))
      DO 970 I=1,LENB
      II = I1(I)
      IF (AKM(I) .LT. ZERO .AND. WLQ(I) .GE. 0.0) THEN
         WFN(I) = - TXC(I) * WFN(I) * RASAL / AKM(I)
      ELSE
         WFN(I) = ZERO
      ENDIF
      WFN(I) = AMIN1(WFN(I), FRAC)
C
C     COMPUTE CLOUD AMOUNT
C
      TX1(I) = CLN(II)
      IF (WFN(I) .GT. CRMSFX)  TX1(I) = TX1(I) + CLF(I)
      IF (TX1(I) .GT. ONE)  TX1(I) = ONE
C
C     PRECIPITATION
C
      WLQ(I) = PCU(II) + (DAYLEN*CMB2PA/(DT*GRAV))
     *                 * WLQ(I) * WFN(I) * PII(II)
C
  970 CONTINUE
C
      DO 975 I=1,LENB
      II = I1(I)
      CLN(II) = TX1(I)
  975 CONTINUE
C
C     THETA AND Q CHANGE DUE TO CLOUD TYPE IC
C

c     TEMA = 0.0
c     TEMB = 0.0
      DO 990 L=IC,K
      DO 980 I=1,LENB
      II = I1(I)
      TEM      = (GMH(I,L) - HOL(I,L)) * WFN(I)
      TEM1     =  HOL(I,L) * WFN(I)
      TX1(I)   = POI(II,L) + TEM1 * PKI(II) * (ONE/(CP*PRH(L)))
      TX2(I)   = QOI(II,L) + TEM * (ONE/ALHL)
C
      TX3(I)   = TCU(II,L) + TEM1 * (DAYLEN/(CP*DT))
      TX4(I)   = QCU(II,L) + TEM  * (DAYLEN/(ALHL*DT))
  980 CONTINUE
      DO 985 I=1,LENB
      II = I1(I)
      POI(II,L) = TX1(I)
      QOI(II,L) = TX2(I)
C
      TCU(II,L) = TX3(I)
      QCU(II,L) = TX4(I)
  985 CONTINUE
C
c     II = IP1
c     TEMA = TEMA +  HOL(II,L)  * WFN(II)*(DAYLEN /(ALHL*DT*ONBDSG(L)))
c     TEMB = TEMB +
c    *  (GMH(II,L) - HOL(II,L)) * WFN(II)*(DAYLEN/(ALHL*DT*ONBDSG(L)))
C
  990 CONTINUE
c     PRINT *,' TEMA=',TEMA,' TEMB=',TEMB,' pcu=',wlq(ip1)
C
      DO 992 I=1,LENB
      II = I1(I)
C
C     CUMULUS PRECIPITATION
C
      PCU(II) = WLQ(I)
C
C     CUMULUS FRICTION AT THE BOTTOM LEVEL
C
      TEM      = WFN(I) * (0.5*ONBDSG(K))
      TX1(I)   = UOI(II,KM1) - UOI(II,K)
      TX2(I)   = VOI(II,KM1) - VOI(II,K)
C
      TX3(I)   = UOI(II,K) + TX1(I) * TEM
      TX4(I)   = VOI(II,K) + TX2(I) * TEM
  992 CONTINUE
C
      DO 995 I=1,LENB
      UOI(II,K)  = TX3(I)
      VOI(II,K)  = TX4(I)
  995 CONTINUE
C
C     CUMULUS FRICTION AT ALL OTHER LEVELS
C
      DO 1020 L=KM1,IC1,-1
      DO 1010 I=1,LENB
      II = I1(I)
      TEM = WFN(I) * (0.5*ONBDSG(L))
      TEM1   = TX1(I)
      TEM2   = TX2(I)
      TX1(I) = (UOI(II,L-1) - UOI(II,L)) * ETA(I,L)
      TX2(I) = (VOI(II,L-1) - VOI(II,L)) * ETA(I,L)
C
      TX3(I) = UOI(II,L) + (TX1(I) + TEM1) * TEM
      TX4(I) = VOI(II,L) + (TX2(I) + TEM2) * TEM
 1010 CONTINUE
      DO 1020 I=1,LENB
      II = I1(I)
      UOI(II,L) = TX3(I)
      VOI(II,L) = TX4(I)
 1020 CONTINUE
C
      DO 1030 I=1,LENB
      II = I1(I)
      IF (TXC(I) .GE. 1.0) THEN
         TEM    = WFN(I) * (ONBDSG(IC)*0.5)
      ELSE
         TEM = 0.0
      ENDIF
      TX1(I) = UOI(II,IC) + (TX1(I) + UHT(I) + UHT(I)) * TEM
      TX2(I) = VOI(II,IC) + (TX2(I) + VHT(I) + VHT(I)) * TEM
 1030 CONTINUE
      DO 1040 I=1,LENB
      II = I1(I)
      UOI(II,IC) = TX1(I)
      VOI(II,IC) = TX2(I)
 1040 CONTINUE
C
C
c     TEMA = TEMA * PII(I1(IP1))*CMB2PA/GRAV
c     TEMB = TEMB * PII(I1(IP1))*CMB2PA/GRAV
c     TEMC = PCU(I1(IP1)) - TEM0
c     WRITE(6,8003) TEMA, TEMB, TEMC, I1(IP1)
c8003 FORMAT(' PCUQ1=', E13.6,'PCUQ2=',E13.6,' PCU=',E13.6,' I1=',I8)
c     IF (NST .GE. NSTX) WRITE(6,7004) PCU(IP1)
c7004 FORMAT(' PCU=',2E15.5)
C
C     PENETRATIVE CONVECTION CALCULATION OVER
C
c     PCMAX = 0.0
c     do 4030 i=1,LENB
c     PCMAX = AMAX1(PCMAX,PCU(I1(I)))
c4030 CONTINUE
c     PRINT *,' PCUMAX=',PCMAX

      RETURN
      END
      SUBROUTINE RNCL(LEN, PL, RNO, CLF)
C
C
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C********************   SUBROUTINE  RNCL  ****************************
C********************** 01 FEBRUARY 1991 *****************************
C*********************************************************************
C
      PARAMETER (P5=500.0,  P8=800.0, PT8=0.8, PT2=0.2)
      PARAMETER (PFAC=PT2/(P8-P5))
C
      PARAMETER (P4=400.0,    P6=401.0)
      PARAMETER (CRTM=5.0E-7, CRTMI=1.0/CRTM)
      PARAMETER (CFAC=1.0/(P6-P4))
C
      PARAMETER (ACTP=2.0,   FACM=1.0)
C
      DIMENSION PL(LEN),  RNO(LEN), CLF(LEN)
C
      DO 10 I=1,LEN
      RNO(I) = 1.0
      CLF(I) = 1.0
C
      IF (PL(I) .GE. P5 .AND. PL(I) .LE. P8) THEN
          RNO(I) = (P8-PL(I))*PFAC + PT8
      ELSEIF (PL(I) .GT. P8 ) THEN
          RNO(I) = PT8
      ENDIF
      IF (PL(I) .GE. P4 .AND. PL(I) .LE. P6) THEN
         CLF(I) = (P6-PL(I))*CFAC
      ELSEIF (PL(I) .GT. P6 ) THEN
         CLF(I) = 0.0
      ENDIF
   10 CONTINUE
C
      RETURN
      END
      SUBROUTINE ACRITN(LEN, PL, ACR)
C
C
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C******************** SUBROUTINE  ACRIT    ***************************
C********************** 01 FEBRUARY 1991 *****************************
C*********************************************************************
C
      PARAMETER (ACTP=1.7,   FACM=1.5)
C
      DIMENSION PL(LEN), ACR(LEN)
      DIMENSION IWK(LEN)
      DIMENSION PH(15), A(15), AD(15), AU(15), AC(15)
      LOGICAL FIRST
      DATA    FIRST/.TRUE./
C
      DATA PH/150.0, 200.0, 250.0, 300.0, 350.0, 400.0, 450.0, 500.0
     *,       550.0, 600.0, 650.0, 700.0, 750.0, 800.0, 850.0/
C
      DATA A/ 1.6851, 1.1686, 0.7663, 0.5255, 0.4100, 0.3677
     *,       0.3151, 0.2216, 0.1521, 0.1082, 0.0750, 0.0664
     *,       0.0553, 0.0445, 0.0633/
C
      DATA AD/15*0.0/, AC/15*0.0/, ACTOP/0.0/

C
      IF (FIRST) THEN
         FIRST   = .FALSE.
         ACTOP   = ACTP*FACM
         DO 5 L=1,15
         A(L) = A(L)*FACM
    5    CONTINUE
         DO 10 L=2,15
         TEM   = PH(L) - PH(L-1)
         AU(L) = A(L-1) / TEM
         AD(L) = A(L)   / TEM
         AC(L) = PH(L)*AU(L) - PH(L-1)*AD(L)
         AD(L) = AD(L) - AU(L)
   10    CONTINUE
      ENDIF
C
      DO 20 I=1,LEN
      IWK(I) = PL(I) * 0.02 - 0.999999999
      IF (IWK(I) .GT. 1) THEN
         IF (IWK(I) .LE. 15) THEN
            ACR(I) = AC(IWK(I)) + PL(I) * AD(IWK(I))
         ELSE
            ACR(I) = A(15)
         ENDIF
      ELSE
         ACR(I) = ACTOP
      ENDIF
   20 CONTINUE
C
      RETURN
      END
      SUBROUTINE SETAB(LEN, LENC, K, PRH, SGO, PII, POI, PIK, ALF, BET
     *,                              GAM, TX1, TX2, TX3, TX4, TX5, TX6)
C
#include "slgcm.slgprm"
C
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C********************* SUBROUTINE  SETAB *****************************
C********************** 17 MAY     1988 ******************************
C*********************************************************************
C
C
C
      DIMENSION ALF(LEN,K), BET(LEN,K),  GAM(LEN ,K)
      DIMENSION PII(LEN),   POI(LEN,K), PIK(LEN),  SGO(K),  PRH(K)
      DIMENSION TX1(LENC),  TX2(LENC),  TX3(LENC), TX4(LENC)
     *,         TX5(LENC),  TX6(LENC)
C     DATA IAX/74/, JAY/02/
C
C     CALCULATE ALF AND BET
C
      DO 100 L=1,K
      DO 10 I=1,LENC
      TX5(I) = PRH(L)*PIK(I)
      TX6(I) = POI(I,L)*TX5(I)
      TX1(I) = PII(I)*SGO(L)
      TX3(I) = TX6(I)
   10 CONTINUE
C
      CALL VQSAT(TX3,TX1,TX2,TX4,LENC,.TRUE.)
C
      DO 20 I=1,LENC
      ALF(I,L) = TX2(I) - TX4(I) * TX6(I)
      BET(I,L) = TX4(I) * TX5(I)
      GAM(I,L) = ONE / (ONE + TX4(I) * ALBYCP)
C
   20 CONTINUE
C
  100 CONTINUE
C     PRINT *,' ALF=',(ALF(IAX,L),L=1,LM)
C     PRINT *,' BET=',(BET(IAX,L),L=1,LM)
C     PRINT *,' GAM=',(GAM(IAX,L),L=1,LM)
C
      RETURN
      END
      SUBROUTINE LSP(LEN, LENC, KM,  CNV, PRH, DSG
     *,              PII, POI, QOI,  ALF, BET, GAM, PKI
     *,              CLN, DTL, DQL, PRE,  TX1, TX2, DT)
C
#include "slgcm.slgprm"
C
C
C*********************************************************************
C*********************** ARIES   MODEL *******************************
C********************* SUBROUTINE  LSP   *****************************
C********************** 16 MARCH   1988 ******************************
C*********************************************************************
C
C
      DIMENSION  POI(LEN,KM), QOI(LEN,KM), PII(LEN), PKI(LEN)
     *,          CLN(LEN,KM), DTL(LEN,KM), DQL(LEN,KM), PRE(LEN)
      DIMENSION  TX1(LENC),   TX2(LENC)
     *,          TX3(LENC),   TX4(LENC), TX5(LENC), TX6(LENC)
     *,          IA(LENC)
      DIMENSION  CNV(KM),     PRH(KM),     DSG(KM)
C
      REAL   ALF(LEN,KM), BET(LEN,KM), GAM(LEN,KM)
C
      LOGICAL RAIN
C     DATA IAX/74/, JAY/02/
      DATA RAIN /.FALSE./
C
C     LARGE SCALE PRECIPITATION OCCURS WHEN LAYER IS SUPERSATURATED
C
      DO 100 L=1,KM
C
      LENA = 0
      DO 10 I=1,LENC
      TX1(I) = (ALF(I,L) + BET(I,L) * POI(I,L))*RHCLSP - QOI(I,L)
      IF (TX1(I) .LT. ZERO) THEN
         LENA = LENA + 1
         IA(LENA) = I
         TX2(LENA) = TX1(I) * GAM(I,L)
      ENDIF
10    CONTINUE
c     print *,' after 10 loop'
      IF (LENA .LE. 0) GO TO 100
C
      DO 20 I=1,LENA
      II = IA(I)
C     TX2(I) = TX2(I) / (BET(II,L) * PKI(II) * (ALBYCP/PRH(L)) + ONE)
      TX1(I) = CLN(II,L) - TX2(I)*(DAYLEN/(QCRT*DT))
      IF (TX1(I) .GT. ONE) TX1(I) = ONE
20    CONTINUE
c     print *,' after 20 loop'
C
C   CLOUDINESS
C
C     TX1(1;LENC) = (QCRT*DT/(CNV(L)*DAYLEN)) / PII(1;LENC)
C     WHERE(TX2(1;LENC) .LT. -TX1(1;LENC))
C    *CLN(1,L;LENC) = CLN(1,L;LENC) + ONE
C     WHERE(CLN(1,L;LENC) .GT. ONE) CLN(1,L;LENC) = ONE
C
C     TX1(1  ;LENC) = - PII(1;LENC) * (CNV(L)*DAYLEN/(QCRT*DT))
C     CLN(1,L;LENC) =   TX2(1;LENC) * TX1(1;LENC)
C     WHERE(CLN(1,L;LENC) .GT. ONE) CLN(1,L;LENC) = ONE
C
C
      DO 40 I=1,LENA
      II = IA(I)
      CLN(II,L) = TX1(I)
      TX1(I)   = TX2(I)   * PKI(II)
      TX3(I)   = QOI(II,L) + TX2(I)
      TX4(I)   = POI(II,L) - TX1(I) * (ALBYCP/PRH(L))
      TX5(I)   = DTL(II,L) - TX2(I) * (ALBYCP*DAYLEN/DT)
      TX6(I)   = DQL(II,L) + TX2(I) * (DAYLEN/DT)
40    CONTINUE
c     print *,' after 40 loop'
      DO 60 I=1,LENA
      II = IA(I)
      QOI(II,L) = TX3(I)
      POI(II,L) = TX4(I)
      DTL(II,L) = TX5(I)
      DQL(II,L) = TX6(I)
60    CONTINUE
C
      IF (RAIN .OR. L .EQ. KM) THEN
         DO 70 I=1,LENA
         II = IA(I)
         TX3(I) = PRE(II) - TX2(I) * PII(II) * (CNV(L)*DAYLEN/DT)
70       CONTINUE
         DO 75 I=1,LENA
         PRE(IA(I)) = TX3(I)
75       CONTINUE
      ELSE
         DO 80 I=1,LENA
         II = IA(I)
         TX3(I) = QOI(II,L+1) - TX2(I) * (DSG(L)/DSG(L+1))
         TX4(I) = POI(II,L+1) + TX1(I)
     *                           * (ALBYCP*DSG(L)/(DSG(L+1)*PRH(L+1)))
         TX5(I) = DTL(II,L+1) + TX2(I)
     *                           * (ALBYCP*DSG(L)/DSG(L+1)*DAYLEN/DT)
80       CONTINUE
         DO 85 I=1,LENA
         II = IA(I)
         QOI(II,L+1) = TX3(I)
         POI(II,L+1) = TX4(I)
         DTL(II,L+1) = TX5(I)
85       CONTINUE
      ENDIF
C
100   CONTINUE
c     print *,' after 85 loop'
c     imx1 = ismax(ijm0m0, pre, 1)
c     imn1 = ismin(ijm0m0, pre, 1)
c     print *,' imx1=',imx1,' pre=',pre(imx1)
c    *,       ' imn1=',imn1,' pre=',pre(imn1)
c     print *,' poi=',poi(imx1,km),poi(imn1,km),' qoi=',qoi(imx1,km)
c    *, qoi(imn1,km),' km=',km
c     print *,' albycp=',albycp,' daylen=',daylen,' dt=',dt,' dsg=',dsg
C
      RETURN
      END

