     MODULE MODULE_BL_MFSHCONVPBL

USE MODULE_MODEL_CONSTANTS

REAL,PARAMETER :: XG = 9.80665

REAL,PARAMETER :: XP00= 1.E5

REAL,PARAMETER :: XMD= 28.9644E-3
REAL,PARAMETER :: XMV= 18.0153E-3
REAL,PARAMETER :: XRD=R_D
REAL,PARAMETER :: XRV=R_V
REAL,PARAMETER :: XCPD=7.* XRD /2.
REAL,PARAMETER :: XCPV=4.* XRV
REAL,PARAMETER :: XCL= 4.218E+3
REAL,PARAMETER :: XCI= 2.106E+3
REAL,PARAMETER :: XTT= 273.16
REAL,PARAMETER :: XLVTT=2.5008E+6
REAL,PARAMETER :: XLSTT=2.8345E+6

REAL,PARAMETER :: XGAMW = (XCL - XCPV) / XRV
REAL,PARAMETER :: XBETAW= (XLVTT/XRV) + (XGAMW * XTT)

REAL,PARAMETER :: LOG_611_14 = 6.415326
REAL,PARAMETER :: LOG_XTT = 5.610058
REAL,PARAMETER :: XALPW= LOG_611_14 + (XBETAW /XTT) + (XGAMW *LOG_XTT)

REAL,PARAMETER :: XGAMI = (XCI - XCPV) / XRV
REAL,PARAMETER :: XBETAI = (XLSTT/XRV) + (XGAMI * XTT)

REAL,PARAMETER :: XALPI = LOG_611_14 + (XBETAI /XTT) + (XGAMI *LOG_XTT)
REAL,PARAMETER :: XLINI = 0.32

REAL, PARAMETER :: XALP_PERT = 0.3

REAL, PARAMETER ::XABUO = 1.
REAL, PARAMETER ::XBENTR = 1.
REAL, PARAMETER ::XBDETR = 0.

REAL, PARAMETER ::XCMF = 0.065

REAL, PARAMETER ::XENTR_DRY = 0.55
REAL, PARAMETER ::XDETR_DRY = 10.
REAL, PARAMETER ::XDETR_LUP = 1.0

REAL, PARAMETER ::XENTR_MF = 0.035
REAL, PARAMETER ::XCRAD_MF = 50.
REAL, PARAMETER ::XKCF_MF = 2.75
REAL, PARAMETER ::XKRC_MF = 1.
REAL, PARAMETER ::XTAUSIGMF = 600.
REAL, PARAMETER ::XPRES_UV = 0.5

REAL, PARAMETER ::XFRAC_UP_MAX= 0.33

     CONTAINS

      SUBROUTINE MFSHCONVPBL (DT,STEPBL,HT,DZ &
                    ,RHO,PMID,PINT,TH,EXNER &
                    ,QV, QC, U, V &
                    ,HFX, QFX, TKE &
                    ,RUBLTEN,RVBLTEN,RTHBLTEN &
                    ,RQVBLTEN,RQCBLTEN &
                    ,IDS,IDE,JDS,JDE,KDS,KDE &
                    ,IMS,IME,JMS,JME,KMS,KME &
                    ,ITS,ITE,JTS,JTE,KTS,KTE,KRR &
                    ,MASSFLUX_EDKF, ENTR_EDKF, DETR_EDKF &
                    ,THL_UP, THV_UP, RT_UP, RV_UP &
                    ,RC_UP, U_UP, V_UP, FRAC_UP, RC_MF &
                    ,WTHV,PLM_BL89 )

      IMPLICIT NONE

      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
     & ,IMS,IME,JMS,JME,KMS,KME &
     & ,ITS,ITE,JTS,JTE,KTS,KTE

      INTEGER,INTENT(IN) :: KRR

      INTEGER,INTENT(IN) :: STEPBL

      REAL,INTENT(IN) :: DT

      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: HT, HFX, QFX

      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: DZ &
     & ,EXNER &
     & ,PMID,PINT &
     & ,QV,QC,RHO &
     & ,TH,U,V,TKE

      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: RQCBLTEN,RQVBLTEN &
     & ,RTHBLTEN &
     & ,RUBLTEN,RVBLTEN

      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),OPTIONAL,INTENT(OUT) :: &
     & MASSFLUX_EDKF, ENTR_EDKF, DETR_EDKF &
     & ,THL_UP, THV_UP, RT_UP, RV_UP &
     & ,RC_UP, U_UP, V_UP, FRAC_UP

      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),OPTIONAL,INTENT(INOUT) :: &
     & RC_MF

      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: WTHV
      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: PLM_BL89

INTEGER :: KRRL
INTEGER :: KRRI
LOGICAL :: OMIXUV

REAL :: PIMPL_MF
REAL :: PTSTEP
REAL :: PTSTEP_MET

REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PZZ

REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PZZM

REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PDZZ

REAL, DIMENSION(ITS:ITE,JTS:JTE) :: PSFTH,PSFRV

REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PPABSM

REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PEXNM
REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PRHODREF

REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PRHODJ

REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PTKEM
REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PUM,PVM

REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PTHM
REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE,KRR) :: PRM

REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PRUS,PRVS,PRTHS
REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE,KRR) :: PRRS

REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PEMF, PENTR, PDETR
REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PTHL_UP, PRT_UP, PRV_UP, PRC_UP
REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PU_UP, PV_UP, PTHV_UP, PFRAC_UP
REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PRC_MF
REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: WTHV_MF
REAL, DIMENSION(ITS:ITE,JTS:JTE,KTS:KTE) :: PLM_MF

INTEGER :: I,J,K

DO J=JTS,JTE
   DO K=KTS,KTE
      DO I=ITS,ITE
        IF (K==KTS) PZZ(I,J,K)=0.
        PEMF(I,J,K)=0.
        PENTR(I,J,K)=0.
        PDETR(I,J,K)=0.
        PTHL_UP(I,J,K)=0.
        PTHV_UP(I,J,K)=0.
        PRT_UP(I,J,K)=0.
        PRV_UP(I,J,K)=0.
        PRC_UP(I,J,K)=0.
        PU_UP(I,J,K)=0.
        PV_UP(I,J,K)=0.
        PFRAC_UP(I,J,K)=0.
        WTHV_MF(I,J,K)=0.
        PTHM(I,J,K)=TH(I,K,J)
        PTKEM(I,J,K)=TKE(I,K,J)
        PRM(I,J,K,1)=QV(I,K,J)-RC_MF(I,K,J)
        PRM(I,J,K,2)=RC_MF(I,K,J)
        PUM(I,J,K)=U(I,K,J)
        PVM(I,J,K)=V(I,K,J)
        PRHODREF(I,J,K)=RHO(I,K,J)/(1.+QV(I,K,J))
        PEXNM(I,J,K)=EXNER(I,K,J)
        PPABSM(I,J,K)=PMID(I,K,J)
        IF (K/=KTE) THEN
            PZZ(I,J,K+1)=PZZ(I,J,K)+DZ(I,K,J)
            PZZM(I,J,K)=0.5*(PZZ(I,J,K+1)+PZZ(I,J,K))
        ELSE
            PZZM(I,J,K)=PZZ(I,J,K)+0.5*DZ(I,K-1,J)
        ENDIF
        IF (K==KTS) THEN
           PDZZ(I,J,K)=2*(PZZM(I,J,K))
        ELSE
           PDZZ(I,J,K)=PZZM(I,J,K)-PZZM(I,J,K-1)
        ENDIF

        PRHODJ(I,J,K)=PRHODREF(I,J,K)*DZ(I,K,J)

      ENDDO
   ENDDO
ENDDO

PTHM(:,:,KTE)=PTHM(:,:,KTE-1)
PTKEM(:,:,KTE)=PTKEM(:,:,KTE-1)
PRM(:,:,KTE,1)=PRM(:,:,KTE-1,1)
PRM(:,:,KTE,2)=PRM(:,:,KTE-1,2)
PUM(:,:,KTE)=PUM(:,:,KTE-1)
PVM(:,:,KTE)=PVM(:,:,KTE-1)
PRHODREF(:,:,KTE)=PRHODREF(:,:,KTE-1)
PEXNM(:,:,KTE)=PEXNM(:,:,KTE-1)
PPABSM(:,:,KTE)=PPABSM(:,:,KTE-1)
PRHODJ(:,:,KTE)=PRHODJ(:,:,KTE-1)

PSFTH(:,:)=HFX(ITS:ITE,JTS:JTE)/(PRHODREF(:,:,KTS)*XCPD)
PSFRV(:,:)=QFX(ITS:ITE,JTS:JTE)/(PRHODREF(:,:,KTS))

OMIXUV=.FALSE.
KRRL=1
KRRI=0
PIMPL_MF=0.
PTSTEP=DT*STEPBL
PTSTEP_MET=PTSTEP

      CALL MFSHCONVPBL_CORE(KRR,KRRL,KRRI, &
                OMIXUV, &
                PIMPL_MF,PTSTEP,PTSTEP_MET, &
                PDZZ, PZZ, &
                PRHODJ, PRHODREF, &
                PPABSM, PEXNM, &
                PSFTH,PSFRV, &
                PTHM,PRM,PUM,PVM,PTKEM, &
                PRTHS,PRRS,PRUS,PRVS,PEMF, PENTR, PDETR, &
                PTHL_UP, PRT_UP, PRV_UP, PRC_UP, &
                PU_UP, PV_UP, PTHV_UP, PFRAC_UP, PRC_MF, WTHV_MF,PLM_MF )

DO J=JTS,JTE
   DO K=KTS,KTE
      DO I=ITS,ITE
         RQCBLTEN(I,K,J)=PRRS(I,J,K,2)
         RQVBLTEN(I,K,J)=PRRS(I,J,K,1)
         RTHBLTEN(I,K,J)=PRTHS(I,J,K)
         RUBLTEN(I,K,J)=PRUS(I,J,K)
         RVBLTEN(I,K,J)=PRVS(I,J,K)
         WTHV(I,K,J)=WTHV_MF(I,J,K)
         PLM_BL89(I,K,J)=PLM_MF(I,J,K)
      ENDDO
   ENDDO
ENDDO

      IF ( PRESENT(MASSFLUX_EDKF) ) THEN
         DO J=JTS,JTE
            DO K=KTS,KTE
               DO I=ITS,ITE
                  MASSFLUX_EDKF(I,K,J)=PEMF(I,J,K)
                  ENTR_EDKF(I,K,J)=PENTR(I,J,K)
                  DETR_EDKF(I,K,J)=PDETR(I,J,K)
                  THL_UP(I,K,J)=PTHL_UP(I,J,K)
                  THV_UP(I,K,J)=PTHV_UP(I,J,K)
                  RT_UP(I,K,J)=PRT_UP(I,J,K)
                  RV_UP(I,K,J)=PRV_UP(I,J,K)
                  RC_UP(I,K,J)=PRC_UP(I,J,K)
                  U_UP(I,K,J)=PU_UP(I,J,K)
                  V_UP(I,K,J)=PV_UP(I,J,K)
                  FRAC_UP(I,K,J)=PFRAC_UP(I,J,K)
                  RC_MF(I,K,J)=PRC_MF(I,J,K)
               ENDDO
            ENDDO
         ENDDO
      ENDIF

END SUBROUTINE MFSHCONVPBL

      SUBROUTINE MFSHCONVPBL_CORE(KRR,KRRL,KRRI, &
                OMIXUV, &
                PIMPL_MF,PTSTEP,PTSTEP_MET, &
                PDZZ, PZZ, &
                PRHODJ, PRHODREF, &
                PPABSM, PEXNM, &
                PSFTH,PSFRV, &
                PTHM,PRM,PUM,PVM,PTKEM, &
                PRTHS,PRRS,PRUS,PRVS, PEMF, PENTR, PDETR, &
                PTHL_UP, PRT_UP, PRV_UP, PRC_UP, &
                PU_UP, PV_UP, PTHV_UP, PFRAC_UP, PRC_MF, &
                PFLXZTHVMF,PLM )
IMPLICIT NONE
INTEGER, INTENT(IN) :: KRR
INTEGER, INTENT(IN) :: KRRL
INTEGER, INTENT(IN) :: KRRI
LOGICAL, INTENT(IN) :: OMIXUV
REAL, INTENT(IN) :: PIMPL_MF
REAL, INTENT(IN) :: PTSTEP
REAL, INTENT(IN) :: PTSTEP_MET
REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF
REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSM
REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNM
REAL, DIMENSION(:,:), INTENT(IN) :: PSFTH,PSFRV
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHM
REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRM
REAL, DIMENSION(:,:,:), INTENT(IN) :: PUM,PVM
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTKEM
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRUS,PRVS,PRTHS
REAL, DIMENSION(:,:,:,:), INTENT(OUT) :: PRRS
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PEMF, PENTR, PDETR
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PTHL_UP, PRT_UP, PRV_UP, PRC_UP
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PU_UP, PV_UP, PTHV_UP, PFRAC_UP
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRC_MF
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PFLXZTHVMF
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PLM
REAL, DIMENSION(SIZE(PTHM,1),SIZE(PTHM,2),SIZE(PTHM,3)) :: &
          ZEXN,ZCPH, &
          PRV,PRL,PTH, &
          ZTM, &
          ZLVOCPEXN, &
          ZCF_MF, &
          ZLSOCPEXN, &
          ZAMOIST, &
          ZATHETA, &
          ZTHLM, &
          ZRTM, &
          ZTHVM,ZTHVREF,ZUMM,ZVMM, &
          ZRI_UP,ZW_UP, &
          ZEMF_O_RHODREF, &
          ZTHLDT,ZRTDT,ZUDT,ZVDT, &
          ZFLXZTHMF,ZFLXZRMF,ZFLXZUMF,ZFLXZVMF
INTEGER,DIMENSION(SIZE(PTHM,1),SIZE(PTHM,2)) :: IKLCL,IKETL,IKCTL
INTEGER :: IKU, IKB, IKE
INTEGER :: JI,JJ,JK,JSV
INTEGER :: IRESP
IKU=SIZE(PTHM,3)
IKB=1
IKE=IKU-1
  ZUMM=PUM
  ZVMM=PVM
  CALL COMPUTE_FUNCTION_THERMO_MF( KRR,KRRL,KRRI, &
                                   PTHM,PRM,PEXNM,PPABSM, &
                                   ZTM,ZLVOCPEXN,ZLSOCPEXN, &
                                   ZAMOIST,ZATHETA )
  CALL THL_RT_FROM_TH_R_MF( KRR,KRRL,KRRI, &
                                  PTHM, PRM, ZLVOCPEXN, ZLSOCPEXN, &
                                  ZTHLM, ZRTM )
ZTHVM(:,:,:) = PTHM(:,:,:)*((1.+XRV / XRD *PRM(:,:,:,1))/(1.+ZRTM(:,:,:)))
       ZTHVREF=XG/ZTHVM
       CALL BL89(PZZ,PDZZ,ZTHVREF,ZTHLM,KRR, &
                 PRM,PTKEM,PLM)
      CALL UPDRAFT_SOPE (KRR,KRRL,KRRI,OMIXUV, &
                         PZZ,PDZZ,PSFTH,PSFRV,PPABSM,PRHODREF, &
                         PTKEM,PTHM,PRM,ZTHLM,ZRTM,ZUMM,ZVMM, &
                         PTHL_UP,PRT_UP,PRV_UP,PU_UP,PV_UP, &
                         PRC_UP,ZRI_UP,PTHV_UP,ZW_UP,PFRAC_UP,PEMF,&
                         PDETR,PENTR,IKLCL,IKETL,IKCTL )
       ZEMF_O_RHODREF=PEMF/PRHODREF
       CALL MF_TURB(OMIXUV, PIMPL_MF, PTSTEP,PTSTEP_MET, &
                PDZZ, PRHODJ, ZTHLM,ZTHVM,ZRTM,ZUMM,ZVMM, &
                ZTHLDT,ZRTDT,ZUDT,ZVDT, &
                ZEMF_O_RHODREF,PTHL_UP,PTHV_UP,PRT_UP,PU_UP,PV_UP,&
                ZFLXZTHMF,PFLXZTHVMF,ZFLXZRMF,ZFLXZUMF,ZFLXZVMF )
      CALL COMPUTE_MF_CLOUD(KRRL,ZTHLM,PRC_UP,PFRAC_UP,PDZZ,IKLCL, &
                            PRC_MF,ZCF_MF )
ZEXN(:,:,:)=(PPABSM(:,:,:)/XP00) ** (XRD/XCPD)
PRV(:,:,:)=PRM(:,:,:,1)-PRC_MF(:,:,:)
PRL(:,:,:)=PRC_MF(:,:,:)
ZCPH(:,:,:)=XCPD+ XCPV * PRV(:,:,:)+ XCL * PRL(:,:,:)
PTH(:,:,:)=(ZTHLM(:,:,:)+ZTHLDT(:,:,:))+(XLVTT/(ZCPH*ZEXN(:,:,:))*PRL(:,:,:))
PRTHS(:,:,:) = ZTHLDT(:,:,:)
PRTHS(:,:,:) = (PTH(:,:,:)-PTHM(:,:,:))/PTSTEP_MET
PRRS(:,:,:,2) = (PRC_MF-PRM(:,:,:,2))/PTSTEP_MET
PRRS(:,:,:,1) = ZRTDT(:,:,:)-PRRS(:,:,:,2)
PRTHS(:,:,:) = ZTHLDT(:,:,:)
PRRS(:,:,:,1) = ZRTDT(:,:,:)
PRRS(:,:,:,2) = 0
PRUS(:,:,:) = ZUDT(:,:,:)
PRVS(:,:,:) = ZVDT(:,:,:)
END SUBROUTINE MFSHCONVPBL_CORE
      SUBROUTINE COMPUTE_BL89_ML(PDZZ2D, &
             PTKEM2D,PG_O_THVREF2D,PVPT,KK,OUPORDN,PLWORK)
