SUBROUTINE clo89(cldfac,camt,nclds,kbtm,ktop)
  !
  ! $Author: CPTEC $
  ! $Date: 2000/02/24 13:15:43 $
  ! $Revision: 1.0 $
  !
  !subroutine clo88 computes cloud transmission functions for the
  !longwave code,using code written by bert katz (301-763-8161).
  !and modified by dan schwarzkopf in december,1988.
  IMPLICIT NONE
  INCLUDE "parmeta.f90"
  INTEGER, PARAMETER :: l= lm,imax= 2*im-1,ncol=imax,nblw=163,nblx=47,nbly=15
  INTEGER, PARAMETER :: nblm=nbly-1
  INTEGER, PARAMETER :: lp1=l+1,lp2=l+2
  INTEGER, PARAMETER :: lp3=l+3,lm1=l-1,lm2=l-2,lm3=l-3,ll=2*l,llp1=ll+1
  INTEGER, PARAMETER :: llp2=ll+2,llp3=ll+3,llm1=ll-1,llm2=ll-2,llm3=ll-3
  INTEGER, PARAMETER :: lp1m=lp1*lp1,lp1m1=lp1m-1,lp1v=lp1*(1+2*l/2)
  INTEGER, PARAMETER :: lp121=lp1*nbly,ll3p=3*l+2,nb=12,inlte=3,inltep=inlte+1
  INTEGER, PARAMETER :: nnlte=56,lp1i=imax*lp1,llp1i=imax*llp1,ll3pi=imax*ll3p
  INTEGER, PARAMETER :: nb1=nb-1,ko2=12,ko21=ko2+1,ko2m=ko2-1

  REAL,DIMENSION(imax,lp1,lp1),INTENT(out) :: cldfac
  REAL,DIMENSION(imax,lp1),INTENT(in) :: camt
  INTEGER,DIMENSION(imax),INTENT(in)  :: nclds(imax)
  INTEGER,DIMENSION(imax,lp1),INTENT(in) :: kbtm,ktop

  REAL :: amolwt,csubp,diffctr,g,gravdr,o3difctr,p0,p0xzp2,p0xzp8,p0x2,radcon
  REAL :: rgas,rgassp,secpda,ratco2mw,rath2omw,radcon1,ginv,p0inv,gp0inv
  REAL :: hundred,hninety,sixty,fifty,ten,eight,five,four,three,two,one,haf
  REAL :: quartr,zero,h83e26,h71e26,h1e15,h1e13,h1e11,h1e8,h4e5,h165e5,h5725e4
  REAL :: h488e4,h1e4,h24e3,h20788e3,h2075e3,h1224e3,h5e2,h3082e2,h3e2,h2945e2
  REAL :: h23e2,h15e2,h35e1,h3p6,h181e1,h18e1,h2p9,h2p8,h2p5,h1p8,h1p4387,h1p4
  REAL :: h1p25892,hp8,hp518, hp369,hp1,h44871m2,h559m3,h1m3,h987m4,h285m4,h1m4
  REAL :: h6938m5,h394m5,h37412m5,h1439m5,h128m5,h1m5,h7m6,h4999m6,h25452m6,h1m6
  REAL :: h391m7,h1174m7,h8725m8,h327m8,h257m8,h1m8,h23m10,h14m10,h11m10,h1m10
  REAL :: h83m11,h82m11,h8m11,h77m11,h72m11,h53m11,h48m11,h44m11,h42m11,h37m11
  REAL :: h35m11,h32m11,h3m11,h28m11,h24m11,h23m11,h2m11,h18m11,h15m11,h14m11
  REAL :: h114m11,h11m11,h1m11,h96m12,h93m12,h77m12,h74m12,h65m12,h62m12,h6m12
  REAL :: h45m12,h44m12,h4m12,h38m12,h37m12,h3m12,h29m12,h28m12,h24m12,h21m12
  REAL :: h16m12,h14m12,h12m12,h8m13,h46m13,h36m13,h135m13,h12m13,h1m13,h3m14
  REAL :: h15m14,h14m14,h1m17,h1m18,h1m19,h1m20,h1m21,h1m22,h1m23,h1m24,h26m30
  REAL :: h14m30,h25m31,h21m31,h12m31,h9m32,h55m32,h45m32,h4m33,h62m34,h1m60
  REAL :: hmp575,hm13ez,hm19ez,hm1e1,hm181e1,hm1e2,h1e6,h2e6,h1m2,hmp66667
  REAL :: hm6666m2,hp166666,h41666m2,hmp5,hm2m2,h29316e2,h1226e1,h3116e1,h9p94
  REAL :: hp6,h625m2,hp228,hp60241,hm1797e1,h8121e1,h2e2,hm1ez,h26e2,h44194m2
  REAL :: h1p41819,hp219,hp144,hp816,h69766e5,h235m3,hp26,h129m2,h75826m4,h1p082
  REAL :: hp805,h1386e2, h658m2,h1036e2,h2118m2,h42m2,h323m4,h67390e2,hp3795
  REAL :: hp5048,h102m5,h451m6,h16e1,hm161e1,h161e1,h3m3,h101m16,hm1597e1,h25e2
  REAL :: hp118666,h15m5,h3p5,h18e3,h6p08108,hmp805,hp602409,hp526315,h28571m2
  REAL :: h1m16,h3m4,hm8e1,h28e1

  COMMON/phycon/amolwt,csubp,diffctr,g,gravdr,o3difctr,p0,  &
       p0xzp2,p0xzp8,p0x2,radcon,rgas,rgassp,secpda
  COMMON/phycon/ratco2mw,rath2omw
  COMMON/phycon/radcon1
  COMMON/phycon/ginv,p0inv,gp0inv
  COMMON/hcon/hundred,hninety,sixty,fifty,ten,eight,five,  &
       four,three,two,one,haf,quartr,zero
  COMMON/hcon/h83e26,h71e26,h1e15,h1e13,h1e11,h1e8,h4e5,  &
       h165e5,h5725e4,h488e4,h1e4,h24e3,h20788e3,  &
       h2075e3,h1224e3,h5e2,h3082e2,h3e2,h2945e2,  &
       h23e2,h15e2,h35e1,h3p6,h181e1,h18e1,h2p9,h2p8,  &
       h2p5,h1p8,h1p4387,h1p4,h1p25892,hp8,hp518, hp369,hp1
  COMMON/hcon/h44871m2,h559m3,h1m3,h987m4,h285m4,h1m4,  &
       h6938m5,h394m5,h37412m5,h1439m5,h128m5,h1m5,  &
       h7m6,h4999m6,h25452m6,h1m6,h391m7,h1174m7,  &
       h8725m8,h327m8,h257m8,h1m8,h23m10,h14m10,  &
       h11m10,h1m10,h83m11,h82m11,h8m11,h77m11,  &
       h72m11,h53m11,h48m11,h44m11,h42m11,h37m11,  &
       h35m11,h32m11,h3m11,h28m11,h24m11,h23m11,  &
       h2m11,h18m11,h15m11,h14m11,h114m11,h11m11,  &
       h1m11,h96m12,h93m12,h77m12,h74m12,h65m12,  &
       h62m12,h6m12,h45m12,h44m12,h4m12,h38m12,  &
       h37m12,h3m12,h29m12,h28m12,h24m12,h21m12,  &
       h16m12,h14m12,h12m12,h8m13,h46m13,h36m13,  &
       h135m13,h12m13,h1m13,h3m14,h15m14,h14m14,  &
       h1m17,h1m18,h1m19,h1m20,h1m21,h1m22,h1m23,  &
       h1m24,h26m30,h14m30,h25m31,h21m31,h12m31,  &
       h9m32,h55m32,h45m32,h4m33,h62m34,h1m60
  COMMON/hcon/hmp575,hm13ez,hm19ez,hm1e1,hm181e1,hm1e2
  COMMON/hcon/h1e6,h2e6,h1m2,hmp66667,hm6666m2,hp166666,  &
       h41666m2,hmp5,hm2m2,h29316e2,h1226e1,h3116e1,  &
       h9p94,hp6,h625m2,hp228,hp60241,hm1797e1,  &
       h8121e1,h2e2,hm1ez,h26e2,h44194m2,h1p41819
  COMMON/hcon/hp219,hp144,hp816,h69766e5,h235m3,hp26,  &
       h129m2,h75826m4,h1p082,hp805,h1386e2, h658m2,h1036e2,h2118m2,h42m2,h323m4,  &
       h67390e2,hp3795,hp5048,h102m5,h451m6
  COMMON/hcon/h16e1,hm161e1,h161e1,h3m3,h101m16,  &
       hm1597e1,h25e2,hp118666,h15m5,h3p5,h18e3,  &
       h6p08108,hmp805,hp602409,hp526315, h28571m2,h1m16
  COMMON/hcon/h3m4
  COMMON/hcon/hm8e1
  COMMON/hcon/h28e1

  !parameter settings for the longwave and shortwave radiation code:
  !   imax   =  no. points along the lat. circle used in calcs.
  !   l      =  no. vertical levels (also layers) in model
  !note: the user normally will modify only the imax and l parameters
  !   nblw   =  no. freq. bands for approx computations. see
  !                      bandta for definition
  !   nblx   =  no. freq bands for approx cts computations
  !   nbly   =  no. freq. bands for exact cts computations. see
  !                      bdcomb for definition
  !   inlte  =  no. levels used for nlte calcs.
  !   nnlte  =  index no. of freq. band in nlte calcs.
  !   nb,ko2 are shortwave parameters; other quantities are derived
  !                    from the above parameters.

  REAL,DIMENSION(lp1) :: cldrow
  REAL,DIMENSION(lp1,lp1, imax ) :: cldipt
  !real,dimension(lp1,lp1) :: cldfip
  INTEGER :: i,j,k1,kb,ip,jtop,ir,itop,iq,nc,kp,k,kt,k2
  REAL :: xcld

  DO  iq=1,imax, imax
     itop=iq+( imax -1)
     IF(itop > imax) itop=imax
     jtop=itop-iq+1
     DO  ip=1,jtop
        ir=iq+ip-1
        IF (nclds(ir) == 0) THEN
           DO  j=1,lp1
              DO  i=1,lp1
                 cldipt(i,j,ip)=1.
              END DO
           END DO
        END IF
        IF (nclds(ir) >= 1) THEN
           xcld=1.-camt(ir,2)
           k1=ktop(ir,2)+1
           k2=kbtm(ir,2)
           DO  j=1,lp1
              cldrow(j)=1.
           END DO
           DO  j=1,k2
              cldrow(j)=xcld
           END DO
           kb=MAX(k1,k2+1)
           DO  k=kb,lp1
              DO  kp=1,lp1
                 cldipt(kp,k,ip)=cldrow(kp)
              END DO
           END DO
           DO  j=1,lp1
              cldrow(j)=1.
           END DO
           DO  j=k1,lp1
              cldrow(j)=xcld
           END DO
           kt=MIN(k1-1,k2)
           DO  k=1,kt
              DO  kp=1,lp1
                 cldipt(kp,k,ip)=cldrow(kp)
              END DO
           END DO
           IF(k2+1 <= k1-1) THEN
              DO  j=k2+1,k1-1
                 DO  i=1,lp1
                    cldipt(i,j,ip)=1.
                 END DO
              END DO
           ELSE IF(k1 <= k2) THEN
              DO  j=k1,k2
                 DO  i=1,lp1
                    cldipt(i,j,ip)=xcld
                 END DO
              END DO
           END IF
        END IF
        IF (nclds(ir) >= 2) THEN
           DO  nc=2,nclds(ir)
              xcld=1.-camt(ir,nc+1)
              k1=ktop(ir,nc+1)+1
              k2=kbtm(ir,nc+1)
              DO  j=1,lp1
                 cldrow(j)=1.
              END DO
              DO  j=1,k2
                 cldrow(j)=xcld
              END DO
              kb=MAX(k1,k2+1)
              DO  k=kb,lp1
                 DO  kp=1,lp1
                    cldipt(kp,k,ip)=cldipt(kp,k,ip)*cldrow(kp)
                    !              cldfip(kp,k)=cldrow(kp)
                 END DO
              END DO
              DO  j=1,lp1
                 cldrow(j)=1.
              END DO
              DO  j=k1,lp1
                 cldrow(j)=xcld
              END DO
              kt=MIN(k1-1,k2)
              DO  k=1,kt
                 DO  kp=1,lp1
                    cldipt(kp,k,ip)=cldipt(kp,k,ip)*cldrow(kp)
                    !             cldfip(kp,k)=cldrow(kp)
                 END DO
              END DO
              !         if(k2+1.le.k1-1) then
              !           do 51 j=k2+1,k1-1
              !           do 51 i=1,lp1
              !               cldipt(i,j,ip)=1.
              !51         continue
              IF(k1 <= k2) THEN
                 DO  j=k1,k2
                    DO  i=1,lp1
                       cldipt(i,j,ip)=cldipt(i,j,ip)*xcld
                    END DO
                 END DO
              END IF
              !           do 65 j=1,lp1
              !           do 65 i=1,lp1
              !         cldipt(i,j,ip)=cldipt(i,j,ip)*cldfip(i,j)
              !65       continue
           END DO
        END IF
     END DO
     DO  j=1,lp1
        DO  i=1,lp1
           DO  ip=1,jtop
              ir=iq+ip-1
              cldfac(ir,i,j)=cldipt(i,j,ip)
           END DO
        END DO
     END DO
  END DO
END SUBROUTINE clo89
