!OPTIONS XOPT(HSFUN)
SUBROUTINE CLOUDVAR &
 !---input
 & (KIDIA,   KFDIA,    KLON,   KLEV,  KTOP,  KBOT,  &
 & PQ,       PSAT,     PLSUM,  &
 & PVAR,     PQTMIN,   PQTMAX)  

! *CLOUDVAR* -  

!     A.TOMPKINS     E.C.M.W.F.     2003 

!     PURPOSE
!     -------

!       THIS ROUTINE CALCULATES THE VARIANCE OF THE TOTAL WATER 
!       FIELD FROM THE HUMIDITY AND CLOUD WATER USING A SYMMETRICAL
!       BETA DISTRIBUTION

!**   INTERFACE.
!     ----------

!     *CLOUDVAR* IS CALLED FROM *CALLPAR*
!     ROUTINE TAKES Q,QSAT and QL AS INPUT
!     OUTPUT IS THE VARIANCE OF THE TOTAL WATER DISTRIBUTION

!     EXTERNALS.
!     ----------
!          NONE

!     MODIFICATIONS.
!     -------------
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        D.Salmond     07-Sep-2009 Must be compiled with STRICT

!     SWITCHES.
!     --------

!     MODEL PARAMETERS
!     ----------------

!     REFERENCE.
!     ----------
!          Tompkins 2002, J. Atmos. Sci.

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOECLDP,   ONLY : NSHAPEP, NSHAPEQ, NBETA, RBETA, RBETAP1
USE YOECLDPX,  ONLY : ZRBETA, ZRBETAP1

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KLON 
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV 
INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA 
INTEGER(KIND=JPIM),INTENT(IN)    :: KTOP 
INTEGER(KIND=JPIM),INTENT(IN)    :: KBOT 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PQ(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSAT(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PLSUM(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PVAR(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PQTMIN(KLON,KLEV) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PQTMAX(KLON,KLEV) 

!---input variables
!---local fields
REAL(KIND=JPRB) ::     ZL(KLON), ZQT(KLON)  
REAL(KIND=JPRB) :: ZTEMP,ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4

INTEGER(KIND=JPIM) :: JK, JL, JT, JX


!   Pointers and counters for iteration and diagnostic loop:

INTEGER(KIND=JPIM) :: IIIDX(KLON) ! iteration index

!   variables required for zriddr iteration scheme:

REAL(KIND=JPRB) ::                    &
 & ZFH(KLON),ZFL(KLON),ZFM(KLON),ZFNEW(KLON),            &
 & ZXH(KLON),ZXL(KLON),ZXM(KLON),ZXNEW(KLON),            &
 & ZTT,ZSQARG, ZWIDE,ZLIM  
LOGICAL :: LLITER(KLON), LLL, LLFLAG

!   number of iteration loops.  In a small test, most gridpoints
!   converged in 2 to 4 iterations, with occassionally as many as
!   8 needed for an accuracy of 0.01*(ql+qi). Don't set too high since
!   the loops are all performed, albeit often as "empty loops" (i.e.
!   LITER is false because of convergence), due to vectorisation needs.

INTEGER(KIND=JPIM), PARAMETER :: IITER=20              ! max loop number
REAL(KIND=JPRB)   , PARAMETER :: ZITER_ACC=1.E-2_JPRB  ! iteration accuracy*(ql+qi)
REAL(KIND=JPRB)   , PARAMETER :: ZEPS2=-1.0E30_JPRB

INTEGER(KIND=JPIM) :: JJ,JJJ,JINDEX(KLON+1)
REAL(KIND=JPRB)    :: ZJX,ZNBETA,ZSQART

REAL(KIND=JPRB) :: ZFUNCR, ZQTMIN, ZX, ZBETAP, ZBETAPP1, ZFAC
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "fjfns.h"

!DIR$ VFUNCTION EXPHF
!#include "fcttre.h"

! Master loop in Z.

IF (LHOOK) CALL DR_HOOK('CLOUDVAR',0,ZHOOK_HANDLE)

!opt
ZTEMP=NSHAPEP/(NSHAPEP+NSHAPEQ)
ZTEMP1=1.0_JPRB/(NSHAPEP+NSHAPEQ)
ZTEMP2=NSHAPEP*NSHAPEQ/(NSHAPEP+NSHAPEQ+1.0_JPRB)
ZTEMP3=(NSHAPEP+NSHAPEQ)/NSHAPEP
ZTEMP4=1.0_JPRB/NSHAPEQ

DO JJ=0,100
   ZRBETA(JJ) = RBETA(JJ)
   ZRBETAP1(JJ) = RBETAP1(JJ)
ENDDO
ZRBETA(101) = 0.0_JPRB
ZRBETAP1(101) = 0.0_JPRB

DO JK=KTOP,KBOT

! CC clean up

  DO JL=KIDIA,KFDIA
    ZL(JL)=PLSUM(JL,JK)
    ZQT(JL)=PQ(JL,JK)+ZL(JL) !total water
  ENDDO

!   Don't need to iterate at every gridpoint, thus make pointers

  DO JL=KIDIA,KFDIA
    LLITER(JL)=.FALSE.
    IF (ZL(JL)<=0.0_JPRB) THEN ! clear sky points
      IIIDX(JL)=0
    ELSEIF (PQ(JL,JK)>=PSAT(JL,JK)) THEN ! overcast points
      IIIDX(JL)=1
    ELSE ! partially cloudy points
      IIIDX(JL)=2
      LLITER(JL)=.TRUE.
    ENDIF
  ENDDO

!   Partially cloudy: Iterative gridpoints
!   uses func using ridders' method, return the root of a function
!   Method: See Numerical Recipes

  DO JL=KIDIA,KFDIA
    IF (IIIDX(JL) == 2) THEN 
      ZXL(JL)=-1.0_JPRB
      ZQTMIN=ZXL(JL)
!---func---
!opt  ZX=NSHAPEP*(PSAT(JL,JK)-ZQTMIN)/((NSHAPEP+NSHAPEQ)*(ZQT(JL)-ZQTMIN))
      ZX=ZTEMP*(PSAT(JL,JK)-ZQTMIN)/(ZQT(JL)-ZQTMIN)
      ZX=MAX(MIN(ZX,1.0_JPRB),0.0_JPRB)
      JX=INT(ZX*NBETA)
      ZFAC=ZX*NBETA-JX
      IF (JX < NBETA) THEN 
        ZBETAP=(1.0_JPRB-ZFAC)*RBETA(JX)+ZFAC*RBETA(JX+1)
        ZBETAPP1=(1.0_JPRB-ZFAC)*RBETAP1(JX)+ZFAC*RBETAP1(JX+1)
        ZFUNCR=(ZQT(JL)-ZQTMIN)*ZBETAPP1+(ZQTMIN-PSAT(JL,JK))*ZBETAP+PSAT(JL,JK)+ZL(JL)-ZQT(JL)
      ELSE  
        ZFUNCR=ZL(JL)
      ENDIF
!---func---
      ZFL(JL)=ZFUNCR

!   2 conditions for the maximum iteration bound: a<qs,a<qv and b>qs

!opt  ZLIM=(ZQT(JL)*(NSHAPEP+NSHAPEQ)-PSAT(JL,JK)*NSHAPEP)/NSHAPEQ
      ZLIM=(ZQT(JL)*(NSHAPEP+NSHAPEQ)-PSAT(JL,JK)*NSHAPEP)*ZTEMP4
      ZXH(JL)=MIN(PQ(JL,JK),PSAT(JL,JK),ZLIM) !upper bound for a
      ZQTMIN=ZXH(JL)
!---func---
!opt  ZX=NSHAPEP*(PSAT(JL,JK)-ZQTMIN)/((NSHAPEP+NSHAPEQ)*(ZQT(JL)-ZQTMIN))
      ZX=ZTEMP*(PSAT(JL,JK)-ZQTMIN)/(ZQT(JL)-ZQTMIN)
      ZX=MAX(MIN(ZX,1.0_JPRB),0.0_JPRB)
      JX=INT(ZX*NBETA)
      ZFAC=ZX*NBETA-JX
      IF (JX < NBETA) THEN 
        ZBETAP=(1.0_JPRB-ZFAC)*RBETA(JX)+ZFAC*RBETA(JX+1)
        ZBETAPP1=(1.0_JPRB-ZFAC)*RBETAP1(JX)+ZFAC*RBETAP1(JX+1)
        ZFUNCR=(ZQT(JL)-ZQTMIN)*ZBETAPP1+(ZQTMIN-PSAT(JL,JK))*ZBETAP+PSAT(JL,JK)+ZL(JL)-ZQT(JL)
      ELSE  
        ZFUNCR=ZL(JL)
      ENDIF
!---func---
      ZFH(JL)=ZFUNCR

      IF (ZXL(JL)==ZXH(JL)) LLITER(JL)=.FALSE.
      ZXNEW(JL)=ZEPS2
    ENDIF 
  ENDDO

  ZNBETA=NBETA
  LLFLAG=.TRUE.
  DO JT=1,IITER   ! short iteration loop

    JJ=0
    IF(LLFLAG)THEN
    DO JL=KIDIA,KFDIA
      IF (LLITER(JL)) THEN
        JJ=JJ+1
        JINDEX(JJ)=JL
      ENDIF
    ENDDO
    ENDIF
    LLFLAG=.FALSE.
!
    DO JJJ=1,JJ
      JL=JINDEX(JJJ)
        ZXM(JL)=0.5_JPRB*(ZXL(JL)+ZXH(JL))
        ZQTMIN=ZXM(JL)
!---func---
!opt    ZX=NSHAPEP*(PSAT(JL,JK)-ZQTMIN)/((NSHAPEP+NSHAPEQ)*(ZQT(JL)-ZQTMIN))
        ZX=ZTEMP*(PSAT(JL,JK)-ZQTMIN)/(ZQT(JL)-ZQTMIN)
        ZX=MAX(MIN(ZX,1.0_JPRB),0.0_JPRB)
        ZJX=ZFRIZ(ZX*ZNBETA)
        JX=INT(ZJX)
        ZFAC=ZX*ZNBETA-ZJX
        ZBETAP=(1.0_JPRB-ZFAC)*ZRBETA(JX)+ZFAC*ZRBETA(JX+1)
        ZBETAPP1=(1.0_JPRB-ZFAC)*ZRBETAP1(JX)+ZFAC*ZRBETAP1(JX+1)
        ZFUNCR=(ZQT(JL)-ZQTMIN)*ZBETAPP1+(ZQTMIN-PSAT(JL,JK))*ZBETAP+PSAT(JL,JK)+ZL(JL)-ZQT(JL)
        IF (ZX == 1.0_JPRB) ZFUNCR=ZL(JL)
!---func---
        ZFM(JL)=ZFUNCR
        ZSQARG=ZFM(JL)**2-ZFL(JL)*ZFH(JL)
        ZSQART=MAX(ZSQARG,1E-100_JPRB)
        ZTT=SQRT(ZSQART)
        ZTT=ZXM(JL)+(ZXM(JL)-ZXL(JL)) &
         & *(SIGN(1.0_JPRB,ZFL(JL)-ZFH(JL))*ZFM(JL)/ZTT) !update formula  
        IF(ZSQARG <= 0.0_JPRB) ZTT = ZXNEW(JL)

        LLL = ABS(ZXNEW(JL)-ZTT) <= ZITER_ACC*ZL(JL)
        LLITER(JL) = .NOT.LLL
        LLFLAG=LLFLAG.OR..NOT.LLL
        ZXNEW(JL)=ZTT
! only ZXNEW is needed once we have decided to stop iterating
        IF(.NOT.LLITER(JL)) CYCLE
        ZQTMIN=ZXNEW(JL)
!---func---
!opt    ZX=NSHAPEP*(PSAT(JL,JK)-ZQTMIN)/((NSHAPEP+NSHAPEQ)*(ZQT(JL)-ZQTMIN)
        ZX=ZTEMP*(PSAT(JL,JK)-ZQTMIN)/(ZQT(JL)-ZQTMIN)
        ZX=MAX(MIN(ZX,1.0_JPRB),0.0_JPRB)
        ZJX=ZFRIZ(ZX*ZNBETA)
        JX=INT(ZJX)
        ZFAC=ZX*ZNBETA-ZJX
        ZBETAP=(1.0_JPRB-ZFAC)*ZRBETA(JX)+ZFAC*ZRBETA(JX+1)
        ZBETAPP1=(1.0_JPRB-ZFAC)*ZRBETAP1(JX)+ZFAC*ZRBETAP1(JX+1)
        ZFUNCR=(ZQT(JL)-ZQTMIN)*ZBETAPP1+(ZQTMIN-PSAT(JL,JK))*ZBETAP+PSAT(JL,JK)+ZL(JL)-ZQT(JL)
        IF (ZX == 1.0_JPRB) ZFUNCR=ZL(JL)
!---func---
        ZFNEW(JL)=ZFUNCR

!   bookkeeping to keep the root bracketed on next iteration.

        IF (SIGN(ZFM(JL),ZFNEW(JL)) /= ZFM(JL)) THEN
          ZXL(JL)=ZXM(JL)
          ZFL(JL)=ZFM(JL)
          ZXH(JL)=ZXNEW(JL)
          ZFH(JL)=ZFNEW(JL)
        ELSEIF(SIGN(ZFL(JL),ZFNEW(JL)) /= ZFL(JL)) THEN
          ZXH(JL)=ZXNEW(JL)
          ZFH(JL)=ZFNEW(JL)
        ELSEIF (SIGN(ZFH(JL),ZFNEW(JL)) /= ZFH(JL)) THEN
          ZXL(JL)=ZXNEW(JL)
          ZFL(JL)=ZFNEW(JL)
        ENDIF

    ENDDO !jl
  ENDDO !IITER

! set up min and max
  DO JL=KIDIA,KFDIA
    IF (IIIDX(JL) == 0) THEN 
!     clear sky
      ZWIDE=MIN(0.2_JPRB*PSAT(JL,JK),PSAT(JL,JK)-PQ(JL,JK))
      PQTMIN(JL,JK)=PQ(JL,JK)-ZWIDE
      PQTMAX(JL,JK)=PQ(JL,JK)+ZWIDE
    ELSEIF (IIIDX(JL) == 1) THEN 
!     overcast sky
      ZWIDE=MIN(0.05_JPRB*PSAT(JL,JK),ZL(JL))
      PQTMIN(JL,JK)=PSAT(JL,JK)+ZL(JL)-ZWIDE
      PQTMAX(JL,JK)=PSAT(JL,JK)+ZL(JL)+ZWIDE
    ELSEIF (IIIDX(JL) == 2) THEN 
      PQTMIN(JL,JK)=ZXNEW(JL)
!opt  PQTMAX(JL,JK)=(ZQT(JL)-PQTMIN(JL,JK))*(NSHAPEP+NSHAPEQ)/NSHAPEP+PQTMIN(JL,JK)
      PQTMAX(JL,JK)=(ZQT(JL)-PQTMIN(JL,JK))*ZTEMP3+PQTMIN(JL,JK)
    ENDIF
!opt PVAR(JL,JK)=NSHAPEP*NSHAPEQ*((PQTMAX(JL,JK)-PQTMIN(JL,JK))/&
!    & (NSHAPEP+NSHAPEQ))**2./(NSHAPEP+NSHAPEQ+1.0_JPRB)  
    PVAR(JL,JK)=((PQTMAX(JL,JK)-PQTMIN(JL,JK))*ZTEMP1)**2. *ZTEMP2
    PVAR(JL,JK)=MAX(PVAR(JL,JK),0.0_JPRB)
  ENDDO
ENDDO ! Vertical loop in K

IF (LHOOK) CALL DR_HOOK('CLOUDVAR',1,ZHOOK_HANDLE)
END SUBROUTINE CLOUDVAR