IMPLICIT NONE
REAL, DIMENSION(:,:), INTENT(IN) :: PDZZ2D
REAL, DIMENSION(:,:), INTENT(IN) :: PTKEM2D
REAL, DIMENSION(:,:), INTENT(IN) :: PG_O_THVREF2D
REAL, DIMENSION(:,:), INTENT(IN) :: PVPT
INTEGER, INTENT(IN) :: KK
LOGICAL, INTENT(IN) :: OUPORDN
REAL, DIMENSION(:), INTENT(OUT) :: PLWORK
REAL, DIMENSION(SIZE(PTKEM2D,1)) :: ZLWORK1,ZLWORK2
REAL, DIMENSION(SIZE(PTKEM2D,1)) :: ZINTE,ZPOTE
INTEGER :: IKB,IKE
REAL, DIMENSION(SIZE(PTKEM2D,1),SIZE(PTKEM2D,2)) :: ZDELTVPT,ZHLVPT
REAL, DIMENSION(SIZE(PTKEM2D,1)) :: ZTH
INTEGER :: IIJU,IKU
INTEGER :: J1D
INTEGER :: JKK
INTEGER :: JRR
INTEGER :: JIJK
REAL :: ZTEST,ZTEST0,ZTESTM
IIJU=SIZE(PTKEM2D,1)
IKB = 1
IKE = SIZE(PTKEM2D,2)-1
IKU = SIZE(PTKEM2D,2)
ZDELTVPT(:,2:IKU)=PVPT(:,2:IKU)-PVPT(:,1:IKU-1)
ZDELTVPT(:,1)=0.
WHERE (ABS(ZDELTVPT(:,:))<1.E-10)
  ZDELTVPT(:,:)=1.E-10
END WHERE
ZHLVPT(:,2:IKU)= 0.5 * ( PVPT(:,2:IKU)+PVPT(:,1:IKU-1) )
ZHLVPT(:,1) = PVPT(:,1)
IF (OUPORDN.EQV..TRUE.) THEN
 ZINTE(:)=PTKEM2D(:,KK)
 PLWORK=0.
 ZLWORK1=0.
 ZLWORK2=0.
 ZTESTM=1.
 ZTH(:)=PVPT(:,KK)
 DO JKK=KK+1,IKE
    IF(ZTESTM > 0.) THEN
      ZTESTM=0
      DO J1D=1,IIJU
        ZTEST0=0.5+SIGN(0.5,ZINTE(J1D))
        ZPOTE(J1D) = ZTEST0*(PG_O_THVREF2D(J1D,KK) * &
            (ZHLVPT(J1D,JKK) - ZTH(J1D))) * PDZZ2D(J1D,JKK)
        ZTEST =0.5+SIGN(0.5,ZINTE(J1D)-ZPOTE(J1D))
        ZTESTM=ZTESTM+ZTEST0
        ZLWORK1(J1D)=PDZZ2D(J1D,JKK)
        ZLWORK2(J1D)= ( - PG_O_THVREF2D(J1D,KK) * &
            ( PVPT(J1D,JKK-1) - ZTH(J1D) ) &
          + SQRT (ABS( &
            ( PG_O_THVREF2D(J1D,KK) * (PVPT(J1D,JKK-1) - ZTH(J1D)) )**2 &
            + 2. * ZINTE(J1D) * PG_O_THVREF2D(J1D,KK) &
                 * ZDELTVPT(J1D,JKK) / PDZZ2D(J1D,JKK) )) ) / &
        ( PG_O_THVREF2D(J1D,KK) * ZDELTVPT(J1D,JKK) / PDZZ2D(J1D,JKK) )
        PLWORK(J1D)=PLWORK(J1D)+ZTEST0*(ZTEST*ZLWORK1(J1D)+ &
                                    (1-ZTEST)*ZLWORK2(J1D))
        ZINTE(J1D) = ZINTE(J1D) - ZPOTE(J1D)
      END DO
    ENDIF
  END DO
ENDIF
IF (OUPORDN.EQV..FALSE.) THEN
 ZINTE(:)=PTKEM2D(:,KK)
 PLWORK=0.
 ZLWORK1=0.
 ZLWORK2=0.
 ZTESTM=1.
 ZTH(:)=PVPT(:,KK)
 DO JKK=KK,IKB,-1
    IF(ZTESTM > 0.) THEN
      ZTESTM=0
      DO J1D=1,IIJU
        ZTEST0=0.5+SIGN(0.5,ZINTE(J1D))
        ZPOTE(J1D) = -ZTEST0*(PG_O_THVREF2D(J1D,KK) * &
            (ZHLVPT(J1D,JKK) - ZTH(J1D))) * PDZZ2D(J1D,JKK)
        ZTEST =0.5+SIGN(0.5,ZINTE(J1D)-ZPOTE(J1D))
        ZTESTM=ZTESTM+ZTEST0
        ZLWORK1(J1D)=PDZZ2D(J1D,JKK)
        ZLWORK2(J1D)= ( + PG_O_THVREF2D(J1D,KK) * &
            ( PVPT(J1D,JKK) - ZTH(J1D) ) &
          + SQRT (ABS( &
            ( PG_O_THVREF2D(J1D,KK) * (PVPT(J1D,JKK) - ZTH(J1D)) )**2 &
            + 2. * ZINTE(J1D) * PG_O_THVREF2D(J1D,KK) &
                 * ZDELTVPT(J1D,JKK) / PDZZ2D(J1D,JKK) )) ) / &
        ( PG_O_THVREF2D(J1D,KK) * ZDELTVPT(J1D,JKK) / PDZZ2D(J1D,JKK) )
        PLWORK(J1D)=PLWORK(J1D)+ZTEST0*(ZTEST*ZLWORK1(J1D)+ &
                                    (1-ZTEST)*ZLWORK2(J1D))
        ZINTE(J1D) = ZINTE(J1D) - ZPOTE(J1D)
      END DO
    ENDIF
  END DO
ENDIF
END SUBROUTINE COMPUTE_BL89_ML
          SUBROUTINE COMPUTE_ENTR_DETR(OTEST,OTESTLCL,&
                            HFRAC_ICE,PFRAC_ICE,KK,PPABSM,PZZ,PDZZ,&
                            PTHVM,PTHLM,PRTM,PW_UP2,&
                            PTHL_UP,PRT_UP,PLUP,&
                            PENTR,PDETR,PBUO_INTEG)
IMPLICIT NONE
LOGICAL,DIMENSION(:),INTENT(INOUT) :: OTEST
LOGICAL,DIMENSION(:),INTENT(INOUT) :: OTESTLCL
CHARACTER*1 :: HFRAC_ICE
REAL, DIMENSION(:), INTENT(INOUT) :: PFRAC_ICE
INTEGER, INTENT(IN) :: KK
REAL, DIMENSION(:,:), INTENT(IN) :: PPABSM
REAL, DIMENSION(:,:), INTENT(IN) :: PZZ
REAL, DIMENSION(:,:), INTENT(IN) :: PDZZ
REAL, DIMENSION(:,:), INTENT(IN) :: PTHVM
REAL, DIMENSION(:), INTENT(IN) :: PTHLM
REAL, DIMENSION(:), INTENT(IN) :: PRTM
REAL, DIMENSION(:,:), INTENT(INOUT) :: PW_UP2
REAL, DIMENSION(:), INTENT(IN) :: PTHL_UP,PRT_UP
REAL, DIMENSION(:), INTENT(IN) :: PLUP
REAL, DIMENSION(:), INTENT(INOUT) :: PENTR
REAL, DIMENSION(:), INTENT(INOUT) :: PDETR
REAL, DIMENSION(:), INTENT(INOUT) :: PBUO_INTEG
REAL, DIMENSION(SIZE(PTHLM)) :: ZKIC
REAL, DIMENSION(SIZE(PTHLM)) :: ZEPSI,ZDELTA
REAL, DIMENSION(SIZE(PTHLM)) :: ZEPSI_CLOUD
REAL, DIMENSION(SIZE(PTHLM)) :: ZCOEFFMF_CLOUD
REAL, DIMENSION(SIZE(PTHLM)) :: ZMIXTHL,ZMIXRT
REAL, DIMENSION(SIZE(PTHLM)) :: ZTHMIX,ZTHVMIX
REAL, DIMENSION(SIZE(PTHLM)) :: ZRVMIX,ZRCMIX,ZRIMIX
REAL, DIMENSION(SIZE(PTHLM)) :: ZTHMIX_F2
REAL, DIMENSION(SIZE(PTHLM)) :: ZRVMIX_F2,ZRCMIX_F2,ZRIMIX_F2
REAL, DIMENSION(SIZE(PTHLM)) :: ZTHV_UP
REAL, DIMENSION(SIZE(PTHLM)) :: ZTHVMIX_1,ZTHVMIX_2
REAL, DIMENSION(SIZE(PTHLM)) :: ZBUO_INTEG,&
                                  ZDZ_HALF,&
                                  ZDZ_STOP,&
                                  ZTHV_MINUS_HALF,&
                                  ZTHV_PLUS_HALF,&
                                  ZCOEFF_MINUS_HALF,&
                                  ZCOEFF_PLUS_HALF,&
                                  ZCOTHVU_MINUS_HALF,&
                                  ZCOTHVU_PLUS_HALF,&
                                  ZW2_HALF
REAL, DIMENSION(SIZE(PTHLM)) :: ZCOPRE_MINUS_HALF,&
                                  ZCOPRE_PLUS_HALF,&
                                  ZPRE_MINUS_HALF,&
                                  ZPRE_PLUS_HALF,&
                                  ZTHV_UP_F1,&
                                  ZTHV_UP_F2
REAL, DIMENSION(SIZE(PTHLM)) :: ZCOEFF_QSAT,&
                                  ZRC_ORD,&
                                  ZPART_DRY
REAL, DIMENSION(SIZE(PTHLM)) :: ZQVSAT
REAL, DIMENSION(SIZE(PTHLM)) :: PT
REAL, DIMENSION(SIZE(PTHVM,1),SIZE(PTHVM,2)) ::ZG_O_THVREF
LOGICAL, DIMENSION(SIZE(OTEST,1)) :: GTEST_LOCAL_LCL,&
                                     GTEST_LOCAL_LCL2
REAL :: ZRDORV
REAL :: ZRVORD
INTEGER :: ILON, ITEST, IKB
  IKB=1
  ZRDORV = XRD / XRV
  ZRVORD = XRV / XRD
  ZG_O_THVREF=XG/PTHVM
  ZCOEFF_QSAT=0.
  ZRC_ORD=0.
  ZPART_DRY=1.
  GTEST_LOCAL_LCL=.FALSE.
  ZDZ_HALF(:) = (PZZ(:,KK+1)-PZZ(:,KK))/2.
  ZDZ_STOP(:) = ZDZ_HALF(:)
  ZKIC(:)=0.1
  ZMIXTHL(:) = ZKIC(:) * PTHLM(:)+(1. - ZKIC(:))*PTHL_UP(:)
  ZMIXRT(:) = ZKIC(:) * PRTM(:)+(1. - ZKIC(:))*PRT_UP(:)
IF (KK==IKB) THEN
  ZCOPRE_MINUS_HALF(:) = 0.
ELSE
  ZCOPRE_MINUS_HALF(:) = ((PPABSM(:,KK)-PPABSM(:,KK-1))/PDZZ(:,KK))
ENDIF
  ZCOPRE_PLUS_HALF(:) = ((PPABSM(:,KK+1)-PPABSM(:,KK))/PDZZ(:,KK+1))
IF (KK==IKB) THEN
  ZPRE_MINUS_HALF(:)= PPABSM(:,KK)
ELSE
  ZPRE_MINUS_HALF(:)= ZCOPRE_MINUS_HALF*0.5*(PZZ(:,KK)-PZZ(:,KK-1))+PPABSM(:,KK-1)
ENDIF
  ZPRE_PLUS_HALF(:) = ZCOPRE_PLUS_HALF*0.5*(PZZ(:,KK+1)-PZZ(:,KK))+PPABSM(:,KK)
  CALL TH_R_FROM_THL_RT_1D(HFRAC_ICE,PFRAC_ICE,&
               PPABSM(:,KK),ZMIXTHL,ZMIXRT,&
               ZTHMIX,ZRVMIX,ZRCMIX,ZRIMIX)
  ZTHVMIX_1(:) = ZTHMIX(:)*(1.+ZRVORD*ZRVMIX(:))/(1.+ZMIXRT(:))
  CALL TH_R_FROM_THL_RT_1D(HFRAC_ICE,PFRAC_ICE,&
               ZPRE_PLUS_HALF,ZMIXTHL,ZMIXRT,&
               ZTHMIX,ZRVMIX,ZRCMIX,ZRIMIX)
  ZTHVMIX_2(:) = ZTHMIX(:)*(1.+ZRVORD*ZRVMIX(:))/(1.+ZMIXRT(:))
  CALL TH_R_FROM_THL_RT_1D(HFRAC_ICE,PFRAC_ICE,&
               ZPRE_MINUS_HALF,PTHL_UP,PRT_UP,&
               ZTHMIX,ZRVMIX,ZRCMIX,ZRIMIX)
  ZTHV_UP_F1(:) = ZTHMIX(:)*(1.+ZRVORD*ZRVMIX(:))/(1.+PRT_UP(:))
  CALL TH_R_FROM_THL_RT_1D(HFRAC_ICE,PFRAC_ICE,&
               PPABSM(:,KK),PTHL_UP,PRT_UP,&
               ZTHMIX,ZRVMIX,ZRCMIX,ZRIMIX)
  ZTHV_UP(:) = ZTHMIX(:)*(1.+ZRVORD*ZRVMIX(:))/(1.+PRT_UP(:))
  CALL TH_R_FROM_THL_RT_1D(HFRAC_ICE,PFRAC_ICE,&
               ZPRE_PLUS_HALF,PTHL_UP,PRT_UP,&
               ZTHMIX_F2,ZRVMIX_F2,ZRCMIX_F2,ZRIMIX_F2)
  ZTHV_UP_F2(:) = ZTHMIX_F2(:)*(1.+ZRVORD*ZRVMIX_F2(:))/(1.+PRT_UP(:))
  WHERE ((ZRCMIX(:)>0.).AND.(.NOT.OTESTLCL))
     ZCOEFF_QSAT(:) = (ZRCMIX_F2(:) - ZRCMIX(:))/ ZDZ_HALF(:)
     ZRC_ORD(:) = ZRCMIX(:) - ZCOEFF_QSAT(:) * ZDZ_HALF(:)
     ZDZ_STOP = (- ZRC_ORD(:)/ZCOEFF_QSAT(:))
     ZPART_DRY(:) = ZDZ_STOP / (PZZ(:,KK+1)-PZZ(:,KK))
     GTEST_LOCAL_LCL(:)=.TRUE.
  ENDWHERE
IF (KK==IKB) THEN
  ZCOEFF_MINUS_HALF = 0.
ELSE
  ZCOEFF_MINUS_HALF = ((PTHVM(:,KK)-PTHVM(:,KK-1))/PDZZ(:,KK))
ENDIF
  ZCOEFF_PLUS_HALF = ((PTHVM(:,KK+1)-PTHVM(:,KK))/PDZZ(:,KK+1))
  ZCOTHVU_MINUS_HALF = (ZTHV_UP(:)-ZTHV_UP_F1(:))/ZDZ_HALF(:)
  ZCOTHVU_PLUS_HALF = (ZTHV_UP_F2(:)-ZTHV_UP(:))/ZDZ_HALF(:)
IF (KK==IKB) THEN
  ZTHV_MINUS_HALF = PTHVM(:,KK)
ELSE
  ZTHV_MINUS_HALF = ZCOEFF_MINUS_HALF*0.5*(PZZ(:,KK)-PZZ(:,KK-1))+PTHVM(:,KK-1)
