col2box.F90

Go to the documentation of this file.

SUBROUTINE col2box &
 & (kidia, kfdia, klon, klev, kbox, kovlp &
 & , pclfr, pclbx &
 & )
!
!* Subdivide a column of cloud parameters in a set of homogeneous boxes
!
!     from C.Jakob and S.A. Klein
!
!-----------------------------------------------------------------------

#include "tsmbkind.h"

integer_m :: kidia
integer_m :: kfdia
integer_m :: klon
integer_m :: klev
integer_m :: kbox
integer_m :: kovlp

real_b :: pclfr(klon,klev)
real_b :: pclbx(klon,100,klev)
            
!-- local
      
integer_m :: iabox(klon,kbox), iaboxm1(klon,kbox), iaboxint(klon,kbox)
integer_m :: iboxtype1(klon), iboxtype2(klon), iboxtype3(klon)
integer_m :: isumbox(kbox), isumboxm1(kbox)

real_b :: ztcc(klon)      
       
                  
zboxwidth=1./float(kbox)
zamin =1.e-03
zepsec=1.e-06
      
DO jb=1,kbox
  DO jl=kidia,kfdia
    iaboxint(jl,jb)=0
    iaboxm1(jl,jb)=0
    iabox(jl,jb)=0
  END DO
END DO 
DO jl=kidia,kfdia
  ztcc(jl)     =_zero_
  isumbox(jl)  =_zero_
  isumboxm1(jl)=_zero_
END DO                             
                                            
                                                               
DO jk=1,klev
!
  IF (jk.GT.1) THEN
    DO jb=1,kbox
      DO jl=kidia,kfdia
        iaboxm1(jl,jb)=iabox(jl,jb)
        isumboxm1(jl)=isumboxm1(jl)+iabox(jl,jb)
        iabox(jl,jb)=0
      END DO
    END DO
  END IF
      
  DO jl=kidia,kfdia
    itccm1=nint(REAL(kbox)*ZTCC(jl))           
    IF (ztcc(jl).GT.zamin .AND. ztcc(jl).LT._half_*zboxwidth) THEN
      itccm1=1
    END IF
!
!-- various cloud overlap assumptions
!
    IF (jk.GT.1) THEN 
!
!-- maximum-random
!       
      IF (kovlp.EQ.1) THEN
        ztcc(jl) = _one_ - ( (_one_-ztcc(jl)) &
         &      *(_one_ -max( pclfr(jl,jk)  , pclfr(jl,jk-1))) &
         &      /(_one_ -min( pclfr(jl,jk-1), _one_-zepsec))  )
!
!-- maximum
!       
      ELSE IF (kovlp.EQ.2) THEN
        ztcc(jl)=max(ztcc(jl),pclfr(jl,jk))
!
!-- random
!       
      ELSE IF (kovlp.EQ.3) THEN 
        ztcc(jl)=_one_-(_one_-ztcc(jl))*(_one_-pclfr(jl,jk))
      END IF
!
    ELSE
      ztcc(jl)=pclfr(jl,jk)
    END IF
!
    itcc=nint(REAL(kbox)*ZTCC(jl))
    IF (ztcc(jl).GT.zamin .AND. ztcc(jl).LT. _half_*zboxwidth) THEN
      itcc=1
    END IF
    iam1=isumboxm1(jl)
    ia=nint(REAL(kbox)*PCLFR(jl,jk))
    IF (pclfr(jl,jk).GT.zamin & 
      &       .AND. pclfr(jl,jk).LT. _half_*zboxwidth) THEN       
      ia=1
    END IF
!     
    iboxtype1(jl)=itcc-itccm1
!     IF (KOVLP.NE.3) THEN
    iboxtype2(jl)=min( iam1, ia-iboxtype1(jl))
!     ELSE
!       IBOXTYPE2(JL)=NINT( FLOAT(IAM1)*FLOAT(IA-IBOXTYPE1(JL))
!     &                    /MAX(FLOAT(ITCCM1), ZEPSEC) )
!     END IF       
    iboxtype3(jl)=ia - iboxtype1(jl)-iboxtype2(jl)
  END DO
!
  DO jb=1,kbox
    DO jl=kidia,kfdia
      IF (iaboxint(jl,jb).EQ.0) THEN
        IF (iboxtype1(jl).GT.0) THEN
          iabox(jl,jb)=1
          iaboxint(jl,jb)=1
          iboxtype1(jl)=iboxtype1(jl)-1
        END IF
      ELSE
        IF (iaboxm1(jl,jb).EQ.1) THEN
          IF (iboxtype2(jl).GT.0) THEN
            iabox(jl,jb)=1
            iboxtype2(jl)=iboxtype2(jl)-1
          END IF
        ELSE
          IF (iboxtype3(jl).GT.0) THEN
            iabox(jl,jb)=1
            iboxtype3(jl)=iboxtype3(jl)-1
          END IF
        END IF
      END IF
    END DO
  END DO
!     
  DO jb=1,kbox
    DO jl=kidia,kfdia
      IF (jb.EQ.1) THEN
        iboxtype1(jl)=iboxtype1(jl)+iboxtype2(jl)+iboxtype3(jl)
      END IF
      IF (iabox(jl,jb).EQ.0 .AND. iboxtype1(jl).GT.0) THEN
        iabox(jl,jb)=1
        iboxtype1(jl)=iboxtype1(jl)-1
      END IF
      isumbox(jl)=isumbox(jl)+iabox(jl,jb)
    END DO             
  END DO
  DO jl=kidia,kfdia
    if (jk.GE.21) THEN
      print 9001,(iabox(jl,jb),jb=1,kbox)
    end if  
    DO jb=1,kbox
      pclbx(jl,jb,jk)=float(iabox(jl,jb))
    END DO  
9001 FORMAT(1x,100i1)        
  END DO
      
END DO
      
RETURN
END SUBROUTINE col2box