ENDIF
  ZTHV_PLUS_HALF = ZCOEFF_PLUS_HALF*0.5*(PZZ(:,KK+1)-PZZ(:,KK))+ ZTHV_MINUS_HALF
  PBUO_INTEG = ZG_O_THVREF(:,KK)*ZDZ_HALF(:)*&
              (0.5*( ZCOTHVU_MINUS_HALF - ZCOEFF_MINUS_HALF)*ZDZ_HALF(:) &
                - ZTHV_MINUS_HALF + ZTHV_UP_F1(:) )
  WHERE ((OTEST).AND.(.NOT.OTESTLCL))
     PENTR=0.
     PDETR=0.
     ZBUO_INTEG = ZG_O_THVREF(:,KK)*ZDZ_STOP(:)*&
                (0.5 * ( - ZCOEFF_MINUS_HALF)* ZDZ_STOP(:) &
                  - ZTHV_MINUS_HALF + ZTHV_UP_F1(:) )
     WHERE (ZBUO_INTEG(:)>=0.)
         PENTR = 0.5/(XABUO-XBENTR*XENTR_DRY)*&
                 LOG(1.+ (2.*(XABUO-XBENTR*XENTR_DRY)/PW_UP2(:,KK))* &
                 ZBUO_INTEG)
         PDETR = 0.
         ZW2_HALF = PW_UP2(:,KK) + 2*(XABUO-XBENTR*XENTR_DRY)*(ZBUO_INTEG)
     ELSEWHERE
         PENTR = 0.
         PDETR = 0.5/(XABUO)*&
                 LOG(1.+ (2.*(XABUO)/PW_UP2(:,KK))* &
                 MAX(0.,-ZBUO_INTEG))
         ZW2_HALF = PW_UP2(:,KK) + 2*(XABUO)*(ZBUO_INTEG)
     ENDWHERE
 ENDWHERE
 ZDZ_STOP(:) = ZDZ_HALF(:)
 PBUO_INTEG = PBUO_INTEG + ZG_O_THVREF(:,KK)*ZDZ_HALF(:)*&
                (0.5*(ZCOTHVU_PLUS_HALF - ZCOEFF_PLUS_HALF)* ZDZ_HALF(:) - &
                PTHVM(:,KK) + ZTHV_UP(:) )
 WHERE ((((ZRCMIX_F2(:)>0.).AND.(ZRCMIX(:)<=0.)).AND.(.NOT.OTESTLCL)).AND.(.NOT.GTEST_LOCAL_LCL(:)))
     PT(:)=ZTHMIX_F2(:)*((PPABSM(:,KK+1)/XP00)**(XRD/XCPD))
     ZQVSAT(:)=EXP( XALPW - XBETAW/PT(:) - XGAMW*LOG(PT(:)) )
     ZQVSAT(:)=XRD/XRV*ZQVSAT(:)/PPABSM(:,KK+1) &
                   / (1.+(XRD/XRV-1.)*ZQVSAT(:)/PPABSM(:,KK+1))
     ZCOEFF_QSAT(:) = (PRT_UP(:) - ZQVSAT(:) - &
                ZRCMIX(:))/ (0.5* (PZZ(:,KK+2)-PZZ(:,KK+1)))
     ZRC_ORD(:) = ZRCMIX_F2(:) - ZCOEFF_QSAT(:) * ZDZ_HALF(:)
     ZDZ_STOP = (- ZRC_ORD(:)/ZCOEFF_QSAT(:))
     ZPART_DRY(:) = 0.5+ZDZ_STOP / (PZZ(:,KK+1)-PZZ(:,KK))
     GTEST_LOCAL_LCL2(:)=.TRUE.
 ENDWHERE
 WHERE (((OTEST).AND.(.NOT.OTESTLCL)).AND.(.NOT.GTEST_LOCAL_LCL(:)))
     ZBUO_INTEG = ZG_O_THVREF(:,KK)*ZDZ_STOP(:)*&
                (0.5*( - ZCOEFF_PLUS_HALF)* ZDZ_STOP(:)&
                - PTHVM(:,KK) + ZTHV_UP(:) )
     WHERE (ZW2_HALF>0.)
        WHERE (ZBUO_INTEG(:)>=0.)
           PENTR = PENTR + 0.5/(XABUO-XBENTR*XENTR_DRY)* &
                LOG(1.+ (2.*(XABUO-XBENTR*XENTR_DRY)/ZW2_HALF(:)) * ZBUO_INTEG)
           PDETR = PDETR
        ELSEWHERE
          PENTR = PENTR
          PDETR = PDETR + 0.5/(XABUO)* &
                LOG(1.+ (2.*(XABUO)/ZW2_HALF(:)) * &
                MAX(-ZBUO_INTEG,0.))
        ENDWHERE
     ELSEWHERE
           OTEST=.FALSE.
           PENTR = PENTR
           PDETR = PDETR
     ENDWHERE
 ENDWHERE
 PENTR = XENTR_DRY*PENTR/(PZZ(:,KK+1)-PZZ(:,KK))
 PDETR = XDETR_DRY*PDETR/(PZZ(:,KK+1)-PZZ(:,KK))
 PDETR = MAX(ZPART_DRY(:)*XDETR_LUP/(PLUP-0.5*(PZZ(:,KK)+PZZ(:,KK+1))),PDETR)
 WHERE ((OTEST).AND.(OTESTLCL))
     ZKIC(:) = MAX(0.,ZTHV_UP(:)-PTHVM(:,KK))*ZKIC(:) / &
                 (ZTHV_UP(:)-ZTHVMIX_1(:)+1.E-10)
     ZKIC(:) = MAX(0., MIN(1., ZKIC(:)))
     ZEPSI(:) = ZKIC(:) **2.
     ZDELTA(:) = (1.-ZKIC(:))**2.
     ZEPSI_CLOUD=MIN(ZDELTA,ZEPSI)
     ZCOEFFMF_CLOUD(:)=XENTR_MF * XG / XCRAD_MF
     PENTR(:) = ZCOEFFMF_CLOUD(:)*ZEPSI_CLOUD(:)
     PDETR(:) = ZCOEFFMF_CLOUD(:)*ZDELTA(:)
 ENDWHERE
 WHERE (((OTEST).AND.(.NOT.(OTESTLCL))).AND.((GTEST_LOCAL_LCL(:).OR.GTEST_LOCAL_LCL2(:))))
     ZKIC(:) = MAX(0.,ZTHV_UP_F2(:)-ZTHV_PLUS_HALF)*ZKIC(:) / &
                       (ZTHV_UP_F2(:)-ZTHVMIX_2(:)+1.E-10)
     ZKIC(:) = MAX(0., MIN(1., ZKIC(:)))
     ZEPSI(:) = ZKIC(:) **2.
     ZDELTA(:) = (1.-ZKIC(:))**2.
     ZEPSI_CLOUD=MIN(ZDELTA,ZEPSI)
     ZCOEFFMF_CLOUD(:)=XENTR_MF * XG / XCRAD_MF
     PENTR(:) = PENTR+(1.-ZPART_DRY(:))*ZCOEFFMF_CLOUD(:)*ZEPSI_CLOUD(:)
     PDETR(:) = PDETR+(1.-ZPART_DRY(:))*ZCOEFFMF_CLOUD(:)*ZDELTA(:)
 ENDWHERE
END SUBROUTINE COMPUTE_ENTR_DETR
      SUBROUTINE COMPUTE_FUNCTION_THERMO_MF( KRR,KRRL,KRRI, &
                                       PTH, PR, PEXN, PPABS, &
                                       PT,PLVOCPEXN,PLSOCPEXN, &
                                       PAMOIST,PATHETA )
IMPLICIT NONE
INTEGER, INTENT(IN) :: KRR
INTEGER, INTENT(IN) :: KRRL
INTEGER, INTENT(IN) :: KRRI
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTH
REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PR
REAL, DIMENSION(:,:,:) , INTENT(IN) :: PPABS,PEXN
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PT
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PLVOCPEXN,PLSOCPEXN
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PAMOIST,PATHETA
REAL :: ZEPS
REAL, DIMENSION(SIZE(PTH,1),SIZE(PTH,2),SIZE(PTH,3)) :: &
          ZCP, &
          ZE, &
          ZDEDT, &
          ZFRAC_ICE, &
          ZAMOIST_W, &
          ZATHETA_W, &
          ZAMOIST_I, &
          ZATHETA_I
INTEGER :: JRR
  ZEPS = XMV / XMD
  PLVOCPEXN(:,:,:) = 0.
  PLSOCPEXN(:,:,:) = 0.
  PAMOIST(:,:,:) = 0.
  PATHETA(:,:,:) = 0.
  ZFRAC_ICE(:,:,:) = 0.0
  ZAMOIST_W(:,:,:) = 0.0
  ZATHETA_W(:,:,:) = 0.0
  ZAMOIST_I(:,:,:) = 0.0
  ZATHETA_I(:,:,:) = 0.0
ZCP=XCPD
IF (KRR > 0) ZCP(:,:,:) = ZCP(:,:,:) + XCPV * PR(:,:,:,1)
DO JRR = 2,1+KRRL
   ZCP(:,:,:) = ZCP(:,:,:) + XCL * PR(:,:,:,JRR)
END DO
DO JRR = 2+KRRL,1+KRRL+KRRI
  ZCP(:,:,:) = ZCP(:,:,:) + XCI * PR(:,:,:,JRR)
END DO
PT(:,:,:) = PTH(:,:,:) * PEXN(:,:,:)
IF ( KRRL >= 1 ) THEN
  PLVOCPEXN(:,:,:) = (XLVTT + (XCPV-XCL) * (PT(:,:,:)-XTT) ) / ZCP(:,:,:)
  ZE(:,:,:) = EXP( XALPW - XBETAW/PT(:,:,:) - XGAMW*ALOG( PT(:,:,:) ) )
  ZE(:,:,:) = ZE(:,:,:) * ZEPS / ( PPABS(:,:,:) - ZE(:,:,:) )
  ZDEDT(:,:,:) = ( XBETAW / PT(:,:,:) - XGAMW ) / PT(:,:,:) &
                 * ZE(:,:,:) * ( 1. + ZE(:,:,:) / ZEPS )
  ZAMOIST_W(:,:,:)= 0.5 / ( 1.0 + ZDEDT(:,:,:) * PLVOCPEXN(:,:,:) )
  ZATHETA_W(:,:,:)= ZAMOIST_W(:,:,:) * PEXN(:,:,:) * &
        ( ( ZE(:,:,:) - PR(:,:,:,1) ) * PLVOCPEXN(:,:,:) / &
          ( 1. + ZDEDT(:,:,:) * PLVOCPEXN(:,:,:) ) * &
          ( &
           ZE(:,:,:) * (1. + ZE(:,:,:)/ZEPS) &
                        * ( -2.*XBETAW/PT(:,:,:) + XGAMW ) / PT(:,:,:)**2 &
          +ZDEDT(:,:,:) * (1. + 2. * ZE(:,:,:)/ZEPS) &
                        * ( XBETAW/PT(:,:,:) - XGAMW ) / PT(:,:,:) &
          ) &
         - ZDEDT(:,:,:) &
        )
  IF ( KRRI >= 1 ) THEN
    WHERE(PR(:,:,:,2)+PR(:,:,:,4)>0.0)
      ZFRAC_ICE(:,:,:) = PR(:,:,:,4) / ( PR(:,:,:,2)+PR(:,:,:,4) )
    END WHERE
    PLSOCPEXN(:,:,:) = (XLSTT + (XCPV-XCI) * (PT(:,:,:)-XTT) ) / ZCP(:,:,:)
    ZE(:,:,:) = EXP( XALPI - XBETAI/PT(:,:,:) - XGAMI*ALOG( PT(:,:,:) ) )
    ZE(:,:,:) = ZE(:,:,:) * ZEPS / ( PPABS(:,:,:) - ZE(:,:,:) )
    ZDEDT(:,:,:) = ( XBETAI / PT(:,:,:) - XGAMI ) / PT(:,:,:) &
                   * ZE(:,:,:) * ( 1. + ZE(:,:,:) / ZEPS )
    ZAMOIST_I(:,:,:)= 0.5 / ( 1.0 + ZDEDT(:,:,:) * PLSOCPEXN(:,:,:) )
    ZATHETA_I(:,:,:)= ZAMOIST_I(:,:,:) * PEXN(:,:,:) * &
        ( ( ZE(:,:,:) - PR(:,:,:,1) ) * PLSOCPEXN(:,:,:) / &
          ( 1. + ZDEDT(:,:,:) * PLSOCPEXN(:,:,:) ) * &
          ( &
           ZE(:,:,:) * (1. + ZE(:,:,:)/ZEPS) &
                        * ( -2.*XBETAI/PT(:,:,:) + XGAMI ) / PT(:,:,:)**2 &
          +ZDEDT(:,:,:) * (1. + 2. * ZE(:,:,:)/ZEPS) &
                        * ( XBETAI/PT(:,:,:) - XGAMI ) / PT(:,:,:) &
          ) &
         - ZDEDT(:,:,:) &
        )
  ENDIF
  PAMOIST(:,:,:) = (1.0-ZFRAC_ICE(:,:,:))*ZAMOIST_W(:,:,:) &
                         +ZFRAC_ICE(:,:,:) *ZAMOIST_I(:,:,:)
  PATHETA(:,:,:) = (1.0-ZFRAC_ICE(:,:,:))*ZATHETA_W(:,:,:) &
                         +ZFRAC_ICE(:,:,:) *ZATHETA_I(:,:,:)
  PLVOCPEXN(:,:,:) = PLVOCPEXN(:,:,:) / PEXN(:,:,:)
  PLSOCPEXN(:,:,:) = PLSOCPEXN(:,:,:) / PEXN(:,:,:)
ENDIF
END SUBROUTINE COMPUTE_FUNCTION_THERMO_MF
      SUBROUTINE COMPUTE_UPDRAFT(OMIXUV,PZZ,PDZZ,KK, &
                                 PSFTH,PSFRV, &
                                 PPABSM,PRHODREF,PUM,PVM, PTKEM, &
                                 PTHM,PRVM,PRCM,PRIM,PTHLM,PRTM, &
                                 PTHL_UP,PRT_UP, &
                                 PRV_UP,PRC_UP,PRI_UP,PTHV_UP, &
                                 PW_UP,PU_UP, PV_UP, &
                                 PFRAC_UP,PEMF,PDETR,PENTR, &
                                 KKLCL,KKETL,KKCTL)
IMPLICIT NONE
LOGICAL, INTENT(IN) :: OMIXUV
REAL, DIMENSION(:,:), INTENT(IN) :: PZZ
REAL, DIMENSION(:,:), INTENT(IN) :: PDZZ
INTEGER, INTENT(IN) :: KK
REAL, DIMENSION(:), INTENT(IN) :: PSFTH,PSFRV
REAL, DIMENSION(:,:), INTENT(IN) :: PPABSM
REAL, DIMENSION(:,:), INTENT(IN) :: PRHODREF
REAL, DIMENSION(:,:), INTENT(IN) :: PUM
REAL, DIMENSION(:,:), INTENT(IN) :: PVM
REAL, DIMENSION(:,:), INTENT(IN) :: PTKEM
REAL, DIMENSION(:,:), INTENT(IN) :: PTHM
REAL, DIMENSION(:,:), INTENT(IN) :: PRVM,PRCM,PRIM
REAL, DIMENSION(:,:), INTENT(IN) :: PTHLM,PRTM
REAL, DIMENSION(:,:), INTENT(OUT) :: PTHL_UP,PRT_UP
REAL, DIMENSION(:,:), INTENT(OUT) :: PU_UP, PV_UP
REAL, DIMENSION(:,:), INTENT(OUT) :: PRV_UP,PRC_UP, &
                                         PRI_UP,PTHV_UP,&
                                         PW_UP,PFRAC_UP
REAL, DIMENSION(:,:), INTENT(OUT) :: PEMF,PDETR,PENTR
INTEGER, DIMENSION(:), INTENT(OUT) :: KKLCL,KKETL,KKCTL
REAL, DIMENSION(SIZE(PTHM,1),SIZE(PTHM,2)) :: &
                        ZTHM_F,ZRVM_F,ZRCM_F,ZRIM_F
REAL, DIMENSION(SIZE(PTHM,1),SIZE(PTHM,2)) :: &
                        ZRTM_F, ZTHLM_F, ZTKEM_F,&
                        ZUM_F,ZVM_F,ZRHO_F, &
                        ZPRES_F,ZTHVM_F,ZTHVM, &
                        ZG_O_THVREF, &
                        ZW_UP2
REAL, DIMENSION(SIZE(PTHM,1),SIZE(PTHM,2)) :: &
                        ZTH_UP, &
                        ZFRAC_ICE
REAL, DIMENSION(SIZE(PTHM,1),SIZE(PTHM,2)) :: ZCOEF
REAL, DIMENSION(SIZE(PSFTH,1) ) :: ZWTHVSURF
CHARACTER(LEN=1) :: YFRAC_ICE
REAL :: ZRDORV
REAL :: ZRVORD
REAL, DIMENSION(SIZE(PTHM,1)) :: ZMIX1,ZMIX2,ZMIX3
REAL, DIMENSION(SIZE(PTHM,1)) :: ZBUO_INTEG
REAL, DIMENSION(SIZE(PTHM,1)) :: ZLUP
REAL, DIMENSION(SIZE(PTHM,1)) :: ZDEPTH
INTEGER :: IKB,IKE
INTEGER :: IKU
INTEGER :: JK,JI,JSV
LOGICAL, DIMENSION(SIZE(PTHM,1)) :: GTEST,GTESTLCL,GTESTETL
LOGICAL :: GLMIX
LOGICAL, DIMENSION(SIZE(PTHM,1)) :: GWORK1
LOGICAL, DIMENSION(SIZE(PTHM,1),SIZE(PTHM,2)) :: GWORK2
INTEGER :: ITEST
REAL :: ZTMAX,ZRMAX
ZTMAX=2.0
ZRMAX=1.E-3
IKU=SIZE(PTHM,2)
IKB=1
IKE=IKU-1
KKLCL(:)=IKE
KKETL(:)=IKE
KKCTL(:)=IKE
PRV_UP(:,:)=0.
PRC_UP(:,:)=0.
PW_UP(:,:)=0.
PEMF(:,:)=0.
PDETR(:,:)=0.
PENTR(:,:)=0.
ZTH_UP(:,:)=0.
PFRAC_UP(:,:)=0.
PTHV_UP(:,:)=0.
PRI_UP(:,:)=0.
ZFRAC_ICE(:,:)=0.
YFRAC_ICE='T'
ZBUO_INTEG=0.
ZRDORV = XRD / XRV
ZRVORD = (XRV / XRD)
ZTHM_F (:,IKB+1:IKU) = 0.5*(PTHM(:,IKB:IKU-1)+PTHM(:,IKB+1:IKU))
ZTHLM_F(:,IKB+1:IKU) = 0.5*(PTHLM(:,IKB:IKU-1)+PTHLM(:,IKB+1:IKU))
ZRTM_F (:,IKB+1:IKU) = 0.5*(PRTM(:,IKB:IKU-1)+PRTM(:,IKB+1:IKU))
ZTKEM_F(:,IKB+1:IKU) = 0.5*(PTKEM(:,IKB:IKU-1)+PTKEM(:,IKB+1:IKU))
ZPRES_F(:,IKB+1:IKU) = 0.5*(PPABSM(:,IKB:IKU-1)+PPABSM(:,IKB+1:IKU))
ZRHO_F (:,IKB+1:IKU) = 0.5*(PRHODREF(:,IKB:IKU-1)+PRHODREF(:,IKB+1:IKU))
ZRVM_F (:,IKB+1:IKU) = 0.5*(PRVM(:,IKB:IKU-1)+PRVM(:,IKB+1:IKU))
ZUM_F (:,IKB+1:IKU) = 0.5*(PUM(:,IKB:IKU-1)+PUM(:,IKB+1:IKU))
ZVM_F (:,IKB+1:IKU) = 0.5*(PVM(:,IKB:IKU-1)+PVM(:,IKB+1:IKU))
ZTHM_F (:,IKB) = PTHM(:,IKB)
ZTHLM_F(:,IKB) = PTHLM(:,IKB)
ZRTM_F (:,IKB) = PRTM (:,IKB)
ZTKEM_F(:,IKB) = PTKEM(:,IKB)
ZPRES_F(:,IKB) = PPABSM(:,IKB)
ZRHO_F(:,IKB) = PRHODREF(:,IKB)
ZRVM_F(:,IKB) = PRVM(:,IKB)
ZUM_F(:,IKB) = PUM(:,IKB)
ZVM_F(:,IKB) = PVM(:,IKB)
ZTHVM_F(:,:)=ZTHM_F(:,:)*((1.+ZRVORD*ZRVM_F(:,:))/(1.+ZRTM_F(:,:)))
ZTHVM(:,:)=PTHM(:,:)*((1.+ZRVORD*PRVM(:,:))/(1.+PRTM(:,:)))
PTHL_UP(:,:)=ZTHLM_F(:,:)
PRT_UP(:,:)=ZRTM_F(:,:)
ZW_UP2(:,:)=0.
PTHV_UP(:,:)=ZTHVM_F(:,:)
PU_UP(:,:)=ZUM_F(:,:)
PV_UP(:,:)=ZVM_F(:,:)
PTHL_UP(:,KK)= ZTHLM_F(:,KK)+MAX(0.,MIN(ZTMAX,(PSFTH(:)/SQRT(ZTKEM_F(:,KK)))*XALP_PERT))
PRT_UP(:,KK) = ZRTM_F(:,KK)+MAX(0.,MIN(ZRMAX,(PSFRV(:)/SQRT(ZTKEM_F(:,KK)))*XALP_PERT))
ZW_UP2(:,KK) = MAX(0.0001,(2./3.)*ZTKEM_F(:,KK))
CALL TH_R_FROM_THL_RT_2D(YFRAC_ICE,ZFRAC_ICE(:,KK:KK),ZPRES_F(:,KK:KK), &
             PTHL_UP(:,KK:KK),PRT_UP(:,KK:KK),ZTH_UP(:,KK:KK), &
             PRV_UP(:,KK:KK),PRC_UP(:,KK:KK),PRI_UP(:,KK:KK))
PTHV_UP(:,KK) = ZTH_UP(:,KK)*((1+ZRVORD*PRV_UP(:,KK))/(1+PRT_UP(:,KK)))
ZG_O_THVREF=XG/ZTHVM_F
GLMIX=.TRUE.
ZTKEM_F(:,KK)=0.
CALL COMPUTE_BL89_ML(PDZZ,ZTKEM_F,ZG_O_THVREF,ZTHVM_F,KK,GLMIX,ZLUP)
ZLUP(:)=MAX(ZLUP(:),1.E-10)
ZWTHVSURF(:) = (ZTHVM_F(:,IKB)/ZTHM_F(:,IKB))*PSFTH(:)+ &
                (0.61*ZTHM_F(:,IKB))*PSFRV(:)
WHERE (ZWTHVSURF(:)>0.)
  PEMF(:,KK) = XCMF * ZRHO_F(:,KK) * ((ZG_O_THVREF(:,KK))*ZWTHVSURF*ZLUP)**(1./3.)
  PFRAC_UP(:,KK)=MIN(PEMF(:,KK)/(SQRT(ZW_UP2(:,KK))*ZRHO_F(:,KK)),XFRAC_UP_MAX)
  ZW_UP2(:,KK)=(PEMF(:,KK)/(PFRAC_UP(:,KK)*ZRHO_F(:,KK)))**2
  GTEST(:)=.TRUE.
ELSEWHERE
  PEMF(:,KK) =0.
  GTEST(:)=.FALSE.
ENDWHERE
GTESTLCL(:)=.FALSE.
GTESTETL(:)=.FALSE.
DO JK=KK,IKE-1
ITEST=COUNT(GTEST)
IF (ITEST==0) CYCLE
  WHERE(GTEST)
  WHERE ((PRC_UP(:,JK)>0.).AND.(.NOT.(GTESTLCL)))
      KKLCL(:) = JK
      GTESTLCL(:)=.TRUE.
  ENDWHERE
  ENDWHERE
 CALL COMPUTE_ENTR_DETR(GTEST,GTESTLCL,YFRAC_ICE,ZFRAC_ICE(:,JK),JK,&
                       PPABSM(:,:),PZZ(:,:),PDZZ(:,:),ZTHVM(:,:),&
                       PTHLM(:,JK),PRTM(:,JK),ZW_UP2(:,:), &
                       PTHL_UP(:,JK),PRT_UP(:,JK),ZLUP(:), &
                       PENTR(:,JK),PDETR(:,JK),ZBUO_INTEG)
  IF (JK==KK) THEN
       PDETR(:,JK)=0.
  ENDIF
  WHERE(GTEST)
    ZMIX1(:)=0.5*(PZZ(:,JK+1)-PZZ(:,JK))*(PENTR(:,JK)-PDETR(:,JK))
    PEMF(:,JK+1)=PEMF(:,JK)*EXP(2*ZMIX1(:))
  ENDWHERE
  WHERE (GTEST.AND.(PEMF(:,JK+1)<=0.))
    PEMF(:,JK+1)=0.
    GTEST(:)=.FALSE.
    KKCTL(:) = JK+1
  ENDWHERE
  WHERE(GTEST)
    ZMIX2(:) = (PZZ(:,JK+1)-PZZ(:,JK))*PENTR(:,JK)
    ZMIX3(:) = (PZZ(:,JK+1)-PZZ(:,JK))*PDETR(:,JK)
    PTHL_UP(:,JK+1) = (PTHL_UP(:,JK)*(1.-0.5*ZMIX2(:)) + PTHLM(:,JK)*ZMIX2(:)) &
                          /(1.+0.5*ZMIX2(:))
    PRT_UP(:,JK+1) = (PRT_UP (:,JK)*(1.-0.5*ZMIX2(:)) + PRTM(:,JK)*ZMIX2(:)) &
                          /(1.+0.5*ZMIX2(:))
  ENDWHERE
  IF(OMIXUV) THEN
    WHERE(GTEST)
      PU_UP(:,JK+1) = (PU_UP (:,JK)*(1-0.5*ZMIX2(:)) + PUM(:,JK)*ZMIX2(:)+ &
                        0.5*XPRES_UV*(PZZ(:,JK+1)-PZZ(:,JK))*&
                        ((PUM(:,JK+1)-PUM(:,JK))/PDZZ(:,JK+1)+&
                         (PUM(:,JK)-PUM(:,JK-1))/PDZZ(:,JK)) ) &
                        /(1+0.5*ZMIX2(:))
      PV_UP(:,JK+1) = (PV_UP (:,JK)*(1-0.5*ZMIX2(:)) + PVM(:,JK)*ZMIX2(:)+ &
                        0.5*XPRES_UV*(PZZ(:,JK+1)-PZZ(:,JK))*&
                        ((PVM(:,JK+1)-PVM(:,JK))/PDZZ(:,JK+1)+&
                         (PVM(:,JK)-PVM(:,JK-1))/PDZZ(:,JK)) ) &
                        /(1+0.5*ZMIX2(:))
    ENDWHERE
  ENDIF
  CALL TH_R_FROM_THL_RT_2D(YFRAC_ICE,ZFRAC_ICE(:,JK+1:JK+1),ZPRES_F(:,JK+1:JK+1), &
          PTHL_UP(:,JK+1:JK+1),PRT_UP(:,JK+1:JK+1),ZTH_UP(:,JK+1:JK+1), &
          PRV_UP(:,JK+1:JK+1),PRC_UP(:,JK+1:JK+1),PRI_UP(:,JK+1:JK+1))
  WHERE(GTEST)
      PTHV_UP(:,JK+1) = ZTH_UP(:,JK+1)*((1+ZRVORD*PRV_UP(:,JK+1))/(1+PRT_UP(:,JK+1)))
   WHERE (.NOT.(GTESTLCL))
      WHERE (ZBUO_INTEG(:)>0.)
        ZW_UP2(:,JK+1) = ZW_UP2(:,JK) + 2.*(XABUO-XBENTR*XENTR_DRY)* ZBUO_INTEG(:)
      ENDWHERE
      WHERE (ZBUO_INTEG(:)<=0.)
        ZW_UP2(:,JK+1) = ZW_UP2(:,JK) + 2.*XABUO* ZBUO_INTEG(:)
      ENDWHERE
   ENDWHERE
   WHERE (GTESTLCL)
      ZW_UP2(:,JK+1) = ZW_UP2(:,JK)*(1.-(XBDETR*ZMIX3(:)+XBENTR*ZMIX2(:)))&
            /(1.+(XBDETR*ZMIX3(:)+XBENTR*ZMIX2(:))) &
            +2.*(XABUO)*ZBUO_INTEG/(1.+(XBDETR*ZMIX3(:)+XBENTR*ZMIX2(:)))
   ENDWHERE
 ENDWHERE
  GTESTETL(:)=.FALSE.
  WHERE (GTEST.AND.(ZBUO_INTEG(:)<=0.))
      KKETL(:) = JK+1
      GTESTETL(:)=.TRUE.
  ENDWHERE
  WHERE (GTEST.AND.((ZW_UP2(:,JK+1)<=0.).OR.(PEMF(:,JK+1)<=0.)))
      ZW_UP2(:,JK+1)=0.
      PEMF(:,JK+1)=0.
      GTEST(:)=.FALSE.
      PTHL_UP(:,JK+1)=ZTHLM_F(:,JK+1)
      PRT_UP(:,JK+1)=ZRTM_F(:,JK+1)
      PRC_UP(:,JK+1)=0.
      PRV_UP(:,JK+1)=0.
      PTHV_UP(:,JK+1)=ZTHVM_F(:,JK+1)
      PFRAC_UP(:,JK+1)=0.
      KKCTL(:)=JK+1
  ENDWHERE
  WHERE (GTEST)
      PFRAC_UP(:,JK+1)=PEMF(:,JK+1)/(SQRT(ZW_UP2(:,JK+1))*ZRHO_F(:,JK+1))
  ENDWHERE
  WHERE (GTEST)
      PFRAC_UP(:,JK+1)=MIN(XFRAC_UP_MAX,PFRAC_UP(:,JK+1))
  ENDWHERE
  WHERE ((GTEST.AND.GTESTETL).AND.GTESTLCL)
    PFRAC_UP(:,JK+1)=MIN(PFRAC_UP(:,JK+1),PFRAC_UP(:,JK))
  ENDWHERE
  PEMF(:,JK+1)=PFRAC_UP(:,JK+1)*SQRT(ZW_UP2(:,JK+1))*ZRHO_F(:,JK+1)
ENDDO
PW_UP(:,:)=SQRT(ZW_UP2(:,:))
PEMF(:,KK) =0.
PEMF(:,IKU)=0.
PFRAC_UP(:,IKU)=0.
DO JI=1,SIZE(PTHM,1)
   ZDEPTH(JI) = (PZZ(JI,KKCTL(JI)) - PZZ(JI,KKLCL(JI)) )
END DO
GWORK1(:)= (GTESTLCL(:) .AND. (ZDEPTH(:) > 3000.) )
GWORK2(:,:) = SPREAD( GWORK1(:), DIM=2, NCOPIES=IKU )
ZCOEF(:,:) = SPREAD( (1.-(ZDEPTH(:)-3000.)/1000.), DIM=2, NCOPIES=IKU)
ZCOEF=MIN(MAX(ZCOEF,0.),1.)
WHERE (GWORK2)
   PEMF(:,:) = PEMF(:,:) * ZCOEF(:,:)
   PFRAC_UP(:,:) = PFRAC_UP(:,:) * ZCOEF(:,:)
ENDWHERE
END SUBROUTINE COMPUTE_UPDRAFT
      SUBROUTINE MF_TURB(OMIXUV, PIMPL, PTSTEP, &
                PTSTEP_MET, PDZZ, &
                PRHODJ, &
                PTHLM,PTHVM,PRTM,PUM,PVM, &
                PTHLDT,PRTDT,PUDT,PVDT, &
                PEMF,PTHL_UP,PTHV_UP,PRT_UP,PU_UP,PV_UP, &
                PFLXZTHMF,PFLXZTHVMF,PFLXZRMF,PFLXZUMF,PFLXZVMF )
IMPLICIT NONE
LOGICAL, INTENT(IN) :: OMIXUV
REAL, INTENT(IN) :: PIMPL
REAL, INTENT(IN) :: PTSTEP
REAL, INTENT(IN) :: PTSTEP_MET
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHLM
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRTM
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVM
REAL, DIMENSION(:,:,:), INTENT(IN) :: PUM
REAL, DIMENSION(:,:,:), INTENT(IN) :: PVM
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PTHLDT
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRTDT
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PUDT
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PVDT
REAL, DIMENSION(:,:,:), INTENT(IN) :: PEMF,PTHL_UP,PTHV_UP,PRT_UP,PU_UP,PV_UP
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PFLXZTHMF,PFLXZTHVMF,PFLXZRMF,PFLXZUMF,PFLXZVMF
REAL, DIMENSION(SIZE(PTHLM,1),SIZE(PTHLM,2),SIZE(PTHLM,3)) :: ZVARS
PFLXZTHMF = 0.
PFLXZRMF = 0.
PFLXZTHVMF = 0.
PFLXZUMF = 0.
PFLXZVMF = 0.
PTHLDT = 0.
PRTDT = 0.
PUDT = 0.
PVDT = 0.
PFLXZTHMF(:,:,:) = PEMF(:,:,:)*(PTHL_UP(:,:,:)-MZM(PTHLM(:,:,:)))
PFLXZRMF(:,:,:) = PEMF(:,:,:)*(PRT_UP(:,:,:)-MZM(PRTM(:,:,:)))
PFLXZTHVMF(:,:,:) = PEMF(:,:,:)*(PTHV_UP(:,:,:)-MZM(PTHVM(:,:,:)))
PFLXZTHVMF(:,:,:) = 9.81/PTHVM(:,:,:)* PEMF(:,:,:)*(PTHV_UP(:,:,:)-MZM(PTHVM(:,:,:)))
IF (OMIXUV) THEN
  PFLXZUMF(:,:,:) = PEMF(:,:,:)*(PU_UP(:,:,:)-MZM(PUM(:,:,:)))
  PFLXZVMF(:,:,:) = PEMF(:,:,:)*(PV_UP(:,:,:)-MZM(PVM(:,:,:)))
ENDIF
CALL TRIDIAG_MASSFLUX(PTHLM,PFLXZTHMF,-PEMF,PTSTEP_MET,PIMPL, &
                      PDZZ,PRHODJ,ZVARS )
PFLXZTHMF(:,:,:) = PEMF(:,:,:)*(PTHL_UP(:,:,:)-MZM(ZVARS(:,:,:)))
PTHLDT(:,:,:)= (ZVARS(:,:,:)-PTHLM(:,:,:))/PTSTEP_MET
CALL TRIDIAG_MASSFLUX(PRTM(:,:,:),PFLXZRMF,-PEMF,PTSTEP_MET,PIMPL, &
                                 PDZZ,PRHODJ,ZVARS )
PFLXZRMF(:,:,:) = PEMF(:,:,:)*(PRT_UP(:,:,:)-MZM(ZVARS(:,:,:)))
PRTDT(:,:,:) = (ZVARS(:,:,:)-PRTM(:,:,:))/PTSTEP_MET
IF (OMIXUV) THEN
 CALL TRIDIAG_MASSFLUX(PUM,PFLXZUMF,-PEMF,PTSTEP,PIMPL, &
                                 PDZZ,PRHODJ,ZVARS )
PFLXZUMF(:,:,:) = PEMF(:,:,:)*(PU_UP(:,:,:)-MZM(ZVARS(:,:,:)))
  PUDT(:,:,:)= (ZVARS(:,:,:)-PUM(:,:,:))/PTSTEP_MET
  CALL TRIDIAG_MASSFLUX(PVM,PFLXZVMF,-PEMF,PTSTEP,PIMPL, &
                                 PDZZ,PRHODJ,ZVARS )
PFLXZVMF(:,:,:) = PEMF(:,:,:)*(PV_UP(:,:,:)-MZM(ZVARS(:,:,:)))
  PVDT(:,:,:)= (ZVARS(:,:,:)-PVM(:,:,:))/PTSTEP_MET
ENDIF
END SUBROUTINE MF_TURB
FUNCTION MZM(PA) RESULT(PMZM)
IMPLICIT NONE
REAL, DIMENSION(:,:,:), INTENT(IN) :: PA
REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMZM
INTEGER :: JK
INTEGER :: IKU
IKU = SIZE(PA,3)
DO JK=2,IKU
   PMZM(:,:,JK)=0.5*(PA(:,:,JK)+PA(:,:,JK-1))
ENDDO
PMZM(:,:,1)=PA(:,:,2)
END FUNCTION MZM
      SUBROUTINE TH_R_FROM_THL_RT_1D(HFRAC_ICE,PFRAC_ICE,PP, &
                                  PTHL, PRT, PTH, PRV, PRL, PRI )
IMPLICIT NONE
CHARACTER*1 , INTENT(IN) :: HFRAC_ICE
REAL, DIMENSION(:), INTENT(INOUT) :: PFRAC_ICE
REAL, DIMENSION(:), INTENT(IN) :: PP
REAL, DIMENSION(:), INTENT(IN) :: PTHL
REAL, DIMENSION(:),INTENT(IN) :: PRT
REAL, DIMENSION(:), INTENT(OUT):: PTH
REAL, DIMENSION(:), INTENT(OUT):: PRV
REAL, DIMENSION(:), INTENT(OUT):: PRL
REAL, DIMENSION(:), INTENT(OUT):: PRI
INTEGER :: II
REAL :: ZCOEF
REAL, DIMENSION(SIZE(PP,1)) :: ZEXN,ZFOES,ZQVSAT
REAL, DIMENSION(SIZE(PTHL,1)) :: ZRVSAT,ZCPH,ZRLTEMP
REAL, DIMENSION(SIZE(PTHL,1)) :: ZT,ZLOVCPEXN,ZLOSCPEXN
ZCOEF = 0.8
PRL(:)=0.
PRI(:)=0.
ZRLTEMP(:)=0.
PRV(:)=PRT(:)
PTH(:)=PTHL(:)
ZEXN(:)=(PP(:)/XP00) ** (XRD/XCPD)
    DO II=1,20
      ZT(:)=PTH(:)*ZEXN(:)
      WHERE (ZT(:) > 273.15)
      ZFOES(:) = EXP( XALPW - XBETAW/ZT(:) - XGAMW*LOG(ZT(:)) )
      ZQVSAT(:) = XRD/XRV*ZFOES(:)/PP(:) &
                   / (1.+(XRD/XRV-1.)*ZFOES(:)/PP(:))
      ZRVSAT(:) = (1-ZCOEF)*ZQVSAT(:)*(1+PRT(:))+(ZCOEF)*PRV(:)
      PFRAC_ICE(:)=0.
      ZRLTEMP(:)=MAX(0.,PRV(:)-ZRVSAT(:))
      PRV(:)=PRV(:)-ZRLTEMP(:)
      PRL(:)=PRL(:)+PRI(:)+ZRLTEMP(:)
      PRI(:) = PFRAC_ICE(:) * (PRL(:))
      PRL(:) = (1-PFRAC_ICE(:))* (PRT(:) - PRV(:))
      ZCPH(:)=XCPD+ XCPV * PRV(:)+ XCL * PRL(:) + XCI * PRI(:)
      ZLOVCPEXN(:) = (XLVTT + (XCPV-XCL) * (ZT(:)-XTT)) &
                        /(ZCPH*ZEXN(:))
      ZLOSCPEXN(:) = (XLSTT + (XCPV-XCI) * (ZT(:)-XTT)) &
                        /(ZCPH*ZEXN(:))
      PTH(:)=PTHL(:)+ZLOVCPEXN*PRL(:)+ZLOSCPEXN(:)*PRI(:)
      ELSEWHERE
        PRL(:)=0.
        PRI(:)=0.
        PRV(:)=PRT(:)
        PTH(:)=PTHL(:)
      ENDWHERE
    ENDDO
END SUBROUTINE TH_R_FROM_THL_RT_1D
      SUBROUTINE TH_R_FROM_THL_RT_2D(HFRAC_ICE,PFRAC_ICE,PP, &
                                  PTHL, PRT, PTH, PRV, PRL, PRI )
IMPLICIT NONE
CHARACTER*1 , INTENT(IN) :: HFRAC_ICE
REAL, DIMENSION(:,:), INTENT(INOUT) :: PFRAC_ICE
REAL, DIMENSION(:,:), INTENT(IN) :: PP
REAL, DIMENSION(:,:), INTENT(IN) :: PTHL
REAL, DIMENSION(:,:),INTENT(IN) :: PRT
REAL, DIMENSION(:,:), INTENT(OUT):: PTH
REAL, DIMENSION(:,:), INTENT(OUT):: PRV
REAL, DIMENSION(:,:), INTENT(OUT):: PRL
REAL, DIMENSION(:,:), INTENT(OUT):: PRI
INTEGER :: II
REAL :: ZCOEF
REAL, DIMENSION(SIZE(PP,1),SIZE(PP,2)) :: ZEXN,ZFOES,ZQVSAT
REAL, DIMENSION(SIZE(PTHL,1),SIZE(PTHL,2)) :: ZRVSAT,ZCPH,ZRLTEMP
REAL, DIMENSION(SIZE(PTHL,1),SIZE(PTHL,2)) :: ZT,ZLOVCPEXN,ZLOSCPEXN
ZCOEF = 0.8
PRL(:,:)=0.
PRI(:,:)=0.
ZRLTEMP(:,:)=0.
PRV(:,:)=PRT(:,:)
PTH(:,:)=PTHL(:,:)
ZEXN(:,:)=(PP(:,:)/XP00) ** (XRD/XCPD)
    DO II=1,20
      ZT(:,:)=PTH(:,:)*ZEXN(:,:)
      WHERE (ZT(:,:) > 273.15)
      ZFOES(:,:) = EXP( XALPW - XBETAW/ZT(:,:) - XGAMW*LOG(ZT(:,:)) )
      ZQVSAT(:,:) = XRD/XRV*ZFOES(:,:)/PP(:,:) &
                   / (1.+(XRD/XRV-1.)*ZFOES(:,:)/PP(:,:))
      ZRVSAT(:,:) = (1-ZCOEF)*ZQVSAT(:,:)*(1+PRT(:,:))+(ZCOEF)*PRV(:,:)
      PFRAC_ICE(:,:) = 0.
      ZRLTEMP(:,:)=MAX(0.,PRV(:,:)-ZRVSAT(:,:))
      PRV(:,:)=PRV(:,:)-ZRLTEMP(:,:)
      PRL(:,:)=PRL(:,:)+PRI(:,:)+ZRLTEMP(:,:)
      PRI(:,:) = PFRAC_ICE(:,:) * (PRL(:,:))
      PRL(:,:) = (1-PFRAC_ICE(:,:))* (PRT(:,:) - PRV(:,:))
        ZCPH(:,:)=XCPD+ XCPV * PRV(:,:)+ XCL * PRL(:,:) + XCI * PRI(:,:)
        ZLOVCPEXN(:,:) = (XLVTT + (XCPV-XCL) * (ZT(:,:)-XTT)) &
                        /(ZCPH*ZEXN(:,:))
        ZLOSCPEXN(:,:) = (XLSTT + (XCPV-XCI) * (ZT(:,:)-XTT)) &
                        /(ZCPH*ZEXN(:,:))
        PTH(:,:)=PTHL(:,:)+ZLOVCPEXN*PRL(:,:)+ZLOSCPEXN(:,:)*PRI(:,:)
      ELSEWHERE
        PRL(:,:)=0.
        PRI(:,:)=0.
        PRV(:,:)=PRT(:,:)
        PTH(:,:)=PTHL(:,:)
       ENDWHERE
    ENDDO
END SUBROUTINE TH_R_FROM_THL_RT_2D
      SUBROUTINE THL_RT_FROM_TH_R_MF( KRR,KRRL,KRRI, &
                                       PTH, PR, PLVOCPEXN, PLSOCPEXN, &
                                       PTHL, PRT )
IMPLICIT NONE
INTEGER, INTENT(IN) :: KRR
INTEGER, INTENT(IN) :: KRRL
INTEGER, INTENT(IN) :: KRRI
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTH
REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PR
REAL, DIMENSION(:,:,:), INTENT(IN) :: PLVOCPEXN, PLSOCPEXN
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PTHL
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRT
IF ( KRRL >= 1 ) THEN
  IF ( KRRI >= 1 ) THEN
    PRT(:,:,:) = PR(:,:,:,1) + PR(:,:,:,2) + PR(:,:,:,4)
    PTHL(:,:,:) = PTH(:,:,:) - PLVOCPEXN(:,:,:) * PR(:,:,:,2) &
                               - PLSOCPEXN(:,:,:) * PR(:,:,:,4)
  ELSE
    PRT(:,:,:) = PR(:,:,:,1) + PR(:,:,:,2)
    PTHL(:,:,:) = PTH(:,:,:) - PLVOCPEXN(:,:,:) * PR(:,:,:,2)
  END IF
ELSE
PRT(:,:,:) = PR(:,:,:,1)
PTHL(:,:,:) = PTH(:,:,:)
END IF
END SUBROUTINE THL_RT_FROM_TH_R_MF
       SUBROUTINE TRIDIAG_MASSFLUX(PVARM,PF,PDFDT,PTSTEP,PIMPL, &
                                 PDZZ,PRHODJ,PVARP )
IMPLICIT NONE
REAL, DIMENSION(:,:,:), INTENT(IN) :: PVARM
REAL, DIMENSION(:,:,:), INTENT(IN) :: PF
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDFDT
REAL, INTENT(IN) :: PTSTEP
REAL, INTENT(IN) :: PIMPL
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ
REAL, DIMENSION(:,:,:), INTENT(OUT):: PVARP
REAL, DIMENSION(SIZE(PVARM,1),SIZE(PVARM,2),SIZE(PVARM,3)) :: ZRHODJ_DFDT_O_DZ
REAL, DIMENSION(SIZE(PVARM,1),SIZE(PVARM,2),SIZE(PVARM,3)) :: ZMZM_RHODJ
REAL, DIMENSION(SIZE(PVARM,1),SIZE(PVARM,2),SIZE(PVARM,3)) :: ZA, ZB, ZC
REAL, DIMENSION(SIZE(PVARM,1),SIZE(PVARM,2),SIZE(PVARM,3)) :: ZY ,ZGAM
REAL, DIMENSION(SIZE(PVARM,1),SIZE(PVARM,2)) :: ZBET
INTEGER :: JK
INTEGER :: IKB,IKE
IKB=1
IKE=SIZE(PVARM,3)-1
ZMZM_RHODJ = MZM(PRHODJ)
ZRHODJ_DFDT_O_DZ = ZMZM_RHODJ*PDFDT/PDZZ
ZA=0.
ZB=0.
ZC=0.
ZY=0.
ZY(:,:,IKB) = PRHODJ(:,:,IKB)*PVARM(:,:,IKB)/PTSTEP &
    - ZMZM_RHODJ(:,:,IKB+1) * PF(:,:,IKB+1)/PDZZ(:,:,IKB+1) &
    + ZMZM_RHODJ(:,:,IKB ) * PF(:,:,IKB )/PDZZ(:,:,IKB ) &
    + ZRHODJ_DFDT_O_DZ(:,:,IKB+1) * 0.5*PIMPL * PVARM(:,:,IKB+1) &
    + ZRHODJ_DFDT_O_DZ(:,:,IKB+1) * 0.5*PIMPL * PVARM(:,:,IKB )
DO JK=IKB+1,IKE-1
  ZY(:,:,JK) = PRHODJ(:,:,JK)*PVARM(:,:,JK)/PTSTEP &
    - ZMZM_RHODJ(:,:,JK+1) * PF(:,:,JK+1)/PDZZ(:,:,JK+1) &
    + ZMZM_RHODJ(:,:,JK ) * PF(:,:,JK )/PDZZ(:,:,JK ) &
    + ZRHODJ_DFDT_O_DZ(:,:,JK+1) * 0.5*PIMPL * PVARM(:,:,JK+1) &
    + ZRHODJ_DFDT_O_DZ(:,:,JK+1) * 0.5*PIMPL * PVARM(:,:,JK ) &
    - ZRHODJ_DFDT_O_DZ(:,:,JK ) * 0.5*PIMPL * PVARM(:,:,JK ) &
    - ZRHODJ_DFDT_O_DZ(:,:,JK ) * 0.5*PIMPL * PVARM(:,:,JK-1)
END DO
ZY(:,:,IKE) = PRHODJ(:,:,IKE)*PVARM(:,:,IKE)/PTSTEP &
    - ZMZM_RHODJ(:,:,IKE+1) * PF(:,:,IKE+1)/PDZZ(:,:,IKE+1) &
    + ZMZM_RHODJ(:,:,IKE ) * PF(:,:,IKE )/PDZZ(:,:,IKE ) &
    - ZRHODJ_DFDT_O_DZ(:,:,IKE ) * 0.5*PIMPL * PVARM(:,:,IKE ) &
    - ZRHODJ_DFDT_O_DZ(:,:,IKE ) * 0.5*PIMPL * PVARM(:,:,IKE-1)
IF ( PIMPL > 1.E-10 ) THEN
  ZB(:,:,IKB) = PRHODJ(:,:,IKB)/PTSTEP &
                + ZRHODJ_DFDT_O_DZ(:,:,IKB+1) * 0.5*PIMPL
  ZC(:,:,IKB) = ZRHODJ_DFDT_O_DZ(:,:,IKB+1) * 0.5*PIMPL
  DO JK=IKB+1,IKE-1
    ZA(:,:,JK) = - ZRHODJ_DFDT_O_DZ(:,:,JK ) * 0.5*PIMPL
    ZB(:,:,JK) = PRHODJ(:,:,JK)/PTSTEP &
                 + ZRHODJ_DFDT_O_DZ(:,:,JK+1) * 0.5*PIMPL &
                 - ZRHODJ_DFDT_O_DZ(:,:,JK ) * 0.5*PIMPL
    ZC(:,:,JK) = ZRHODJ_DFDT_O_DZ(:,:,JK+1) * 0.5*PIMPL
  END DO
  ZA(:,:,IKE) = - ZRHODJ_DFDT_O_DZ(:,:,IKE ) * 0.5*PIMPL
  ZB(:,:,IKE) = PRHODJ(:,:,IKE)/PTSTEP &
                - ZRHODJ_DFDT_O_DZ(:,:,IKE ) * 0.5*PIMPL
  ZBET(:,:) = ZB(:,:,IKB)
  PVARP(:,:,IKB) = ZY(:,:,IKB) / ZBET(:,:)
  DO JK = IKB+1,IKE-1
    ZGAM(:,:,JK) = ZC(:,:,JK-1) / ZBET(:,:)
    ZBET(:,:) = ZB(:,:,JK) - ZA(:,:,JK) * ZGAM(:,:,JK)
    PVARP(:,:,JK)= ( ZY(:,:,JK) - ZA(:,:,JK) * PVARP(:,:,JK-1) ) / ZBET(:,:)
  END DO
  ZGAM(:,:,IKE) = ZC(:,:,IKE-1) / ZBET(:,:)
  ZBET(:,:) = ZB(:,:,IKE) - ZA(:,:,IKE) * ZGAM(:,:,IKE)
  PVARP(:,:,IKE)= ( ZY(:,:,IKE) - ZA(:,:,IKE) * PVARP(:,:,IKE-1) ) / ZBET(:,:)
  DO JK = IKE-1,IKB,-1
    PVARP(:,:,JK) = PVARP(:,:,JK) - ZGAM(:,:,JK+1) * PVARP(:,:,JK+1)
  END DO
ELSE
  PVARP(:,:,IKB:IKE) = ZY(:,:,IKB:IKE) * PTSTEP / PRHODJ(:,:,IKB:IKE)
END IF
PVARP(:,:,IKE+1)=PVARP(:,:,IKE)
END SUBROUTINE TRIDIAG_MASSFLUX
      SUBROUTINE UPDRAFT_SOPE(KRR,KRRL,KRRI,OMIXUV, &
                         PZZ,PDZZ,PSFTH,PSFRV,PPABSM,PRHODREF, &
                         PTKEM,PTHM,PRM,PTHLM,PRTM,PUM,PVM, &
                         PTHL_UP,PRT_UP,PRV_UP,PU_UP,PV_UP, &
                         PRC_UP,PRI_UP,PTHV_UP,PW_UP,PFRAC_UP,PEMF, &
                         PDETR,PENTR,KKLCL,KKETL,KKCTL )
IMPLICIT NONE
INTEGER, INTENT(IN) :: KRR
INTEGER, INTENT(IN) :: KRRL
INTEGER, INTENT(IN) :: KRRI
LOGICAL, INTENT(IN) :: OMIXUV
REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ
REAL, DIMENSION(:,:), INTENT(IN) :: PSFTH,PSFRV
REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSM
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTKEM
REAL, DIMENSION(:,:,:), INTENT(IN) :: PUM,PVM
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHM
REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRM
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHLM,PRTM
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PTHL_UP,PRT_UP
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRV_UP,PRC_UP,PRI_UP,&
                                           PW_UP,PFRAC_UP,PEMF, &
                                           PDETR,PENTR,PTHV_UP, &
                                           PU_UP, PV_UP
INTEGER, DIMENSION(:,:), INTENT(OUT) :: KKLCL,KKETL,KKCTL
INTEGER :: IKB
REAL, DIMENSION(SIZE(PTKEM,1)*SIZE(PTKEM,2),SIZE(PTKEM,3)) :: ZPABSM,ZRHODREF
REAL, DIMENSION(SIZE(PTKEM,1)*SIZE(PTKEM,2),SIZE(PTKEM,3)) :: ZZZ,ZDZZ
REAL, DIMENSION(SIZE(PTKEM,1)*SIZE(PTKEM,2),SIZE(PTKEM,3)) :: ZTHLM,ZRTM,&
                                                              ZTHM,ZTKEM,&
                                                              ZUM,ZVM
REAL, DIMENSION(SIZE(PTKEM,1)*SIZE(PTKEM,2),SIZE(PTKEM,3)) :: ZRVM,ZRCM,ZRIM
REAL, DIMENSION(SIZE(PSFTH,1)*SIZE(PSFTH,2)) :: ZSFTH,ZSFRV
REAL, DIMENSION(SIZE(PTKEM,1)*SIZE(PTKEM,2),SIZE(PTKEM,3)) :: ZTHL_UP,ZRT_UP,&
                                      ZRV_UP,ZRC_UP, ZRI_UP, &
                                      ZW_UP,ZU_UP,ZV_UP,ZTHV_UP, &
                                      ZFRAC_UP,ZEMF_UP,ZENTR_UP,ZDETR_UP
REAL, DIMENSION(SIZE(PTKEM,1)*SIZE(PTKEM,2)) :: ZFRAC_GRID
INTEGER, DIMENSION(SIZE(PTKEM,1)*SIZE(PTKEM,2)) :: JKETL,JKCTL,JKLCL
INTEGER :: IIU,IJU,IKU
INTEGER :: J1D
INTEGER :: JK,JKK,JSV
INTEGER :: JRR
REAL :: ZRVORD
IIU=SIZE(PTKEM,1)
IJU=SIZE(PTKEM,2)
IKB = 1
IKU = SIZE(PTKEM,3)
ZRVORD = XRV / XRD
DO JK=IKB,IKU
  ZZZ (:,JK) = RESHAPE(PZZ (:,:,JK),(/ IIU*IJU /) )
  ZDZZ (:,JK) = RESHAPE(PDZZ (:,:,JK),(/ IIU*IJU /) )
  ZTHM (:,JK) = RESHAPE(PTHM (:,:,JK),(/ IIU*IJU /) )
  ZTKEM (:,JK) = RESHAPE(PTKEM (:,:,JK),(/ IIU*IJU /) )
  ZPABSM (:,JK) = RESHAPE(PPABSM (:,:,JK),(/ IIU*IJU /) )
  ZRHODREF(:,JK) = RESHAPE(PRHODREF(:,:,JK),(/ IIU*IJU /) )
  ZRVM (:,JK) = RESHAPE(PRM (:,:,JK,1),(/ IIU*IJU /) )
  ZTHLM (:,JK) = RESHAPE(PTHLM (:,:,JK),(/ IIU*IJU /) )
  ZRTM (:,JK) = RESHAPE(PRTM (:,:,JK),(/ IIU*IJU /) )
  ZUM (:,JK) = RESHAPE(PUM (:,:,JK),(/ IIU*IJU /) )
  ZVM (:,JK) = RESHAPE(PVM (:,:,JK),(/ IIU*IJU /) )
END DO
IF (KRRL>1) THEN
DO JK=1,IKU
  ZRCM (:,JK) = RESHAPE(PRM (:,:,JK,2),(/ IIU*IJU /) )
END DO
ELSE
  ZRCM (:,:) =0.
ENDIF
IF (KRRI>1) THEN
DO JK=1,IKU
  ZRIM (:,JK) = RESHAPE(PRM (:,:,JK,4),(/ IIU*IJU /) )
END DO
ELSE
  ZRIM (:,:) =0.
ENDIF
ZSFTH(:)=RESHAPE(PSFTH(:,:),(/ IIU*IJU /) )
ZSFRV(:)=RESHAPE(PSFRV(:,:),(/ IIU*IJU /) )
JK=IKB
CALL COMPUTE_UPDRAFT(OMIXUV,ZZZ,ZDZZ,JK, &
                     ZSFTH,ZSFRV,ZPABSM,ZRHODREF,ZUM,ZVM,ZTKEM, &
                     ZTHM,ZRVM,ZRCM,ZRIM,ZTHLM,ZRTM, &
                     ZTHL_UP,ZRT_UP,ZRV_UP,ZRC_UP,ZRI_UP,&
                     ZTHV_UP,ZW_UP,ZU_UP,ZV_UP, &
                     ZFRAC_UP,ZEMF_UP,&
                     ZDETR_UP,ZENTR_UP,&
                     JKLCL,JKETL,JKCTL)
PTHL_UP(:,:,:)= RESHAPE(ZTHL_UP(:,:), (/ IIU,IJU,IKU /))
PRT_UP(:,:,:)=RESHAPE(ZRT_UP(:,:), (/ IIU,IJU,IKU /) )
PRV_UP(:,:,:)=RESHAPE(ZRV_UP(:,:), (/ IIU,IJU,IKU /) )
PRC_UP(:,:,:)=RESHAPE(ZRC_UP(:,:), (/ IIU,IJU,IKU /) )
PRI_UP(:,:,:)=RESHAPE(ZRI_UP(:,:), (/ IIU,IJU,IKU /) )
PW_UP(:,:,:)=RESHAPE(ZW_UP(:,:), (/ IIU,IJU,IKU /) )
PU_UP(:,:,:)=RESHAPE(ZU_UP(:,:), (/ IIU,IJU,IKU /) )
PV_UP(:,:,:)=RESHAPE(ZV_UP(:,:), (/ IIU,IJU,IKU /) )
PEMF(:,:,:)=RESHAPE(ZEMF_UP(:,:), (/ IIU,IJU,IKU /) )
PDETR(:,:,:)=RESHAPE(ZDETR_UP(:,:), (/ IIU,IJU,IKU /) )
PENTR(:,:,:)=RESHAPE(ZENTR_UP(:,:), (/ IIU,IJU,IKU /) )
PTHV_UP(:,:,:)=RESHAPE(ZTHV_UP(:,:), (/ IIU,IJU,IKU /) )
KKETL(:,:)=RESHAPE(JKETL(:),(/ IIU,IJU/) )
KKCTL(:,:)=RESHAPE(JKCTL(:),(/ IIU,IJU/) )
KKLCL(:,:)=RESHAPE(JKLCL(:),(/ IIU,IJU/) )
PFRAC_UP(:,:,:)=RESHAPE(ZFRAC_UP(:,:),(/ IIU,IJU,IKU /) )
END SUBROUTINE UPDRAFT_SOPE
      SUBROUTINE COMPUTE_MF_CLOUD(KRRL, PTHLM,PRC_UP, PFRAC_UP, PDZZ, KKLCL,&
                                  PRC_MF,PCF_MF )
IMPLICIT NONE
INTEGER, INTENT(IN) :: KRRL
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHLM
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRC_UP
REAL, DIMENSION(:,:,:), INTENT(IN) :: PFRAC_UP
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ
INTEGER, DIMENSION(:,:), INTENT(IN) :: KKLCL
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRC_MF, PCF_MF
REAL, DIMENSION(SIZE(PTHLM,1),SIZE(PTHLM,2),SIZE(PTHLM,3)) :: ZFLXZ
INTEGER :: IKU, IKB, IKE, JI,JJ,JK
IKU=SIZE(PTHLM,3)
IKB=1
IKE=IKU-1
PCF_MF = 0.
PRC_MF = 0.
DO JI=1,SIZE(PCF_MF,1)
DO JJ=1,SIZE(PCF_MF,2)
DO JK=KKLCL(JI,JJ),IKE
PCF_MF(JI,JJ,JK ) = XKCF_MF *0.5* ( &
  & PFRAC_UP(JI,JJ,JK) + PFRAC_UP(JI,JJ,JK+1) )
PRC_MF(JI,JJ,JK) = 0.5* XKCF_MF * ( PFRAC_UP(JI,JJ,JK)*PRC_UP(JI,JJ,JK) &
                         + PFRAC_UP(JI,JJ,JK+1)*PRC_UP(JI,JJ,JK+1) )
END DO
END DO
END DO
END SUBROUTINE COMPUTE_MF_CLOUD
      SUBROUTINE mfshconvpblinit(massflux_EDKF, entr_EDKF, detr_EDKF &
                                     ,thl_up, thv_up, rt_up &
                                     ,rv_up, rc_up, u_up, v_up &
                                     ,frac_up,RESTART,ALLOWED_TO_READ, &
     & IDS,IDE,JDS,JDE,KDS,KDE, &
     & IMS,IME,JMS,JME,KMS,KME, &
     & ITS,ITE,JTS,JTE,KTS,KTE )
      IMPLICIT NONE
      LOGICAL,INTENT(IN) :: ALLOWED_TO_READ,RESTART
      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE, &
     & IMS,IME,JMS,JME,KMS,KME, &
     & ITS,ITE,JTS,JTE,KTS,KTE
      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT),OPTIONAL :: &
     & MASSFLUX_EDKF, ENTR_EDKF, DETR_EDKF &
     & ,THL_UP, THV_UP, RT_UP, RV_UP &
     & ,RC_UP, U_UP, V_UP, FRAC_UP
      INTEGER :: I,J,K,ITF,JTF,KTF
      JTF=MIN0(JTE,JDE-1)
      KTF=MIN0(KTE,KDE-1)
      ITF=MIN0(ITE,IDE-1)
      IF( PRESENT (MASSFLUX_EDKF) ) THEN
        DO J=JTS,JTF
        DO K=KTS,KTF
        DO I=ITS,ITF
          MASSFLUX_EDKF(I,K,J)=0.
          ENTR_EDKF(I,K,J)=0.
          DETR_EDKF(I,K,J)=0.
          THL_UP(I,K,J)=0.
          THV_UP(I,K,J)=0.
          RT_UP(I,K,J)=0.
          RV_UP(I,K,J)=0.
          RC_UP(I,K,J)=0.
          U_UP(I,K,J)=0.
          V_UP(I,K,J)=0.
          FRAC_UP(I,K,J)=0.
        ENDDO
        ENDDO
        ENDDO
      ENDIF
END SUBROUTINE mfshconvpblinit
      SUBROUTINE BL89(PZZ,PDZZ,PTHVREF,PTHLM,KRR, &
                 PRM,PTKEM,PLM)
INTEGER, INTENT(IN) :: KRR
REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ
REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHVREF
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTKEM
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHLM
REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRM
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PLM
INTEGER :: IKB,IKE
REAL, DIMENSION(SIZE(PTKEM,1)*SIZE(PTKEM,2),SIZE(PTKEM,3)) :: ZRTM
REAL, DIMENSION(SIZE(PTKEM,1)*SIZE(PTKEM,2),SIZE(PTKEM,3)) ::ZVPT
REAL, DIMENSION(SIZE(PTKEM,1)*SIZE(PTKEM,2)) :: ZLWORK
REAL, DIMENSION(SIZE(PTKEM,1)*SIZE(PTKEM,2),SIZE(PTKEM,3)) :: ZZZ,ZDZZ,&
                                                              ZG_O_THVREF, &
                                                              ZTHM,ZTKEM,ZLM,&
                                                              ZLMUP,ZLMDN,&
                                                              ZLMTEST
REAL, DIMENSION(SIZE(PRM,1)*SIZE(PRM,2),SIZE(PRM,3),SIZE(PRM,4)) :: ZRM
REAL, DIMENSION(SIZE(PRM,1)*SIZE(PRM,2),SIZE(PRM,3)) :: ZSUM
REAL :: ZPOTE,ZLWORK1,ZLWORK2
INTEGER :: IIU,IJU,IKU,IICE
INTEGER :: J1D
INTEGER :: JK,JKK
INTEGER :: JRR
REAL :: ZRVORD
LOGICAL :: GUPORDN
REAL :: Z2SQRT2
Z2SQRT2=2.*SQRT(2.)
IIU=SIZE(PTKEM,1)
IJU=SIZE(PTKEM,2)
IKB = 1
IKE = SIZE(PTKEM,3)-1
IKU = SIZE(PTKEM,3)
ZRVORD = XRV / XRD
DO JK=1,IKU
  ZZZ (:,JK) = RESHAPE(PZZ (:,:,JK),(/ IIU*IJU /) )
  ZDZZ (:,JK) = RESHAPE(PDZZ (:,:,JK),(/ IIU*IJU /) )
  ZTHM (:,JK) = RESHAPE(PTHLM (:,:,JK),(/ IIU*IJU /) )
  ZTKEM (:,JK) = RESHAPE(PTKEM (:,:,JK),(/ IIU*IJU /) )
  ZG_O_THVREF(:,JK) = RESHAPE(XG/PTHVREF(:,:,JK),(/ IIU*IJU /) )
  DO JRR=1,KRR
    ZRM (:,JK,JRR) = RESHAPE(PRM (:,:,JK,JRR),(/ IIU*IJU /) )
  END DO
END DO
IF(KRR /= 0) THEN
  ZSUM(:,:) = 0.
  DO JRR=1,KRR
    ZSUM(:,:) = ZSUM(:,:)+ZRM(:,:,JRR)
  ENDDO
  ZVPT(:,1:)=ZTHM(:,:) * ( 1. + ZRVORD*ZRM(:,:,1) ) &
                           / ( 1. + ZSUM(:,:) )
ELSE
  ZVPT(:,1:)=ZTHM(:,:)
END IF
DO JK=IKB,IKE
   GUPORDN=.FALSE.
   CALL COMPUTE_BL89_ML(ZDZZ,ZTKEM,ZG_O_THVREF,ZVPT,JK,GUPORDN,ZLWORK)
   ZLMDN(:,JK)=MIN(ZLWORK(:),0.5*(ZZZ(:,JK)+ZZZ(:,JK+1))-ZZZ(:,IKB))
   GUPORDN=.TRUE.
   CALL COMPUTE_BL89_ML(ZDZZ,ZTKEM,ZG_O_THVREF,ZVPT,JK,GUPORDN,ZLWORK)
   ZLMUP(:,JK)=ZLWORK(:)
  DO J1D=1,IIU*IJU
    ZLWORK1=MAX(ZLMDN(J1D,JK),1.E-10)
    ZLWORK2=MAX(ZLMUP(J1D,JK),1.E-10)
    ZPOTE = ZLWORK1 / ZLWORK2
    ZLWORK2=1.d0 + ZPOTE**(2./3.)
    ZLM(J1D,JK) = Z2SQRT2*ZLWORK1/(ZLWORK2*SQRT(ZLWORK2))
  END DO
ZLM(:,JK)=( 0.5* (MAX(ZLMDN(:,JK),1.E-10)**(-2./3.)+MAX(ZLMUP(:,JK),1.E-10)**(-2./3.)) )**(-1.5)
ZLM(:,JK)=MAX(ZLM(:,JK),XLINI)
END DO
ZLM(:,IKE) =ZLM(:,IKE-1)
ZLM(:,IKE+1)=ZLM(:,IKE-1)
ZLMUP(:,IKE) =ZLMUP(:,IKE-1)
ZLMUP(:,IKE+1)=ZLMUP(:,IKE-1)
ZLMDN(:,IKE) =ZLMDN(:,IKE-1)
ZLMDN(:,IKE+1)=ZLMDN(:,IKE-1)
  DO JK=1,IKU
    PLM (:,:,JK) = RESHAPE(ZLM (:,JK), (/ IIU,IJU /) )
  END DO
END SUBROUTINE BL89
END MODULE MODULE_BL_MFSHCONVPBL


module PDEparabolic

!! a module for use for solving parabolic partial differential equations

!> banded and tridiagonal solvers, for now we just take everything to be banded...
use phys_consts, only: wp
use vendor_lapack95, only: gbsv!,gtsv

implicit none (type, external)

private
public :: TRBDF21D, backEuler1D

contains

function TRBDF21D(Ts,A,B,C,D,E,Tsminx1,Tsmaxx1,dt,dx1,dx1i)

!! SOLVE A 1D DIFFUSION PROBLEM.  IT IS EXPECTED THAT
!! GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!! THEY ARE PASSED INTO THIS ROUTINE.
!!
!! FORM OF EQUATION SOLVED IS:
!!  dT/dt + A T + B dT/dx + C d/dx(D dT/dx) = E
!!
!!  NOTE: UPON FURTHER REVIEW I THINK THE FORM SOLVED IS ACTUALLY:
!!  dT/dt = A T + B dT/dx + C d/dx(D dT/dx) + E

real(wp), dimension(:), intent(in) :: A,B,C,D,E
real(wp), dimension(:), intent(in) :: Ts
real(wp), intent(in) :: Tsminx1, Tsmaxx1, dt
real(wp), dimension(0:), intent(in) :: dx1   !ith backward difference
real(wp), dimension(:), intent(in) :: dx1i   !ith centered difference
integer, parameter :: ll=2                   !number of lower diagonals

real(wp), dimension(3*ll+1,size(Ts)) :: M    !note extra rows for lapack workspace
real(wp), dimension(size(Ts)) :: Dh
integer :: ix1,lx1

real(wp), dimension(size(Ts)) :: TR

real(wp), dimension(size(Ts)) :: TRBDF21D

!> ORGANIZE SIZES AND THERMAL CONDUCTIVITY
lx1=size(Ts)
Dh(1)=0
Dh(2:lx1)=0.5*(D(1:lx1-1)+D(2:lx1))         !ith left cell wall thermal conductivity
!    TR(:)=Ts(:)/dt+E(:)
!! boundaries to be overwritten later...  This is now done for each grid point in a separate statement

!! ## TR HALF STEP:  DEFINE A MATRIX USING BANDED STORAGE

! ZZZ - check whether diriclet or neumann...
!> MINX1 BOUNDARY (DIRICHLET)
ix1=1
M(ll+3,ix1)=1
M(ll+2,ix1+1)=0
M(ll+1,ix1+2)=0
TR(ix1)=Tsminx1

!> FIRST INTERIOR GRID POINT
ix1=2

!> ix1-1
M(ll+4,ix1-1)=-C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)/2 &
           +B(ix1)/(dx1(ix1+1)+dx1(ix1))/2

!> ix1
M(ll+3,ix1)=1/(dt/2)-A(ix1)/2 &
         +C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1)/2 &
         +C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)/2

!> ix1+1, super-diag.
M(ll+2,ix1+1)=-C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1)/2 &
         -B(ix1)/(dx1(ix1+1)+dx1(ix1))/2
M(ll+1,ix1+2)=0
TR(ix1)=Ts(ix1)/(dt/2)+E(ix1) &
  -M(ll+4,ix1-1)*Ts(ix1-1) &
  -(-A(ix1)/2+C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1)/2+C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)/2)*Ts(ix1) &
  -M(ll+2,ix1+1)*Ts(ix1+1) &
  -M(ll+1,ix1+2)*Ts(ix1+2)

!> INTERIOR GRID POINTS
do concurrent (ix1=3:lx1-2)
  !! do concurrent OK because only indexing already defined things
  M(ll+5,ix1-2) = 0
  !! ix1-2 grid point, sub-diag.
  M(ll+4,ix1-1)=-C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)/2 &        !ix1-1
             +B(ix1)/(dx1(ix1+1)+dx1(ix1))/2
  M(ll+3,ix1)=1/(dt/2)-A(ix1)/2 &                           !ix1
           +C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1)/2 &
           +C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)/2
  M(ll+2,ix1+1)=-C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1)/2 &    !ix1+1, super-diag.
           -B(ix1)/(dx1(ix1+1)+dx1(ix1))/2
  M(ll+1,ix1+2) = 0
  !! ix1+2 grid point
  TR(ix1)=Ts(ix1)/(dt/2)+E(ix1) &
    -M(ll+5,ix1-2)*Ts(ix1-2) &
    -M(ll+4,ix1-1)*Ts(ix1-1) &
    -(-A(ix1)/2+C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1)/2+C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)/2)*Ts(ix1) &
    -M(ll+2,ix1+1)*Ts(ix1+1) &
    -M(ll+1,ix1+2)*Ts(ix1+2)
end do

!> LAST INTERIOR GRID POINT
ix1=lx1-1
M(ll+5,ix1-2)=0
M(ll+4,ix1-1)=-C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)/2 &            !ix1-1
           +B(ix1)/(dx1(ix1+1)+dx1(ix1))/2
M(ll+3,ix1)=1/(dt/2)-A(ix1)/2 &                               !ix1
         +C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1)/2 &
         +C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)/2
M(ll+2,ix1+1)=-C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1)/2 &        !ix1+1, super-diag.
         -B(ix1)/(dx1(ix1+1)+dx1(ix1))/2
TR(ix1)=Ts(ix1)/(dt/2)+E(ix1) &
  -M(ll+5,ix1-2)*Ts(ix1-2) &
  -M(ll+4,ix1-1)*Ts(ix1-1) &
  -(-A(ix1)/2+C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1)/2+C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)/2)*Ts(ix1) &
  -M(ll+2,ix1+1)*Ts(ix1+1)

! ZZZ - check whether dirichlet or neumann...
!> MAXX1 BOUNDARY
ix1=lx1
M(ll+5,ix1-2)=0
M(ll+4,ix1-1)=0
M(ll+3,ix1)=1
TR(ix1)=Tsmaxx1

!! ### TR HALF STEP MATRIX SOLUTION:  CALL LAPACK'S BANDED SOLVER

!> BANDED SOLVER (INPUT MATRIX MUST BE SHIFTED 'DOWN' BY KL ROWS)
call gbsv(M,TR,kl=2)

!! ## BDF2 STEP:  DEFINE A MATRIX USING BANDED STORAGE

!ZZZ - check whether D or N
!> MINX1 BOUNDARY (DIRICHLET)
ix1=1
M(ll+3,ix1)=1
M(ll+2,ix1+1)=0
M(ll+1,ix1+2)=0
TRBDF21D(ix1)=Tsminx1

!> FIRST INTERIOR GRID POINT
ix1=2
M(ll+4,ix1-1)=-C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1) &            !ix1-1
           +B(ix1)/(dx1(ix1+1)+dx1(ix1))
M(ll+3,ix1)=1/(dt/3)-A(ix1) &                               !ix1
         +C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1) &
         +C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)
M(ll+2,ix1+1)=-C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1) &        !ix1+1, super-diag.
         -B(ix1)/(dx1(ix1+1)+dx1(ix1))
M(ll+1,ix1+2)=0
TRBDF21D(ix1)=E(ix1) &
  -1/3._wp*Ts(ix1)/(dt/3) &
  +4/3._wp*TR(ix1)/(dt/3)

!> INTERIOR GRID POINTS
do concurrent (ix1=3:lx1-2)
  M(ll+5,ix1-2)=0                                               !ix1-2 grid point, sub-diag.
  M(ll+4,ix1-1)=-C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1) &        !ix1-1
             +B(ix1)/(dx1(ix1+1)+dx1(ix1))
  M(ll+3,ix1)=1/(dt/3)-A(ix1) &                           !ix1
           +C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1) &
           +C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)
  M(ll+2,ix1+1)=-C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1) &    !ix1+1, super-diag.
           -B(ix1)/(dx1(ix1+1)+dx1(ix1))
  M(ll+1,ix1+2)=0                                               !ix1+2 grid point
  TRBDF21D(ix1)=E(ix1) &
    -1/3._wp*Ts(ix1)/(dt/3) &
    +4/3._wp*TR(ix1)/(dt/3)
end do

!LAST INTERIOR GRID POINT
ix1=lx1-1
M(ll+5,ix1-2)=0
M(ll+4,ix1-1)=-C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1) &            !ix1-1
           +B(ix1)/(dx1(ix1+1)+dx1(ix1))
M(ll+3,ix1)=1/(dt/3)-A(ix1) &                               !ix1
         +C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1) &
         +C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)
M(ll+2,ix1+1)=-C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1) &        !ix1+1, super-diag.
         -B(ix1)/(dx1(ix1+1)+dx1(ix1))
TRBDF21D(ix1)=E(ix1) &
  -1/3._wp*Ts(ix1)/(dt/3) &
  +4/3._wp*TR(ix1)/(dt/3)

!check whether D or N
!> MAXX1 BOUNDARY
ix1=lx1
M(ll+5,ix1-2)=0
M(ll+4,ix1-1)=0
M(ll+3,ix1)=1
TRBDF21D(ix1)=Tsmaxx1

!! ## BDF2 STEP MATRIX SOLUTION:  CALL LAPACK'S BANDED SOLVER

!> BANDED SOLVER (INPUT MATRIX MUST BE SHIFTED 'DOWN' BY KL ROWS)
call gbsv(M,TRBDF21D,kl=2)

end function TRBDF21D

function backEuler1D(Ts,A,B,C,D,E,Tsminx1,Tsmaxx1,dt,dx1,dx1i,coeffs,rhs)

!------------------------------------------------------------
!-------SOLVE A 1D DIFFUSION PROBLEM.  IT IS EXPECTED THAT
!-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!-------THEY ARE PASSED INTO THIS ROUTINE.  FORM OF EQUATION
!-------SOLVED IS:
!------- dT/dt + A T + B dT/dx + C d/dx(D dT/dx) = E
!------------------------------------------------------------

real(wp), dimension(:), intent(in) :: A,B,C,D,E
real(wp), dimension(:), intent(in) :: Ts
real(wp), intent(in) :: Tsminx1, Tsmaxx1, dt
real(wp), dimension(0:), intent(in) :: dx1   !ith backward difference
real(wp), dimension(:), intent(in) :: dx1i   !ith centered difference
real(wp), dimension(:,:), intent(inout), optional :: coeffs
!! intent(out)
real(wp), dimension(:), intent(inout), optional :: rhs
!! intent(out)

integer, parameter :: ll=2                   !number of lower diagonals
real(wp), dimension(3*ll+1,size(Ts)) :: M    !note extra rows for lapack workspace
real(wp), dimension(size(Ts)) :: Dh
real(wp), dimension(size(Ts)) :: backEuler1D
integer :: ix1,lx1

!------------------------------------------------------------
!-------DEFINE A MATRIX USING BANDED STORAGE
!------------------------------------------------------------
lx1=size(Ts)
Dh(1)=0
Dh(2:lx1)=0.5*(D(1:lx1-1)+D(2:lx1))         !ith left cell wall thermal conductivity
backEuler1D(:)=Ts(:)/dt+E(:)                !boundaries to be overwritten later...

! check whether D or N
!> MINX1 BOUNDARY, Dirichlet BCS
ix1=1
M(ll+3,ix1)=1       !main diagonal denoted temperature at this grid point... 1*Ts,i=Tsminx1
M(ll+2,ix1+1)=0     !1st super diagonal
M(ll+1,ix1+2)=0     !2nd super diagonal
backEuler1D(ix1)=Tsminx1

!! if Neumann version, use a 1st order forward...
!ix1=1
!M(ll+3,ix1)=-1/dx1(ix1+1)       !main diagonal denoted temperature at this grid point... 1*Ts,i=Tsminx1
!M(ll+2,ix1+1)=1/dx1(ix1+1)      !1st super diagonal
!M(ll+1,ix1+2)=0                 !2nd super diagonal
!backEuler1D(ix1)=Tsminx1          !here this is not interpreted as temperature, but instead the -heat flux divided by thermal conductivity
!

!> FIRST INTERIOR GRID POINT
ix1=2
M(ll+4,ix1-1)=-C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1) &            !ix1-1, sub-diaginal
           +B(ix1)/(dx1(ix1+1)+dx1(ix1))
M(ll+3,ix1)=1/dt-A(ix1) &                                     !ix1
         +C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1) &
         +C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)
M(ll+2,ix1+1)=-C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1) &        !ix1+1, super-diag.
         -B(ix1)/(dx1(ix1+1)+dx1(ix1))
M(ll+1,ix1+2)=0

!> INTERIOR GRID POINTS
do concurrent (ix1=3:lx1-2)
  M(ll+5,ix1-2) = 0
  !! ix1-2 grid point, sub-diag.
  M(ll+4,ix1-1)=-C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1) &            !ix1-1
             +B(ix1)/(dx1(ix1+1)+dx1(ix1))
  M(ll+3,ix1)=1/dt-A(ix1) &                                     !ix1
           +C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1) &
           +C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)
  M(ll+2,ix1+1)=-C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1) &        !ix1+1, super-diag.
           -B(ix1)/(dx1(ix1+1)+dx1(ix1))
  M(ll+1,ix1+2) = 0
  !! ix1+2 grid point
end do

!> LAST INTERIOR GRID POINT
ix1=lx1-1
M(ll+5,ix1-2)=0
M(ll+4,ix1-1)=-C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1) &            !ix1-1
           +B(ix1)/(dx1(ix1+1)+dx1(ix1))
M(ll+3,ix1)=1/dt-A(ix1) &                                     !ix1
         +C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1) &
         +C(ix1)*Dh(ix1)/dx1i(ix1)/dx1(ix1)
M(ll+2,ix1+1)=-C(ix1)*Dh(ix1+1)/dx1i(ix1)/dx1(ix1+1) &        !ix1+1, super-diag.
         -B(ix1)/(dx1(ix1+1)+dx1(ix1))

! check whether D or N
!> MAXX1 BOUNDARY
ix1=lx1
M(ll+5,ix1-2)=0
M(ll+4,ix1-1)=0
M(ll+3,ix1)=1
backEuler1D(ix1)=Tsmaxx1
!
!!Neumann conditions...
!ix1=lx1
!M(ll+5,ix1-2)=0            !superdiagonal
!M(ll+4,ix1-1)=-1/dx1(ix1)            !subdiagonal
!M(ll+3,ix1)=1/dx1(ix1)              !main diag.
!backEuler1D(ix1)=Tsmaxx1     !here interpreted as -heat flux divided by thermal conductivity...
!

!> in case we want to output the right-hand side of the system; has to be done here before
!   the output argument (which stores rhs) is overwritten by the solution.
if (present(rhs)) then
  rhs(1:lx1)=backEuler1D(1:lx1)
end if

!! ## DO SOME STUFF TO CALL LAPACK'S BANDED SOLVER
!> BANDED SOLVER (INPUT MATRIX MUST BE SHIFTED 'DOWN' BY KL ROWS)
call gbsv(M,backEuler1D,kl=2)

!> this is for if one wants to output the matrix bands for testing purposes
if (present(coeffs)) then
  coeffs(1:lx1,1)=M(ll+2,1:lx1)
  coeffs(1:lx1,2)=M(ll+3,1:lx1)
  coeffs(1:lx1,3)=M(ll+4,1:lx1)
end if

end function backEuler1D

end module PDEparabolic


module hk
    !! A module containing a Fortran implementation of the
    !! Hoshen-Kopelman algorithm, as well as the necessary
    !! union-find procedures.

    implicit none
    contains

        function hoshen_kopelman(matrix) result(num_clusters)
            !! Hoshen-Kopelman algorithm for labelling clusters on
            !! a binary matrix.
            !!
            !! The function takes in a binary matrix
            !! (zeros and positive numbers), labels the clusters of
            !! positive numbers and returns the total number of clusters
            !! found. The argument matrix is overwritten with the labels.
            integer, intent(inout), dimension(:,:) :: matrix
                !! The matrix to be labelled.
            integer :: num_clusters
                !! The total number of disjoint clusters labelled.
            integer :: m, n, i, j, up, left, label
            integer, dimension(:), allocatable :: labels, new_labels

            m = size(matrix, 1)
            n = size(matrix, 2)
            allocate(labels(m*n/2+1))
            labels = 0
            num_clusters = 0

            do j = 1, n
                do i = 1, m
                    if(matrix(i,j) > 0) then
                        if(i == 1) then
                            up = 0
                        else
                            up = matrix(i-1, j)
                        end if
                        if(j == 1) then
                            left = 0
                        else
                            left = matrix(i, j-1)
                        end if

                        ! New cluster
                        if(up==0 .and. left==0) then
                            num_clusters = num_clusters + 1
                            labels(num_clusters) = num_clusters
                            matrix(i,j) = num_clusters

                        ! Site binds clusters
                        else if(up > 0 .and. left > 0) then
                            matrix(i,j) = uf_union(up, left, labels)

                        ! Only one neighbour
                        else
                            matrix(i,j) = max(up, left)
                        end if
                    end if
                end do
            end do

            allocate(new_labels(m*n/2+1))
            new_labels = 0
            num_clusters = 0

            do j = 1, n
                do i = 1, m
                    if(matrix(i,j) > 0) then
                        label = uf_find(matrix(i,j), labels)
                        if(new_labels(label) == 0) then
                            num_clusters = num_clusters + 1
                            new_labels(label) = num_clusters
                        end if
                        matrix(i,j) = new_labels(label)
                    end if
                end do
            end do
        end function

        function uf_find(x, labels) result(y)
            !! Union-Find find algorithm:
            !! Find the lowest corresponding label.
            !! Relabelling is done when necessary.
            integer, intent(in) :: x
                !! Label for which to find the lowest corresponding label.
            integer, dimension(:), intent(inout) :: labels
                !! List of labels. **labels(i)** points to the lowest
                !! corresponding label of label **i**.
            integer :: y, z, tmp

            y = x
            do while(labels(y) /= y)
                y = labels(y)
            end do

            tmp = x
            do while(labels(tmp) /= tmp)
                z = labels(tmp)
                labels(tmp) = y
                tmp = z
            end do
        end function

        function uf_union(x, y, labels) result(canonical_label)
            !! Union-Find union algorithm:
            !! Merge two labels, return the result.
            integer, intent(in) :: x, y
                !! Labels to merge.
            integer, dimension(:), intent(inout) :: labels
                !! List of labels.
            integer :: canonical_label

            canonical_label = uf_find(y,labels)
            labels(uf_find(x,labels)) = canonical_label
        end function
end module hk


      SUBROUTINE KFLUD3
C
C     THIS ROUTINE GENERATES THE PSUEDO STIFFNESS MATRIX TERMS
C     FOR THE TRIANGULAR FLUID ELEMENT
C
C     THE ECPT DATA IS THE FOLLOWING
C
C         FIELD         SYMBOL
C           1             ID
C           2             SIL1
C           3             SIL2
C           4             SIL3
C           5             RHO
C           6             BULK
C           7             N
C           8             CSF
C           9             R1
C           10            Z1
C           11            -
C           12            CSF
C           13            R2
C           14            Z2
C           15            -
C           16            CSF
C           17            R3
C           18            Z3
C           19            -
C           20            -
C
      LOGICAL          NOGO
      INTEGER          OUT      ,NP(3)    ,NECPT(100)
      DOUBLE PRECISION CONSTD   ,DPI      ,
     1                 R        ,R1       ,R2       ,R3       ,
     2                 Z1       ,Z2       ,Z3       ,DETH     ,
     3                 H        ,RA       ,RB       ,ZA       ,
     4                 ZB       ,DR       ,DZ       ,BETA     ,
     5                 BLOG     ,DZR      ,DZR2     ,BET2     ,
     6                 R12      ,R22      ,G00      ,G10      ,
     7                 G20      ,G01      ,G11      ,G02      ,
     8                 RN       ,PIRO     ,PRN2     ,KQ       ,
     9                 KVEC     ,KG
      CHARACTER        UFM*23
      COMMON /XMSSG /  UFM
      COMMON /CONDAD/  CONSTD(5)
      COMMON /SYSTEM/  SYSBUF   ,OUT      ,NOGO
      COMMON /SMA1IO/  DUM1(10) ,IFKGG
      COMMON /SMA1CL/  IOPT4    ,K4GGSW   ,NPVT
      COMMON /SMA1ET/  ECPT(100)
      COMMON /SMA1DP/  R        ,R1       ,R2       ,R3       ,
     1                 Z1       ,Z2       ,Z3       ,DETH     ,
     2                 H(9)     ,RA       ,RB       ,ZA       ,
     3                 ZB       ,DR       ,DZ       ,BETA     ,
     4                 BLOG     ,DZR      ,DZR2     ,BET2     ,
     5                 R12      ,R22      ,G00      ,G10      ,
     6                 G20      ,G01      ,G11      ,G02      ,
     7                 RN       ,PIRO     ,PRN2     ,KQ(9)    ,
     8                 KVEC(3)  ,KG(3)    ,IRET     ,IPT      ,
     9                 JC       ,IR
      EQUIVALENCE      (CONSTD(1),DPI)    ,(ECPT(1),NECPT(1))
C
C     SELECT POINTS FOR COUNTERCLOCKWISE ORDER
C
      NP(1) = NECPT(2)
      NP(2) = NECPT(3)
      NP(3) = NECPT(4)
      R1    = ECPT( 9)
      Z1    = ECPT(10)
      R2    = ECPT(13)
      Z2    = ECPT(14)
      R3    = ECPT(17)
      Z3    = ECPT(18)
      R     = (R2-R1)*(Z3-Z1) - (R3-R1)*(Z2-Z1)
      IF (R) 10,2000,20
   10 NP(2) = NP(3)
      NP(3) = NECPT(3)
      R2    = ECPT(17)
      R3    = ECPT(13)
      Z2    = ECPT(18)
      Z3    = ECPT(14)
   20 IF (R1.LE.0.0D0 .OR. R2.LE.0.0D0 .OR. R3.LE.0.0D0) GO TO 1000
      DETH  = DABS(R)
      H(1)  = (R2*Z3-R3*Z2)/DETH
      H(4)  = (R3*Z1-R1*Z3)/DETH
      H(7)  = (R1*Z2-R2*Z1)/DETH
      H(2)  = (Z2-Z3)/DETH
      H(5)  = (Z3-Z1)/DETH
      H(8)  = (Z1-Z2)/DETH
      H(3)  = (R3-R2)/DETH
      H(6)  = (R1-R3)/DETH
      H(9)  = (R2-R1)/DETH
C
C     THE INTEGRAL PARAMETERS ARE THE SUM DUE TO SIDES 1-2,2-3,3-1.
C
      G00   = 0.0
      G01   = 0.0
      G02   = 0.0
      G10   = 0.0
      G11   = 0.0
      G20   = 0.0
      IRET  = 1
      RA    = R1
      RB    = R2
      ZA    = Z1
      ZB    = Z2
      GO TO 500
  100 IRET  = 2
      RA    = R2
      RB    = R3
      ZA    = Z2
      ZB    = Z3
      GO TO 500
  110 IRET  = 3
      RA    = R3
      RB    = R1
      ZA    = Z3
      ZB    = Z1
C
C     THE INTEGRAL PARAMETERS ARE CALCULATED BELOW
C
  500 DR    = RB - RA
      DZ    = ZB - ZA
      IF (DR**2/DETH .LE. 1.0D-6) GO TO 140
      BETA  = ZA - RA*DZ/DR
      BET2  = BETA**2
      BLOG  = BETA*DLOG(RA/RB)
      DZR   = DZ/DR
      DZR2  = DZR**2
      R12   = (RA**2-RB**2)/2.0D0
      R22   = (RA**3-RB**3)/3.0D0
      G00   = G00 + BLOG - DZ
      G10   = G10 - BETA*DR  + R12*DZR
      G20   = G20 + BETA*R12 + DZR*R22
      G01   = G01 + BLOG*BETA/2.0D0 - BETA*DZ + DZR2*R12/2.0D0
      G11   = G11 - BET2*DR/2.0D0 + BETA*DZR*R12 + DZR2*R22/2.0D0
      G02   = G02 + BET2*BLOG/3.0D0 - BET2*DZ + BETA*DZR2*R12 +
     1        DZR*DZR2*R22/3.0D0
  140 CONTINUE
      GO TO (100,110,120), IRET
  120 CONTINUE
C
C     FORM THE PSUEDO STIFFNESS MATRIX USING THE PARAMETERS
C
      RN    = NECPT(7)
      IF (ECPT(5) .LE. 0.0) RETURN
      PIRO  = DPI/DBLE(ECPT(5))
      IF(NECPT(7) .EQ. 0) PIRO=PIRO*2.0D0
      PRN2  = PIRO*RN**2
      KQ(1) = PRN2*G00
      KQ(2) = PRN2*G10
      KQ(3) = PRN2*G01
      KQ(4) = KQ(2)
      KQ(5) = (PIRO + PRN2)*G20
      KQ(6) = PRN2*G11
      KQ(7) = KQ(3)
      KQ(8) = KQ(6)
      KQ(9) = PIRO*G20 + PRN2*G02
      DO 200 I = 1,3
      IPT   = I - 1
      IF (NPVT .EQ. NP(I)) GO TO 210
  200 CONTINUE
      RETURN
C
  210 IPT   = 3*IPT + 1
      CALL GMMATD (H(IPT),1,3,0,KQ,3,3,0,KVEC)
      CALL GMMATD (KVEC,1,3,0,H(1),3,3,1,KG)
      JC    = NPVT
      DO 220 I = 1,3
      IR    = NP(I)
      CALL SMA1B (KG(I),IR,JC,IFKGG,0.0D0)
  220 CONTINUE
 2000 RETURN
C
 1000 IR    = NECPT(1)/1000
      WRITE  (OUT,5001) UFM,IR
 5001 FORMAT (A23,' 5001, NEG. OR ZERO RADIUS DETECTED FOR CFLUID3 OR',
     1       ' CFLUID4 ELEMENT',I12)
      NOGO = .TRUE.
      RETURN
      END


PROGRAM extremes
!
!  Purpose:
!    To find the largest and smallest values in a data set,
!    and to print out the data set with the largest and smallest
!    values labeled.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/15/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare constants
INTEGER, PARAMETER :: MAX_SIZE = 10    ! Max size of data set

! Data dictionary: declare variable types, definitions, & units
INTEGER, DIMENSION(MAX_SIZE) :: input  ! Input values
INTEGER :: ilarge                      ! Pointer to largest value
INTEGER :: ismall                      ! Pointer to smallest value
INTEGER :: j                           ! DO loop index
INTEGER :: nvals                       ! Number of vals in data set
INTEGER :: temp                        ! Temporary variable

! Get number of values in data set
WRITE (*,*) 'Enter number of values in data set:'
READ (*,*) nvals

! Is the number <= MAX_SIZE?
size: IF ( nvals <= MAX_SIZE ) THEN

   ! Get input values.
   in: DO J = 1, nvals
      WRITE (*,100) 'Enter value ', j
      100 FORMAT (' ',A,I3,': ')
      READ (*,*) input(j)
   END DO in

   ! Find the largest value.
   temp = input(1)
   ilarge = 1
   large: DO j = 2, nvals
      IF ( input(j) > temp ) THEN
        temp = input(j)
        ilarge = j
      END IF
   END DO large

   ! Find the smallest value.
   temp = input(1)
   ismall = 1
   small: DO j = 2, nvals
      IF ( input(j) < temp ) THEN
        temp = input(j)
        ismall = j
      END IF
   END DO small

   ! Write out list.
   WRITE (*,110)
   110 FORMAT ('0','The values are:')
   out: DO j = 1, nvals
      IF ( j == ilarge ) THEN
         WRITE (*,'(1X,I6,2X,A)') input(j), 'LARGEST'
      ELSE IF ( J == ismall ) THEN
         WRITE (*,'(1X,I6,2X,A)') input(j), 'SMALLEST'
      ELSE
         WRITE (*,'(1X,I6)') input(j)
      END IF
   END DO out

ELSE size

   ! nvals > max_size.  Tell user and quit.
   WRITE (*,120) nvals, MAX_SIZE
   120 FORMAT (1X,'Too many input values: ', I6, ' > ', I6)

END IF size

END PROGRAM extremes


Program CalcPresion

  Implicit None
  Real, Parameter :: Pi=4.0*atan(1.0)
  Real, Parameter :: lamda = 1.25
  Real :: Dens
  Real, allocatable, Dimension(:) :: r, gdr
  Real :: g1, glmin, glplu
  Real :: P
  Integer :: Den, State
  Integer :: i ,j, k
  Character (len=11) :: Filename, Cons

  Open(15, file="Presion.dat")

  CONC: Do Den=1 , 10

     Write(Cons,256) Den
     Filename = "gdr"//trim(Cons)//".dat"
     Write(*,*) "Archivo: ",Filename
     Dens = Den * 0.1

     Open(3, file=filename)
     i=0
     ReadSize: Do

        Read(3,*, iostat=state)
        If ( state .LT. 0 ) Exit
        i=i+1

     End Do ReadSize
     !Write(*,*) i

     Rewind(3)

     Allocate( r(i), gdr(i) )

     Save: Do j=1, i

        Read(3,*) r(j) , gdr(j)
        !If ( state .LT. 0 ) Exit

     End Do Save

     FindG1 : Do j = 1 ,i
        k = j
        If( r(j) .GE. 1.0)  Exit

     End Do FindG1
     g1 = gdr(k)

     FindGl : Do j = 1 ,i
        k = j
        If( r(j) .GE. lamda  )  Exit

     End Do FindGl
     glmin = gdr(k-1)
     glplu = gdr(k)

     !Write(*,*) g1 , glmin, glplu

     P = dens + (2*Pi/3)*dens*dens * ( g1 + lamda*lamda*lamda*( glplu - glmin )  )
     Write(15,*) dens,P

     Close(3)

     Deallocate(r,gdr)

  End Do CONC

256 Format (I2.2)
End Program CalcPresion


!Program to use MPI_Scan to calculate the scan (partial reduction)
!This calculates the sum of all ranks <= the current rank
!So the results should be
!0 => 0
!1 => 0 + 1 = 1
!2 => 0 + 1 + 2 = 3
!3 => 0 + 1 + 2 + 3 = 6
!etc.
PROGRAM scan

  USE mpi
  IMPLICIT NONE

  INTEGER, PARAMETER :: tag = 100

  INTEGER :: rank, recv
  INTEGER :: nproc, ierr

  CALL MPI_Init(ierr)

  CALL MPI_Comm_size(MPI_COMM_WORLD, nproc, ierr)
  CALL MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr)

  CALL MPI_Scan(rank, recv, 1, MPI_INTEGER, MPI_SUM, MPI_COMM_WORLD, ierr)
  PRINT "(A,I3,A,I3)","The sum of all ranks up to current on rank ", &
      rank, " is ", recv

  CALL MPI_Finalize(ierr)

END PROGRAM scan


      COMPLEX FUNCTION CLARND( IDIST, ISEED )
*
*  -- LAPACK auxiliary routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            IDIST
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
*     ..
*
*  Purpose
*  =======
*
*  CLARND returns a random complex number from a uniform or normal
*  distribution.
*
*  Arguments
*  =========
*
*  IDIST   (input) INTEGER
*          Specifies the distribution of the random numbers:
*          = 1:  real and imaginary parts each uniform (0,1)
*          = 2:  real and imaginary parts each uniform (-1,1)
*          = 3:  real and imaginary parts each normal (0,1)
*          = 4:  uniformly distributed on the disc abs(z) <= 1
*          = 5:  uniformly distributed on the circle abs(z) = 1
*
*  ISEED   (input/output) INTEGER array, dimension (4)
*          On entry, the seed of the random number generator; the array
*          elements must be between 0 and 4095, and ISEED(4) must be
*          odd.
*          On exit, the seed is updated.
*
*  Further Details
*  ===============
*
*  This routine calls the auxiliary routine SLARAN to generate a random
*  real number from a uniform (0,1) distribution. The Box-Muller method
*  is used to transform numbers from a uniform to a normal distribution.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TWO
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
      REAL               TWOPI
      PARAMETER          ( TWOPI = 6.2831853071795864769252867663E+0 )
*     ..
*     .. Local Scalars ..
      REAL               T1, T2
*     ..
*     .. External Functions ..
      REAL               SLARAN
      EXTERNAL           SLARAN
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CMPLX, EXP, LOG, SQRT
*     ..
*     .. Executable Statements ..
*
*     Generate a pair of real random numbers from a uniform (0,1)
*     distribution
*
      T1 = SLARAN( ISEED )
      T2 = SLARAN( ISEED )
*
      IF( IDIST.EQ.1 ) THEN
*
*        real and imaginary parts each uniform (0,1)
*
         CLARND = CMPLX( T1, T2 )
      ELSE IF( IDIST.EQ.2 ) THEN
*
*        real and imaginary parts each uniform (-1,1)
*
         CLARND = CMPLX( TWO*T1-ONE, TWO*T2-ONE )
      ELSE IF( IDIST.EQ.3 ) THEN
*
*        real and imaginary parts each normal (0,1)
*
         CLARND = SQRT( -TWO*LOG( T1 ) )*EXP( CMPLX( ZERO, TWOPI*T2 ) )
      ELSE IF( IDIST.EQ.4 ) THEN
*
*        uniform distribution on the unit disc abs(z) <= 1
*
         CLARND = SQRT( T1 )*EXP( CMPLX( ZERO, TWOPI*T2 ) )
      ELSE IF( IDIST.EQ.5 ) THEN
*
*        uniform distribution on the unit circle abs(z) = 1
*
         CLARND = EXP( CMPLX( ZERO, TWOPI*T2 ) )
      END IF
      RETURN
*
*     End of CLARND
*
      END


C$Procedure      GEOREC ( Geodetic to rectangular coordinates )

      SUBROUTINE GEOREC ( LONG, LAT, ALT,  RE, F,  RECTAN )

C$ Abstract
C
C     Convert geodetic coordinates to rectangular coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONVERSION,  COORDINATES
C
C$ Declarations

      DOUBLE PRECISION   LONG
      DOUBLE PRECISION   LAT
      DOUBLE PRECISION   ALT
      DOUBLE PRECISION   RE
      DOUBLE PRECISION   F
      DOUBLE PRECISION   RECTAN ( 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     LONG       I   Geodetic longitude of point (radians).
C     LAT        I   Geodetic latitude  of point (radians).
C     ALT        I   Altitude of point above the reference spheroid.
C     RE         I   Equatorial radius of the reference spheroid.
C     F          I   Flattening coefficient.
C     RECTAN     O   Rectangular coordinates of point.
C
C$ Detailed_Input
C
C     LONG       Geodetic longitude of the input point.  This is the
C                angle between the prime meridian and the meridian
C                containing RECTAN.  The direction of increasing
C                longitude is from the +X axis towards the +Y axis.
C
C                Longitude is measured in radians.  On input, the
C                range of longitude is unrestricted.
C
C     LAT        Geodetic latitude of the input point.  For a point P
C                on the reference spheroid, this is the angle between
C                the XY plane and the outward normal vector at P.
C                For a point P not on the reference spheroid, the
C                geodetic latitude is that of the closest point to P on
C                the spheroid.
C
C                Latitude is measured in radians.  On input, the
C                range of latitude is unrestricted.
C
C     ALT        Altitude of point above the reference spheroid.
C                ALT must be in the same units as RE.
C
C     RE         Equatorial radius of a reference spheroid.  This
C                spheroid is a volume of revolution:  its horizontal
C                cross sections are circular.  The shape of the
C                spheroid is defined by an equatorial radius RE and
C                a polar radius RP. RE must be in the same units
C                as ALT.
C
C     F          Flattening coefficient = (RE-RP) / RE,  where RP is
C                the polar radius of the spheroid.
C
C$ Detailed_Output
C
C     RECTAN     The rectangular coordinates of a point.
C
C                The units associated with RECTAN are those associated
C                with the inputs ALT and RE.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If the flattening coefficient is greater than or equal to
C        one, the error SPICE(VALUEOUTOFRANGE) is signaled.
C
C     2) If the equatorial radius is less than or equal to zero,
C        the error SPICE(VALUEOUTOFRANGE) is signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Given the geodetic coordinates of a point, and the constants
C     describing the reference spheroid,  this routine returns the
C     bodyfixed rectangular coordinates of the point.  The bodyfixed
C     rectangular frame is that having the x-axis pass through the
C     0 degree latitude 0 degree longitude point.  The y-axis passes
C     through the 0 degree latitude 90 degree longitude.  The z-axis
C     passes through the 90 degree latitude point.  For some bodies
C     this coordinate system may not be a right-handed coordinate
C     system.
C
C$ Examples
C
C     This routine can be used to convert body fixed geodetic
C     coordinates (such as the used for United States Geological
C     Survey topographic maps) to bodyfixed rectangular coordinates
C     such as the Satellite Tracking and Data Network of 1973.
C
C     The code would look something like this
C
C        C
C        C     Using the equatorial radius of the Clark66 spheroid
C        C     (CLARKR = 6378.2064 km) and the Clark 66 flattening
C        C     factor (CLARKF = 1.0D0 / 294.9787D0 ) convert to
C        C     body fixed rectangular coordinates.
C        C
C              CALL GEOREC ( LONG, LAT, ALT, CLARKR, CLARKF, X )
C
C        C
C        C     Add the North American Datum of 1927 to STDN 73 center
C        C     offset
C        C
C              CALL VADD   ( X, OFFSET, STDNX )
C
C
C     Below are two tables.
C
C     Listed in the first table (under LONG, LAT, and ALT ) are
C     geodetic coordinate triples that approximately represent points
C     whose rectangular coordinates are taken from the set {-1, 0, 1}.
C     (Angular quantities are given in degrees.)
C
C     The result of the code fragment
C
C        C
C        C     Use the SPICELIB routine CONVRT to convert the angular
C        C     quantities to degrees.
C        C
C              CALL CONVRT ( LAT,  'DEGREES', 'RADIANS', LAT  )
C              CALL CONVRT ( LONG, 'DEGREES', 'RADIANS', LONG )
C
C              CALL GEOREC ( LONG, LAT, ALT, CLARKR, CLARKF, X )
C
C
C     are listed in the second parallel table under X(1), X(2) and X(3).
C
C
C       LONG      LAT        ALT            X(1)       X(2)     X(3)
C       ------------------------------      --------------------------
C       0.0000    90.0000   -6356.5838      0.0000     0.0000   0.0000
C       0.0000     0.0000   -6377.2063      1.0000     0.0000   0.0000
C      90.0000     0.0000   -6377.2063      0.0000     1.0000   0.0000
C       0.0000    90.0000   -6355.5838      0.0000     0.0000   1.0000
C     180.0000     0.0000   -6377.2063     -1.0000     0.0000   0.0000
C     -90.0000     0.0000   -6377.2063      0.0000    -1.0000   0.0000
C       0.0000   -90.0000   -6355.5838      0.0000     0.0000  -1.0000
C      45.0000     0.0000   -6376.7921      1.0000     1.0000   0.0000
C       0.0000    88.7070   -6355.5725      1.0000     0.0000   1.0000
C      90.0000    88.7070   -6355.5725      0.0000     1.0000   1.0000
C      45.0000    88.1713   -6355.5612      1.0000     1.0000   1.0000
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     See FUNDAMENTALS OF ASTRODYNAMICS, Bate, Mueller, White
C     published by Dover for a description of geodetic coordinates.
C
C$ Author_and_Institution
C
C     C.H. Acton      (JPL)
C     N.J. Bachman    (JPL)
C     H.A. Neilan     (JPL)
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.3, 26-JUL-2016 (BVS)
C
C        Minor headers edits.
C
C-    SPICELIB Version 1.0.2, 29-JUL-2003 (NJB) (CHA)
C
C        Various header changes were made to improve clarity.  Some
C        minor header corrections were made.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     geodetic to rectangular coordinates
C
C-&

C$ Revisions
C
C-    Beta Version 3.0.0, 9-JUN-1989  (HAN)
C
C        Error handling added to detect equatorial radius out of
C        range. If the equatorial radius is less than or equal to
C        zero, an error is signaled.
C
C-    Beta Version 2.0.0, 21-DEC-1988 (HAN)
C
C        Error handling to detect invalid flattening coefficients
C        was added. Because the flattening coefficient is used to
C        compute the polar radius, it must be checked so that the
C        polar radius greater than zero.
C
C-&

C
C     SPICELIB functions
C
      LOGICAL          RETURN

C
C     Local variables
C
      DOUBLE PRECISION HEIGHT

      DOUBLE PRECISION RP
      DOUBLE PRECISION CLMBDA
      DOUBLE PRECISION SLMBDA
      DOUBLE PRECISION CPHI
      DOUBLE PRECISION SPHI
      DOUBLE PRECISION BIG
      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION SCALE

      DOUBLE PRECISION BASE   (3)
      DOUBLE PRECISION NORMAL (3)

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'GEOREC' )
      END IF

C
C     The equatorial radius must be greater than zero.
C
      IF ( RE .LE. 0.0D0 ) THEN
          CALL SETMSG ( 'Equatorial radius was *.' )
          CALL ERRDP  ( '*', RE                    )
          CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'   )
          CALL CHKOUT ( 'GEOREC'                   )
          RETURN
      END IF

C
C     If the flattening coefficient is greater than one, the polar
C     radius computed below is negative. If it's equal to one, the
C     polar radius is zero. Either case is a problem, so signal an
C     error and check out.
C
      IF ( F .GE. 1 ) THEN
          CALL SETMSG ( 'Flattening coefficient was *.'  )
          CALL ERRDP  ( '*', F                           )
          CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'         )
          CALL CHKOUT ( 'GEOREC'                         )
          RETURN
      END IF

C
C     Move the altitude to a temporary variable.
C
      HEIGHT = ALT

C
C     Compute the polar radius of the spheroid.
C
      RP     = RE - (F * RE)

C
C     Compute a scale factor needed for finding the rectangular
C     coordinates of a point with altitude 0 but the same geodetic
C     latitude and longitude as the input point.
C
      CPHI   = DCOS(LAT)
      SPHI   = DSIN(LAT)
      CLMBDA = DCOS(LONG)
      SLMBDA = DSIN(LONG)

      BIG    = MAX ( DABS(RE*CPHI), DABS(RP*SPHI) )

      X      = RE*CPHI / BIG
      Y      = RP*SPHI / BIG

      SCALE  = 1.0D0   / (BIG * DSQRT(X*X + Y*Y) )

C
C     Compute the rectangular coordinates of the point with zero
C     altitude.
C
      BASE(1) = SCALE * RE * RE * CLMBDA * CPHI
      BASE(2) = SCALE * RE * RE * SLMBDA * CPHI
      BASE(3) = SCALE * RP * RP * SPHI

C
C     Fetch the normal to the ellipsoid at this point.
C
      CALL SURFNM ( RE, RE, RP, BASE, NORMAL )

C
C     Move along the normal to the input point.
C
      CALL VLCOM ( 1.0D0, BASE, HEIGHT, NORMAL, RECTAN )

      CALL CHKOUT ( 'GEOREC' )
      RETURN
      END