diff --git a/src/MNH/rain_ice.f90 b/src/MNH/rain_ice.f90
index fd649b6c89b7404e06d4c03263ac0e7954a91e7c..9d11bd3ee900c037915978e883f7732a8fc8e407 100644
--- a/src/MNH/rain_ice.f90
+++ b/src/MNH/rain_ice.f90
@@ -61,21 +61,20 @@ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRSS ! Snow/aggregate m.r. source
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRGS ! Graupel m.r. source
-
!
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRC! Cloud instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINDEP ! Cloud instant deposition
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRR! Rain instant precip
-REAL, DIMENSION(:,:,:),INTENT(OUT) :: PINPRR3D! Rain inst precip 3D
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PEVAP3D! Rain evap profile
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRS! Snow instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRG! Graupel instant precip
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRAINFR! Rain fraction
-REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PSEA ! Sea Mask
-REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PTOWN! Fraction that is town
-REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(IN) :: PRHT ! Hail m.r. at t
-REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(INOUT) :: PRHS ! Hail m.r. source
-REAL, DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: PINPRH! Hail instant precip
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRC! Cloud instant precip
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINDEP ! Cloud instant deposition
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRR! Rain instant precip
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PINPRR3D! Rain inst precip 3D
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PEVAP3D! Rain evap profile
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRS! Snow instant precip
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRG! Graupel instant precip
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRAINFR! Rain fraction
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PSEA ! Sea Mask
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PTOWN! Fraction that is town
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(IN) :: PRHT ! Hail m.r. at t
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(INOUT) :: PRHS ! Hail m.r. source
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: PINPRH! Hail instant precip
REAL, DIMENSION(:,:,:,:), OPTIONAL, INTENT(OUT) :: PFPR ! upper-air precipitation fluxes
!
END SUBROUTINE RAIN_ICE
@@ -241,28 +240,40 @@ END MODULE MODI_RAIN_ICE
!! J.Escobar : 8/2018 : for real*4 , bis => limit exp() in RAIN_ICE_SLOW with XMNH_HUGE_12_LOG
!! P.Wautelet 01/02/2019: add missing initialization for PFPR
!! 02/2019 C.Lac add rain fraction as an output field
+! P. Wautelet 25/02/2019: split rain_ice (cleaner and easier to maintain/debug)
! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg
!
!* 0. DECLARATIONS
! ------------
!
-USE MODD_PARAMETERS
-USE MODD_CST
-USE MODD_CONF
-USE MODD_RAIN_ICE_DESCR
-USE MODD_RAIN_ICE_PARAM
-USE MODD_PARAM_ICE
-USE MODD_BUDGET
-USE MODD_LES
-USE MODI_BUDGET
-USE MODI_GAMMA
-USE MODE_ll
-USE MODE_MSG
+use MODD_BUDGET, only: LBU_ENABLE, LBUDGET_RC, LBUDGET_RG, LBUDGET_RH, LBUDGET_RI, &
+ LBUDGET_RR, LBUDGET_RS, LBUDGET_RV, LBUDGET_TH
+use MODD_CST, only: XCI, XCL, XCPD, XCPV, XLSTT, XLVTT, XTT
+use MODD_CST, only: XALPI, XBETAI, XGAMI, XMD, XMV, XTT
+use MODD_LES, only: LLES_CALL
+use MODD_PARAMETERS, only: JPVEXT
+use MODD_PARAM_ICE, only: CSUBG_PR_PDF, LDEPOSC
+use MODD_RAIN_ICE_DESCR, only: XLBEXR, XLBR, XRTMIN
+use MODD_RAIN_ICE_PARAM, only: XCRIAUTC
+!
+use MODE_MSG
+use MODE_RAIN_ICE_FAST_RG, only: RAIN_ICE_FAST_RG
+use MODE_RAIN_ICE_FAST_RH, only: RAIN_ICE_FAST_RH
+use MODE_RAIN_ICE_FAST_RI, only: RAIN_ICE_FAST_RI
+use MODE_RAIN_ICE_FAST_RS, only: RAIN_ICE_FAST_RS
+use MODE_RAIN_ICE_NUCLEATION, only: RAIN_ICE_NUCLEATION
+use MODE_RAIN_ICE_SEDIMENTATION_SPLIT, only: RAIN_ICE_SEDIMENTATION_SPLIT
+use MODE_RAIN_ICE_SEDIMENTATION_STAT, only: RAIN_ICE_SEDIMENTATION_STAT
+use MODE_RAIN_ICE_SLOW, only: RAIN_ICE_SLOW
+use MODE_RAIN_ICE_WARM, only: RAIN_ICE_WARM
!
#ifdef MNH_PGI
USE MODE_PACK_PGI
#endif
!
+use MODI_BUDGET
+USE MODI_ICE4_RAINFR_VERT
+!
IMPLICIT NONE
!
!* 0.1 Declarations of dummy arguments :
@@ -271,7 +282,7 @@ IMPLICIT NONE
!
LOGICAL, INTENT(IN) :: OSEDIC ! Switch for droplet sedim.
CHARACTER(LEN=4), INTENT(IN) :: HSEDIM ! Sedimentation scheme
-CHARACTER(LEN=4), INTENT(IN) :: HSUBG_AUCV
+CHARACTER(LEN=4), INTENT(IN) :: HSUBG_AUCV ! Switch for rc->rr Subgrid autoconversion
! Kind of Subgrid autoconversion method
LOGICAL, INTENT(IN) :: OWARM ! .TRUE. allows raindrops to
! form by warm processes
@@ -286,14 +297,14 @@ REAL, INTENT(IN) :: PTSTEP ! Double Time step
! (single if cold start)
INTEGER, INTENT(IN) :: KRR ! Number of moist variable
!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Layer thikness (m)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Layer thikness (m)
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! absolute pressure at t
!
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIT ! Pristine ice n.c. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCLDFR! Convective Mass Flux Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PCLDFR ! Cloud fraction
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
@@ -302,6 +313,7 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Pristine ice m.r. at t
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGT ! Graupel/hail m.r. at t
+!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PSIGS ! Sigma_s at t
!
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
@@ -312,165 +324,101 @@ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRSS ! Snow/aggregate m.r. source
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRGS ! Graupel m.r. source
!
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRC! Cloud instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINDEP ! Cloud instant deposition
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRR! Rain instant precip
-REAL, DIMENSION(:,:,:),INTENT(OUT) :: PINPRR3D! Rain inst precip 3D
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PEVAP3D! Rain evap profile
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRS! Snow instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRG! Graupel instant precip
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRAINFR! Rain fraction
-REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PSEA ! Sea Mask
-REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PTOWN! Fraction that is town
-REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(IN) :: PRHT ! Hail m.r. at t
-REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(INOUT) :: PRHS ! Hail m.r. source
-REAL, DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: PINPRH! Hail instant precip
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRC! Cloud instant precip
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINDEP ! Cloud instant deposition
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRR! Rain instant precip
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PINPRR3D! Rain inst precip 3D
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PEVAP3D! Rain evap profile
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRS! Snow instant precip
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRG! Graupel instant precip
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PRAINFR! Rain fraction
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PSEA ! Sea Mask
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PTOWN! Fraction that is town
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(IN) :: PRHT ! Hail m.r. at t
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(INOUT) :: PRHS ! Hail m.r. source
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: PINPRH! Hail instant precip
REAL, DIMENSION(:,:,:,:), OPTIONAL, INTENT(OUT) :: PFPR ! upper-air precipitation fluxes
!
!* 0.2 Declarations of local variables :
!
-INTEGER :: JK ! Vertical loop index for the rain sedimentation
-INTEGER :: JN ! Temporal loop index for the rain sedimentation
-INTEGER :: JJ ! Loop index for the interpolation
-INTEGER :: JI ! Loop index for the interpolation
-INTEGER :: IIB ! Define the domain where is
-INTEGER :: IIE ! the microphysical sources have to be computed
-INTEGER :: IJB !
-INTEGER :: IJE !
-INTEGER :: IKB,IKTB,IKT !
-INTEGER :: IKE,IKTE !
-!
-REAL :: ZTSPLITR ! Small time step for rain sedimentation
-!
-!
-INTEGER :: ISEDIMR,ISEDIMC, ISEDIMI, ISEDIMS, ISEDIMG, ISEDIMH, &
- INEGT, IMICRO ! Case number of sedimentation, T>0 (for HEN)
- ! and r_x>0 locations
-INTEGER :: IGRIM, IGACC, IGDRY ! Case number of riming, accretion and dry growth
- ! locations
-INTEGER :: IGWET, IHAIL ! wet growth locations and case number
-LOGICAL, DIMENSION(SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) &
- :: GSEDIMR,GSEDIMC, GSEDIMI, GSEDIMS, GSEDIMG, GSEDIMH ! Test where to compute the SED processes
-LOGICAL, DIMENSION(SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) &
- :: GNEGT ! Test where to compute the HEN process
+INTEGER :: IIB ! Define the domain where is
+INTEGER :: IIE ! the microphysical sources have to be computed
+INTEGER :: IIT !
+INTEGER :: IJB !
+INTEGER :: IJE !
+INTEGER :: IJT !
+INTEGER :: IKB,IKTB,IKT !
+INTEGER :: IKE,IKTE !
+!
+INTEGER :: IMICRO
+INTEGER, DIMENSION(SIZE(PEXNREF)) :: I1,I2,I3 ! Used to replace the COUNT
+INTEGER :: JL ! and PACK intrinsics
LOGICAL, DIMENSION(SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) &
- :: GMICRO ! Test where to compute all processes
-LOGICAL, DIMENSION(:), ALLOCATABLE :: GRIM ! Test where to compute riming
-LOGICAL, DIMENSION(:), ALLOCATABLE :: GACC ! Test where to compute accretion
-LOGICAL, DIMENSION(:), ALLOCATABLE :: GDRY ! Test where to compute dry growth
-LOGICAL, DIMENSION(:), ALLOCATABLE :: GWET ! Test where to compute wet growth
-LOGICAL, DIMENSION(:), ALLOCATABLE :: GHAIL ! Test where to compute hail growth
-LOGICAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2)):: GDEP
-INTEGER, DIMENSION(:), ALLOCATABLE :: IVEC1,IVEC2 ! Vectors of indices for
- ! interpolations
-REAL, DIMENSION(:), ALLOCATABLE :: ZVEC1,ZVEC2,ZVEC3 ! Work vectors for
- ! interpolations
-REAL, DIMENSION(SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) &
+ :: GMICRO ! Test where to compute all processes
+REAL :: ZINVTSTEP
+REAL :: ZCOEFFRCM
+REAL, DIMENSION(:), ALLOCATABLE :: ZRVT ! Water vapor m.r. at t
+REAL, DIMENSION(:), ALLOCATABLE :: ZRCT ! Cloud water m.r. at t
+REAL, DIMENSION(:), ALLOCATABLE :: ZRRT ! Rain water m.r. at t
+REAL, DIMENSION(:), ALLOCATABLE :: ZRIT ! Pristine ice m.r. at t
+REAL, DIMENSION(:), ALLOCATABLE :: ZRST ! Snow/aggregate m.r. at t
+REAL, DIMENSION(:), ALLOCATABLE :: ZRGT ! Graupel m.r. at t
+REAL, DIMENSION(:), ALLOCATABLE :: ZRHT ! Hail m.r. at t
+REAL, DIMENSION(:), ALLOCATABLE :: ZCIT ! Pristine ice conc. at t
+!
+REAL, DIMENSION(:), ALLOCATABLE :: ZRVS ! Water vapor m.r. source
+REAL, DIMENSION(:), ALLOCATABLE :: ZRCS ! Cloud water m.r. source
+REAL, DIMENSION(:), ALLOCATABLE :: ZRRS ! Rain water m.r. source
+REAL, DIMENSION(:), ALLOCATABLE :: ZRIS ! Pristine ice m.r. source
+REAL, DIMENSION(:), ALLOCATABLE :: ZRSS ! Snow/aggregate m.r. source
+REAL, DIMENSION(:), ALLOCATABLE :: ZRGS ! Graupel m.r. source
+REAL, DIMENSION(:), ALLOCATABLE :: ZRHS ! Hail m.r. source
+REAL, DIMENSION(:), ALLOCATABLE :: ZTHS ! Theta source
+REAL, DIMENSION(:), ALLOCATABLE :: ZTHT ! Potential temperature
+REAL, DIMENSION(:), ALLOCATABLE :: ZTHLT ! Liquid potential temperature
+!
+REAL, DIMENSION(:), ALLOCATABLE :: ZRHODREF, & ! RHO Dry REFerence
+ ZRHODJ, & ! RHO times Jacobian
+ ZZT, & ! Temperature
+ ZPRES, & ! Pressure
+ ZEXNREF, & ! EXNer Pressure REFerence
+ ZZW, & ! Work array
+ ZLSFACT, & ! L_s/(Pi_ref*C_ph)
+ ZLVFACT, & ! L_v/(Pi_ref*C_ph)
+ ZUSW, & ! Undersaturation over water
+ ZSSI, & ! Supersaturation over ice
+ ZLBDAR, & ! Slope parameter of the raindrop distribution
+ ZLBDAR_RF,& ! Slope parameter of the raindrop distribution
+ ! for the Rain Fraction part
+ ZLBDAS, & ! Slope parameter of the aggregate distribution
+ ZLBDAG, & ! Slope parameter of the graupel distribution
+ ZLBDAH, & ! Slope parameter of the hail distribution
+ ZRDRYG, & ! Dry growth rate of the graupeln
+ ZRWETG, & ! Wet growth rate of the graupeln
+ ZAI, & ! Thermodynamical function
+ ZCJ, & ! Function to compute the ventilation coefficient
+ ZKA, & ! Thermal conductivity of the air
+ ZDV, & ! Diffusivity of water vapor in the air
+ ZSIGMA_RC,& ! Standard deviation of rc at time t
+ ZCF, & ! Cloud fraction
+ ZRF, & ! Rain fraction
+ ZHLC_HCF, & ! HLCLOUDS : fraction of High Cloud Fraction in grid
+ ZHLC_LCF, & ! HLCLOUDS : fraction of Low Cloud Fraction in grid
+ ! note that ZCF = ZHLC_HCF + ZHLC_LCF
+ ZHLC_HRC, & ! HLCLOUDS : LWC that is High LWC in grid
+ ZHLC_LRC, & ! HLCLOUDS : LWC that is Low LWC in grid
+ ! note that ZRC = ZHLC_HRC + ZHLC_LRC
+ ZHLC_RCMAX, & ! HLCLOUDS : maximum value for RC in distribution
+ ZRCRAUTC, & ! RC value to begin rain formation =XCRIAUTC/RHODREF
+ ZHLC_HRCLOCAL, & ! HLCLOUDS : LWC that is High LWC local in HCF
+ ZHLC_LRCLOCAL ! HLCLOUDS : LWC that is Low LWC local in LCF
+ ! note that ZRC/CF = ZHLC_HRCLOCAL+ ZHLC_LRCLOCAL
+ ! = ZHLC_HRC/HCF+ ZHLC_LRC/LCF
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZZW1 ! Work arrays
+REAL, DIMENSION(SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) &
:: ZW ! work array
-REAL, DIMENSION(SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) &
- :: ZPRCS,ZPRRS,ZPRSS,ZPRGS,ZPRHS ! Mixing ratios created during the time step
-REAL, DIMENSION(SIZE(PEXNREF,1),SIZE(PEXNREF,2),0:SIZE(PEXNREF,3)+1) &
- :: ZWSED ! sedimentation fluxes
-REAL, DIMENSION(SIZE(PEXNREF,1),SIZE(PEXNREF,2),0:SIZE(PEXNREF,3)+1) &
- :: ZWSEDW1 ! sedimentation speed
-REAL, DIMENSION(SIZE(PEXNREF,1),SIZE(PEXNREF,2),0:SIZE(PEXNREF,3)+1) &
- :: ZWSEDW2 ! sedimentation speed
-REAL, DIMENSION(SIZE(PEXNREF,1),SIZE(PEXNREF,2)) &
- :: ZCONC_TMP ! Weighted concentration
-REAL, DIMENSION(SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) &
+REAL, DIMENSION(SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) &
:: ZT ! Temperature
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: &
- ZRAY, & ! Cloud Mean radius
- ZLBC, & ! XLBC weighted by sea fraction
- ZFSEDC
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: ZHLC_HCF3D ! HLCLOUDS cloud fraction in high water content part
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: ZHLC_LCF3D ! HLCLOUDS cloud fraction in low water content part
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: ZHLC_HRC3D ! HLCLOUDS cloud water content in high water content part
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: ZHLC_LRC3D ! HLCLOUDS cloud water content in low water content
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRRT ! Rain water m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRIT ! Pristine ice m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRGT ! Graupel m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRHT ! Hail m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZCIT ! Pristine ice conc. at t
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVS ! Water vapor m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRCS ! Cloud water m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRRS ! Rain water m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRSS ! Snow/aggregate m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRGS ! Graupel m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRHS ! Hail m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZTHS ! Theta source
-REAL, DIMENSION(:), ALLOCATABLE :: ZTHT ! Potential temperature
-REAL, DIMENSION(:), ALLOCATABLE :: ZTHLT ! Liquid potential temperature
-REAL, DIMENSION(:), ALLOCATABLE :: ZCRIAUTI ! Snow-to-ice autoconversion thres.
-!
-REAL, DIMENSION(:), ALLOCATABLE &
- :: ZRHODREF, & ! RHO Dry REFerence
- ZRHODREFC,& ! RHO Dry REFerence
- ZRHODREFR,& ! RHO Dry REFerence
- ZRHODREFI,& ! RHO Dry REFerence
- ZRHODREFS,& ! RHO Dry REFerence
- ZRHODREFG,& ! RHO Dry REFerence
- ZRHODREFH,& ! RHO Dry REFerence
- ZRHODJ, & ! RHO times Jacobian
- ZZT, & ! Temperature
- ZPRES, & ! Pressure
- ZEXNREF, & ! EXNer Pressure REFerence
- ZZW, & ! Work array
- ZZW2, & ! Work array
- ZZW3, & ! Work array
- ZZW4, & ! Work array
- ZLSFACT, & ! L_s/(Pi_ref*C_ph)
- ZLVFACT, & ! L_v/(Pi_ref*C_ph)
- ZUSW, & ! Undersaturation over water
- ZSSI, & ! Supersaturation over ice
- ZLBDAR, & ! Slope parameter of the raindrop distribution
- ZLBDAR_RF,& ! Slope parameter of the raindrop distribution
- ! for the Rain Fraction part
- ZLBDAS, & ! Slope parameter of the aggregate distribution
- ZLBDAG, & ! Slope parameter of the graupel distribution
- ZLBDAH, & ! Slope parameter of the hail distribution
- ZRDRYG, & ! Dry growth rate of the graupeln
- ZRWETG, & ! Wet growth rate of the graupeln
- ZAI, & ! Thermodynamical function
- ZCJ, & ! Function to compute the ventilation coefficient
- ZKA, & ! Thermal conductivity of the air
- ZDV, & ! Diffusivity of water vapor in the air
- ZSIGMA_RC,& ! Standard deviation of rc at time t
- ZCF, & ! Cloud fraction
- ZRF, & ! Rain fraction
- ZHLC_HCF, & ! HLCLOUDS : fraction of High Cloud Fraction in grid
- ZHLC_LCF, & ! HLCLOUDS : fraction of Low Cloud Fraction in grid
- ! note that ZCF = ZHLC_HCF + ZHLC_LCF
- ZHLC_HRC, & ! HLCLOUDS : LWC that is High LWC in grid
- ZHLC_LRC, & ! HLCLOUDS : LWC that is Low LWC in grid
- ! note that ZRC = ZHLC_HRC + ZHLC_LRC
- ZHLC_RCMAX, & ! HLCLOUDS : maximum value for RC in distribution
- ZRCRAUTC, & ! RC value to begin rain formation =XCRIAUTC/RHODREF
- ZHLC_HRCLOCAL, & ! HLCLOUDS : LWC that is High LWC local in HCF
- ZHLC_LRCLOCAL, & ! HLCLOUDS : LWC that is Low LWC local in LCF
- ! note that ZRC/CF = ZHLC_HRCLOCAL+ ZHLC_LRCLOCAL
- ! = ZHLC_HRC/HCF+ ZHLC_LRC/LCF
- ZCC, & ! terminal velocity
- ZFSEDC1D, & ! For cloud sedimentation
- ZWLBDC, & ! Slope parameter of the droplet distribution
- ZCONC, & ! Concentration des aerosols
- ZRAY1D, & ! Mean radius
- ZWLBDA ! Libre parcours moyen
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZZW1 ! Work arrays
-REAL :: ZTIMAUTIC,XDUMMY6,XDUMMY7
-REAL :: ZINVTSTEP
-REAL, DIMENSION(SIZE(XRTMIN)) :: ZRTMIN
-! XRTMIN = Minimum value for the mixing ratio
-! ZRTMIN = Minimum value for the source (tendency)
-!
-INTEGER , DIMENSION(SIZE(GMICRO)) :: I1,I2,I3 ! Used to replace the COUNT
-INTEGER :: JL ! and PACK intrinsics
-REAL :: ZCOEFFRCM
!
!-------------------------------------------------------------------------------
!
@@ -478,6 +426,8 @@ REAL :: ZCOEFFRCM
! -----------------------
!
CALL GET_INDICE_ll (IIB,IJB,IIE,IJE)
+IIT=SIZE(PDZZ,1)
+IJT=SIZE(PDZZ,2)
IKB=KKA+JPVEXT*KKL
IKE=KKU-JPVEXT*KKL
IKT=SIZE(PDZZ,3)
@@ -491,7 +441,9 @@ ZINVTSTEP=1./PTSTEP
!* 2. COMPUTES THE SLOW COLD PROCESS SOURCES
! --------------------------------------
!
-CALL RAIN_ICE_NUCLEATION
+CALL RAIN_ICE_NUCLEATION(IIB, IIE, IJB, IJE, IKTB, IKTE,KRR,PTSTEP,&
+ PTHT,PPABST,PRHODJ,PRHODREF,PRVT,PRCT,PRRT,PRIT,PRST,PRGT,&
+ PCIT,PEXNREF,PTHS,PRVS,PRIS,ZT,PRHT)
!
!
! optimization by looking for locations where
@@ -524,7 +476,11 @@ IF( IMICRO >= 0 ) THEN
ALLOCATE(ZRIT(IMICRO))
ALLOCATE(ZRST(IMICRO))
ALLOCATE(ZRGT(IMICRO))
- IF ( KRR == 7 ) ALLOCATE(ZRHT(IMICRO))
+ IF ( KRR == 7 ) THEN
+ ALLOCATE(ZRHT(IMICRO))
+ ELSE
+ ALLOCATE(ZRHT(0))
+ END IF
ALLOCATE(ZCIT(IMICRO))
ALLOCATE(ZRVS(IMICRO))
ALLOCATE(ZRCS(IMICRO))
@@ -532,7 +488,11 @@ IF( IMICRO >= 0 ) THEN
ALLOCATE(ZRIS(IMICRO))
ALLOCATE(ZRSS(IMICRO))
ALLOCATE(ZRGS(IMICRO))
- IF ( KRR == 7 ) ALLOCATE(ZRHS(IMICRO))
+ IF ( KRR == 7 ) THEN
+ ALLOCATE(ZRHS(IMICRO))
+ ELSE
+ ALLOCATE(ZRHS(0))
+ END IF
ALLOCATE(ZTHS(IMICRO))
ALLOCATE(ZTHT(IMICRO))
ALLOCATE(ZTHLT(IMICRO))
@@ -583,9 +543,6 @@ IF( IMICRO >= 0 ) THEN
ZEXNREF(JL) = PEXNREF(I1(JL),I2(JL),I3(JL))
ENDDO
ALLOCATE(ZZW(IMICRO))
- ALLOCATE(ZZW2(IMICRO))
- ALLOCATE(ZZW3(IMICRO))
- ALLOCATE(ZZW4(IMICRO))
ALLOCATE(ZLSFACT(IMICRO))
ALLOCATE(ZLVFACT(IMICRO))
ZZW(:) = ZEXNREF(:)*( XCPD+XCPV*ZRVT(:)+XCL*(ZRCT(:)+ZRRT(:)) &
@@ -602,7 +559,11 @@ IF( IMICRO >= 0 ) THEN
ALLOCATE(ZLBDAR_RF(IMICRO))
ALLOCATE(ZLBDAS(IMICRO))
ALLOCATE(ZLBDAG(IMICRO))
- IF ( KRR == 7 ) ALLOCATE(ZLBDAH(IMICRO))
+ IF ( KRR == 7 ) THEN
+ ALLOCATE(ZLBDAH(IMICRO))
+ ELSE
+ ALLOCATE(ZLBDAH(0))
+ END IF
ALLOCATE(ZRDRYG(IMICRO))
ALLOCATE(ZRWETG(IMICRO))
ALLOCATE(ZAI(IMICRO))
@@ -619,6 +580,8 @@ IF( IMICRO >= 0 ) THEN
IF (LBU_ENABLE .OR. LLES_CALL) THEN
ALLOCATE(ZRHODJ(IMICRO))
ZRHODJ(:) = PACK( PRHODJ(:,:,:),MASK=GMICRO(:,:,:) )
+ ELSE
+ ALLOCATE(ZRHODJ(0))
END IF
!
@@ -811,12 +774,17 @@ IF( IMICRO >= 0 ) THEN
!Diagnostic of precipitation fraction
ZW(:,:,:) = 0.
PRAINFR(:,:,:) = UNPACK( ZRF(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- CALL RAINFR_VERT(PRAINFR(:,:,:), PRRT(:,:,:))
+ CALL ICE4_RAINFR_VERT(IIB, IIE, IIT, IJB, IJE, IJT, IKB, IKE, IKT, KKL, PRAINFR, PRRT(:,:,:))
DO JL=1,IMICRO
ZRF(JL)=PRAINFR(I1(JL),I2(JL),I3(JL))
END DO
!
- CALL RAIN_ICE_SLOW
+ CALL RAIN_ICE_SLOW(GMICRO, ZINVTSTEP, ZRHODREF, &
+ ZRCT, ZRRT, ZRIT, ZRST, ZRGT, ZRHODJ, ZZT, ZPRES, &
+ ZLSFACT, ZLVFACT, &
+ ZSSI, PRHODJ, PTHS, PRVS, &
+ ZRVS, ZRCS, ZRRS, ZRIS, ZRSS, ZRGS, ZTHS, &
+ ZAI, ZCJ, ZKA, ZDV, ZLBDAS, ZLBDAG)
!
!-------------------------------------------------------------------------------
!
@@ -840,7 +808,9 @@ IF( IMICRO >= 0 ) THEN
IF( OWARM ) THEN ! Check if the formation of the raindrops by the slow
! warm processes is allowed
PEVAP3D(:,:,:)= 0.
- CALL RAIN_ICE_WARM
+ CALL RAIN_ICE_WARM(GMICRO, ZRHODREF, ZRVT, ZRCT, ZRRT, ZHLC_HCF, ZHLC_LCF, ZHLC_HRC, ZHLC_LRC, &
+ ZRHODJ, ZPRES, ZZT, ZLBDAR, ZLBDAR_RF, ZLVFACT, ZCJ, ZKA, ZDV, ZRF, ZCF, ZTHT, ZTHLT, &
+ PRHODJ, PTHS, PRVS, ZRVS, ZRCS, ZRRS, ZTHS, ZUSW, PEVAP3D)
END IF
!
!-------------------------------------------------------------------------------
@@ -849,7 +819,9 @@ IF( IMICRO >= 0 ) THEN
!* 4. COMPUTES THE FAST COLD PROCESS SOURCES FOR r_s
! ----------------------------------------------
!
- CALL RAIN_ICE_FAST_RS
+ CALL RAIN_ICE_FAST_RS(PTSTEP, GMICRO, ZRHODREF, ZRVT, ZRCT, ZRRT, ZRST, ZRHODJ, ZPRES, ZZT, &
+ ZLBDAR, ZLBDAS, ZLSFACT, ZLVFACT, ZCJ, ZKA, ZDV, PRHODJ, PTHS, &
+ ZRCS, ZRRS, ZRSS, ZRGS, ZTHS)
!
!-------------------------------------------------------------------------------
!
@@ -857,7 +829,10 @@ IF( IMICRO >= 0 ) THEN
!* 5. COMPUTES THE FAST COLD PROCESS SOURCES FOR r_g
! ----------------------------------------------
!
- CALL RAIN_ICE_FAST_RG
+ CALL RAIN_ICE_FAST_RG(KRR, GMICRO, ZRHODREF, ZRVT, ZRCT, ZRRT, ZRIT, ZRST, ZRGT, ZCIT, &
+ ZRHODJ, ZPRES, ZZT, ZLBDAR, ZLBDAS, ZLBDAG, ZLSFACT, ZLVFACT, &
+ ZCJ, ZKA, ZDV, PRHODJ, PTHS, ZRCS, ZRRS, ZRIS, ZRSS, ZRGS, ZRHS, ZTHS, &
+ ZUSW, ZRDRYG, ZRWETG)
!
!-------------------------------------------------------------------------------
!
@@ -866,7 +841,9 @@ IF( IMICRO >= 0 ) THEN
! ----------------------------------------------
!
IF ( KRR == 7 ) THEN
- CALL RAIN_ICE_FAST_RH
+ CALL RAIN_ICE_FAST_RH(GMICRO, ZRHODREF, ZRVT, ZRCT, ZRIT, ZRST, ZRGT, ZRHT, ZRHODJ, ZPRES, &
+ ZZT, ZLBDAS, ZLBDAG, ZLBDAH, ZLSFACT, ZLVFACT, ZCJ, ZKA, ZDV, PRHODJ, PTHS, &
+ ZRCS, ZRRS, ZRIS, ZRSS, ZRGS, ZRHS, ZTHS, ZUSW)
END IF
!
!-------------------------------------------------------------------------------
@@ -875,7 +852,8 @@ IF( IMICRO >= 0 ) THEN
!* 7. COMPUTES SPECIFIC SOURCES OF THE WARM AND COLD CLOUDY SPECIES
! -------------------------------------------------------------
!
- CALL RAIN_ICE_FAST_RI
+ CALL RAIN_ICE_FAST_RI(GMICRO, ZRHODREF, ZRIT, ZRHODJ, ZZT, ZSSI, ZLSFACT, ZLVFACT, &
+ ZAI, ZCJ, PRHODJ, PTHS, ZCIT, ZRCS, ZRIS, ZTHS)
!
!
!-------------------------------------------------------------------------------
@@ -906,17 +884,6 @@ IF( IMICRO >= 0 ) THEN
ZW(:,:,:) = PRAINFR(:,:,:)
PRAINFR(:,:,:) = UNPACK( ZRF(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
!
- ZW(:,:,:) = 0.
- ZHLC_HCF3D(:,:,:) = UNPACK( ZHLC_HCF(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
-!
- ZW(:,:,:) = 0.
- ZHLC_LCF3D(:,:,:) = UNPACK( ZHLC_LCF(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
-!
- ZW(:,:,:) = 0.
- ZHLC_HRC3D(:,:,:) = UNPACK( ZHLC_HRC(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
-!
- ZW(:,:,:) = 0.
- ZHLC_LRC3D(:,:,:) = UNPACK( ZHLC_LRC(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
!
!
DEALLOCATE(ZZW1)
@@ -925,7 +892,7 @@ IF( IMICRO >= 0 ) THEN
DEALLOCATE(ZRDRYG)
DEALLOCATE(ZRWETG)
DEALLOCATE(ZLBDAG)
- IF ( KRR == 7 ) DEALLOCATE(ZLBDAH)
+ DEALLOCATE(ZLBDAH)
DEALLOCATE(ZLBDAS)
DEALLOCATE(ZLBDAR)
DEALLOCATE(ZLBDAR_RF)
@@ -934,9 +901,6 @@ IF( IMICRO >= 0 ) THEN
DEALLOCATE(ZLVFACT)
DEALLOCATE(ZLSFACT)
DEALLOCATE(ZZW)
- DEALLOCATE(ZZW2)
- DEALLOCATE(ZZW3)
- DEALLOCATE(ZZW4)
DEALLOCATE(ZEXNREF)
DEALLOCATE(ZPRES)
DEALLOCATE(ZRHODREF)
@@ -945,7 +909,7 @@ IF( IMICRO >= 0 ) THEN
DEALLOCATE(ZTHS)
DEALLOCATE(ZTHT)
DEALLOCATE(ZTHLT)
- IF ( KRR == 7 ) DEALLOCATE(ZRHS)
+ DEALLOCATE(ZRHS)
DEALLOCATE(ZRGS)
DEALLOCATE(ZRSS)
DEALLOCATE(ZRIS)
@@ -954,7 +918,7 @@ IF( IMICRO >= 0 ) THEN
DEALLOCATE(ZRVS)
DEALLOCATE(ZCIT)
DEALLOCATE(ZRGT)
- IF ( KRR == 7 ) DEALLOCATE(ZRHT)
+ DEALLOCATE(ZRHT)
DEALLOCATE(ZRST)
DEALLOCATE(ZRIT)
DEALLOCATE(ZRRT)
@@ -1072,33 +1036,33 @@ END IF
!
!* 8.1 time splitting loop initialization
!
-ZTSPLITR= PTSTEP / FLOAT(KSPLITR)
!
!
IF (HSEDIM == 'STAT') THEN
- CALL RAIN_ICE_SEDIMENTATION_STAT
+ CALL RAIN_ICE_SEDIMENTATION_STAT( IIB, IIE, IJB, IJE, IKB, IKE, IKTB, IKTE, IKT, KKL, KRR, &
+ PTSTEP, OSEDIC, PINPRC, PINDEP, &
+ PINPRR, PINPRS, PINPRG, PDZZ, PRHODREF, PPABST, PTHT, PRHODJ, PINPRR3D, &
+ PRCS, PRCT, PRRS, PRRT, PRIS, PRSS, PRST, PRGS, PRGT, &
+ PSEA, PTOWN, PINPRH, PRHS, PRHT, PFPR )
ELSEIF (HSEDIM == 'SPLI') THEN
- CALL RAIN_ICE_SEDIMENTATION_SPLIT
+ CALL RAIN_ICE_SEDIMENTATION_SPLIT(IIB, IIE, IJB, IJE, IKB, IKE, IKTB, IKTE, IKT, KKL,&
+ KSPLITR,PTSTEP, &
+ KRR,OSEDIC,LDEPOSC,PINPRC,PINDEP,PINPRR,PINPRS,PINPRG,PDZZ,PRHODREF,PPABST,PTHT,PRHODJ,&
+ PINPRR3D,PRCS,PRCT,PRRS,PRRT,PRIS,PRIT,PRSS,PRST,PRGS,PRGT,PSEA,PTOWN,PINPRH,PRHS,PRHT,PFPR)
ELSE
call Print_msg( NVERB_FATAL, 'GEN', 'RAIN_ICE', 'no sedimentation scheme for HSEDIM='//HSEDIM )
END IF
!sedimentation of rain fraction
-CALL RAINFR_VERT(PRAINFR, PRRS(:,:,:)*PTSTEP)
-
-!
+CALL ICE4_RAINFR_VERT(IIB, IIE, IIT, IJB, IJE, IJT, IKB, IKE, IKT, KKL, PRAINFR, PRRS(:,:,:)*PTSTEP)
!
-!-------------------------------------------------------------------------------
!
!-------------------------------------------------------------------------------
!
-!
CONTAINS
!
-!
!-------------------------------------------------------------------------------
!
-!
- SUBROUTINE RAIN_ICE_SEDIMENTATION_SPLIT
+ FUNCTION COUNTJV(LTAB,I1,I2,I3) RESULT(IC)
!
!* 0. DECLARATIONS
! ------------
@@ -1108,2481 +1072,27 @@ IMPLICIT NONE
!* 0.2 declaration of local variables
!
!
-INTEGER , DIMENSION(SIZE(GSEDIMC)) :: IC1,IC2,IC3 ! Used to replace the COUNT
-INTEGER , DIMENSION(SIZE(GSEDIMR)) :: IR1,IR2,IR3 ! Used to replace the COUNT
-INTEGER , DIMENSION(SIZE(GSEDIMS)) :: IS1,IS2,IS3 ! Used to replace the COUNT
-INTEGER , DIMENSION(SIZE(GSEDIMI)) :: II1,II2,II3 ! Used to replace the COUNT
-INTEGER , DIMENSION(SIZE(GSEDIMG)) :: IG1,IG2,IG3 ! Used to replace the COUNT
-INTEGER , DIMENSION(SIZE(GSEDIMH)) :: IH1,IH2,IH3 ! Used to replace the COUNT
-INTEGER :: ILENALLOCC,ILENALLOCR,ILENALLOCI,ILENALLOCS,ILENALLOCG,ILENALLOCH
-INTEGER :: ILISTLENC,ILISTLENR,ILISTLENI,ILISTLENS,ILISTLENG,ILISTLENH
-INTEGER, ALLOCATABLE :: ILISTR(:),ILISTC(:),ILISTI(:),ILISTS(:),ILISTG(:),ILISTH(:)
-! Optimization for NEC
-!INTEGER, SAVE :: IOLDALLOCC = SIZE(PEXNREF,1)*SIZE(PEXNREF,2)*SIZE(PEXNREF,3)/10
-!INTEGER, SAVE :: IOLDALLOCR = SIZE(PEXNREF,1)*SIZE(PEXNREF,2)*SIZE(PEXNREF,3)/10
-!INTEGER, SAVE :: IOLDALLOCI = SIZE(PEXNREF,1)*SIZE(PEXNREF,2)*SIZE(PEXNREF,3)/10
-!INTEGER, SAVE :: IOLDALLOCS = SIZE(PEXNREF,1)*SIZE(PEXNREF,2)*SIZE(PEXNREF,3)/10
-!INTEGER, SAVE :: IOLDALLOCG = SIZE(PEXNREF,1)*SIZE(PEXNREF,2)*SIZE(PEXNREF,3)/10
-!INTEGER, SAVE :: IOLDALLOCH = SIZE(PEXNREF,1)*SIZE(PEXNREF,2)*SIZE(PEXNREF,3)/10
-INTEGER, SAVE :: IOLDALLOCC = 6000
-INTEGER, SAVE :: IOLDALLOCR = 6000
-INTEGER, SAVE :: IOLDALLOCI = 6000
-INTEGER, SAVE :: IOLDALLOCS = 6000
-INTEGER, SAVE :: IOLDALLOCG = 6000
-INTEGER, SAVE :: IOLDALLOCH = 6000
-!
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: ZCONC3D ! droplet condensation
-!-------------------------------------------------------------------------------
-!
-!
-! O. Initialization of for sedimentation
-!
-IF (OSEDIC) PINPRC (:,:) = 0.
-IF (LDEPOSC) PINDEP (:,:) = 0.
-PINPRR (:,:) = 0.
-PINPRR3D (:,:,:) = 0.
-PINPRS (:,:) = 0.
-PINPRG (:,:) = 0.
-IF ( KRR == 7 ) PINPRH (:,:) = 0.
-IF (PRESENT(PFPR)) PFPR(:,:,:,:) = 0.
-!
-!* 1. Parameters for cloud sedimentation
-!
- IF (OSEDIC) THEN
- ZRAY(:,:,:) = 0.
- ZLBC(:,:,:) = XLBC(1)
- ZFSEDC(:,:,:) = XFSEDC(1)
- ZCONC3D(:,:,:)= XCONC_LAND
- ZCONC_TMP(:,:)= XCONC_LAND
- IF (PRESENT(PSEA)) THEN
- ZCONC_TMP(:,:)=PSEA(:,:)*XCONC_SEA+(1.-PSEA(:,:))*XCONC_LAND
-
- DO JK=IKTB,IKTE
- ZLBC(:,:,JK) = PSEA(:,:)*XLBC(2)+(1.-PSEA(:,:))*XLBC(1)
- ZFSEDC(:,:,JK) = (PSEA(:,:)*XFSEDC(2)+(1.-PSEA(:,:))*XFSEDC(1))
- ZFSEDC(:,:,JK) = MAX(MIN(XFSEDC(1),XFSEDC(2)),ZFSEDC(:,:,JK))
- ZCONC3D(:,:,JK)= (1.-PTOWN(:,:))*ZCONC_TMP(:,:)+PTOWN(:,:)*XCONC_URBAN
- ZRAY(:,:,JK) = 0.5*((1.-PSEA(:,:))*GAMMA(XNUC+1.0/XALPHAC)/(GAMMA(XNUC)) + &
- PSEA(:,:)*GAMMA(XNUC2+1.0/XALPHAC2)/(GAMMA(XNUC2)))
- END DO
- ELSE
- ZCONC3D(:,:,:) = XCONC_LAND
- ZRAY(:,:,:) = 0.5*(GAMMA(XNUC+1.0/XALPHAC)/(GAMMA(XNUC)))
- END IF
- ZRAY(:,:,:) = MAX(1.,ZRAY(:,:,:))
- ZLBC(:,:,:) = MAX(MIN(XLBC(1),XLBC(2)),ZLBC(:,:,:))
- ENDIF
-!
-!* 2. compute the fluxes
-!
-! optimization by looking for locations where
-! the precipitating fields are larger than a minimal value only !!!
-! For optimization we consider each variable separately
-
-ZRTMIN(:) = XRTMIN(:) * ZINVTSTEP
-IF (OSEDIC) GSEDIMC(:,:,:) = .FALSE.
-GSEDIMR(:,:,:) = .FALSE.
-GSEDIMI(:,:,:) = .FALSE.
-GSEDIMS(:,:,:) = .FALSE.
-GSEDIMG(:,:,:) = .FALSE.
-IF ( KRR == 7 ) GSEDIMH(:,:,:) = .FALSE.
-!
-ILENALLOCR = 0
-IF (OSEDIC) ILENALLOCC = 0
-ILENALLOCI = 0
-ILENALLOCS = 0
-ILENALLOCG = 0
-IF ( KRR == 7 ) ILENALLOCH = 0
-!
-! ZPiS = Specie i source creating during the current time step
-! PRiS = Source of the previous time step
-!
-IF (OSEDIC) THEN
- ZPRCS(:,:,:) = 0.0
- ZPRCS(:,:,:) = PRCS(:,:,:)-PRCT(:,:,:)* ZINVTSTEP
- PRCS(:,:,:) = PRCT(:,:,:)* ZINVTSTEP
-END IF
-ZPRRS(:,:,:) = 0.0
-ZPRSS(:,:,:) = 0.0
-ZPRGS(:,:,:) = 0.0
-IF ( KRR == 7 ) ZPRHS(:,:,:) = 0.0
-!
-ZPRRS(:,:,:) = PRRS(:,:,:)-PRRT(:,:,:)* ZINVTSTEP
-ZPRSS(:,:,:) = PRSS(:,:,:)-PRST(:,:,:)* ZINVTSTEP
-ZPRGS(:,:,:) = PRGS(:,:,:)-PRGT(:,:,:)* ZINVTSTEP
-IF ( KRR == 7 ) ZPRHS(:,:,:) = PRHS(:,:,:)-PRHT(:,:,:)* ZINVTSTEP
-PRRS(:,:,:) = PRRT(:,:,:)* ZINVTSTEP
-PRSS(:,:,:) = PRST(:,:,:)* ZINVTSTEP
-PRGS(:,:,:) = PRGT(:,:,:)* ZINVTSTEP
-IF ( KRR == 7 ) PRHS(:,:,:) = PRHT(:,:,:)* ZINVTSTEP
-!
-! PRiS = Source of the previous time step + source created during the subtime
-! step
-!
-DO JN = 1 , KSPLITR
- IF( JN==1 ) THEN
- IF (OSEDIC) PRCS(:,:,:) = PRCS(:,:,:) + ZPRCS(:,:,:)/KSPLITR
- PRRS(:,:,:) = PRRS(:,:,:) + ZPRRS(:,:,:)/KSPLITR
- PRSS(:,:,:) = PRSS(:,:,:) + ZPRSS(:,:,:)/KSPLITR
- PRGS(:,:,:) = PRGS(:,:,:) + ZPRGS(:,:,:)/KSPLITR
- IF ( KRR == 7 ) PRHS(:,:,:) = PRHS(:,:,:) + ZPRHS(:,:,:)/KSPLITR
- DO JK = IKTB , IKTE
- ZW(:,:,JK) =ZTSPLITR/(PRHODREF(:,:,JK)* PDZZ(:,:,JK))
- END DO
- ELSE
- IF (OSEDIC) PRCS(:,:,:) = PRCS(:,:,:) + ZPRCS(:,:,:)*ZTSPLITR
- PRRS(:,:,:) = PRRS(:,:,:) + ZPRRS(:,:,:)*ZTSPLITR
- PRSS(:,:,:) = PRSS(:,:,:) + ZPRSS(:,:,:)*ZTSPLITR
- PRGS(:,:,:) = PRGS(:,:,:) + ZPRGS(:,:,:)*ZTSPLITR
- IF ( KRR == 7 ) PRHS(:,:,:) = PRHS(:,:,:) + ZPRHS(:,:,:)*ZTSPLITR
- END IF
- !
- IF (OSEDIC) GSEDIMC(IIB:IIE,IJB:IJE,IKTB:IKTE) = &
- PRCS(IIB:IIE,IJB:IJE,IKTB:IKTE)>ZRTMIN(2)
- GSEDIMR(IIB:IIE,IJB:IJE,IKTB:IKTE) = &
- PRRS(IIB:IIE,IJB:IJE,IKTB:IKTE)>ZRTMIN(3)
- GSEDIMI(IIB:IIE,IJB:IJE,IKTB:IKTE) = &
- PRIS(IIB:IIE,IJB:IJE,IKTB:IKTE)>ZRTMIN(4)
- GSEDIMS(IIB:IIE,IJB:IJE,IKTB:IKTE) = &
- PRSS(IIB:IIE,IJB:IJE,IKTB:IKTE)>ZRTMIN(5)
- GSEDIMG(IIB:IIE,IJB:IJE,IKTB:IKTE) = &
- PRGS(IIB:IIE,IJB:IJE,IKTB:IKTE)>ZRTMIN(6)
- IF ( KRR == 7 ) GSEDIMH(IIB:IIE,IJB:IJE,IKTB:IKTE) = &
- PRHS(IIB:IIE,IJB:IJE,IKTB:IKTE)>ZRTMIN(7)
-!
- IF (OSEDIC) ISEDIMC = COUNTJV( GSEDIMC(:,:,:),IC1(:),IC2(:),IC3(:))
- ISEDIMR = COUNTJV( GSEDIMR(:,:,:),IR1(:),IR2(:),IR3(:))
- ISEDIMI = COUNTJV( GSEDIMI(:,:,:),II1(:),II2(:),II3(:))
- ISEDIMS = COUNTJV( GSEDIMS(:,:,:),IS1(:),IS2(:),IS3(:))
- ISEDIMG = COUNTJV( GSEDIMG(:,:,:),IG1(:),IG2(:),IG3(:))
- IF ( KRR == 7 ) ISEDIMH = COUNTJV( GSEDIMH(:,:,:),IH1(:),IH2(:),IH3(:))
-!
-!* 2.1 for cloud
-!
- IF (OSEDIC) THEN
- ZWSED(:,:,:) = 0.
- IF( JN==1 ) PRCS(:,:,:) = PRCS(:,:,:) * PTSTEP
- IF( ISEDIMC >= 1 ) THEN
- IF ( ISEDIMC .GT. ILENALLOCC ) THEN
- IF ( ILENALLOCC .GT. 0 ) THEN
- DEALLOCATE (ZRCS, ZRHODREFC, ILISTC,ZWLBDC,ZCONC,ZRCT, &
- ZZT,ZPRES,ZRAY1D,ZFSEDC1D,ZWLBDA,ZCC )
- END IF
- ILENALLOCC = MAX (IOLDALLOCC, 2*ISEDIMC )
- IOLDALLOCC = ILENALLOCC
- ALLOCATE(ZRCS(ILENALLOCC), ZRHODREFC(ILENALLOCC), ILISTC(ILENALLOCC), &
- ZWLBDC(ILENALLOCC), ZCONC(ILENALLOCC), ZRCT(ILENALLOCC), ZZT(ILENALLOCC), &
- ZPRES(ILENALLOCC), ZRAY1D(ILENALLOCC), ZFSEDC1D(ILENALLOCC), &
- ZWLBDA(ILENALLOCC), ZCC(ILENALLOCC) )
- END IF
-!
- DO JL=1,ISEDIMC
- ZRCS(JL) = PRCS(IC1(JL),IC2(JL),IC3(JL))
- ZRHODREFC(JL) = PRHODREF(IC1(JL),IC2(JL),IC3(JL))
- ZWLBDC(JL) = ZLBC(IC1(JL),IC2(JL),IC3(JL))
- ZCONC(JL) = ZCONC3D(IC1(JL),IC2(JL),IC3(JL))
- ZRCT(JL) = PRCT(IC1(JL),IC2(JL),IC3(JL))
- ZZT(JL) = PTHT(IC1(JL),IC2(JL),IC3(JL))
- ZPRES(JL) = PPABST(IC1(JL),IC2(JL),IC3(JL))
- ZRAY1D(JL) = ZRAY(IC1(JL),IC2(JL),IC3(JL))
- ZFSEDC1D(JL) = ZFSEDC(IC1(JL),IC2(JL),IC3(JL))
- END DO
-!
- ILISTLENC = 0
- DO JL=1,ISEDIMC
- IF( ZRCS(JL) .GT. ZRTMIN(2) ) THEN
- ILISTLENC = ILISTLENC + 1
- ILISTC(ILISTLENC) = JL
- END IF
- END DO
- DO JJ = 1, ILISTLENC
- JL = ILISTC(JJ)
- IF (ZRCS(JL) .GT. ZRTMIN(2) .AND. ZRCT(JL) .GT. XRTMIN(2)) THEN
- ZWLBDC(JL) = ZWLBDC(JL) * ZCONC(JL) / (ZRHODREFC(JL) * ZRCT(JL))
- ZWLBDC(JL) = ZWLBDC(JL)**XLBEXC
- ZRAY1D(JL) = ZRAY1D(JL) / ZWLBDC(JL) !! ZRAY : mean diameter=M(1)/2
- ZZT(JL) = ZZT(JL) * (ZPRES(JL)/XP00)**(XRD/XCPD)
- ZWLBDA(JL) = 6.6E-8*(101325./ZPRES(JL))*(ZZT(JL)/293.15)
- ZCC(JL) = XCC*(1.+1.26*ZWLBDA(JL)/ZRAY1D(JL)) !! XCC modified for cloud
- ZWSED (IC1(JL),IC2(JL),IC3(JL))= ZRHODREFC(JL)**(-XCEXVT +1 ) * &
- ZWLBDC(JL)**(-XDC)*ZCC(JL)*ZFSEDC1D(JL) * ZRCS(JL)
- END IF
- END DO
- END IF
- DO JK = IKTB , IKTE
- PRCS(:,:,JK) = PRCS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
- END DO
- IF (PRESENT(PFPR)) THEN
- DO JK = IKTB , IKTE
- PFPR(:,:,JK,2)=ZWSED(:,:,JK)
- ENDDO
- ENDIF
- PINPRC(:,:) = PINPRC(:,:) + ZWSED(:,:,IKB) / XRHOLW / KSPLITR
- IF( JN==KSPLITR ) THEN
- PRCS(:,:,:) = PRCS(:,:,:) * ZINVTSTEP
- END IF
- END IF
-!
-!* 2.2 for rain
-!
- IF( JN==1 ) PRRS(:,:,:) = PRRS(:,:,:) * PTSTEP
- ZWSED(:,:,:) = 0.
- IF( ISEDIMR >= 1 ) THEN
- IF ( ISEDIMR .GT. ILENALLOCR ) THEN
- IF ( ILENALLOCR .GT. 0 ) THEN
- DEALLOCATE (ZRRS, ZRHODREFR, ILISTR)
- END IF
- ILENALLOCR = MAX (IOLDALLOCR, 2*ISEDIMR )
- IOLDALLOCR = ILENALLOCR
- ALLOCATE(ZRRS(ILENALLOCR), ZRHODREFR(ILENALLOCR), ILISTR(ILENALLOCR))
- END IF
-!
- DO JL=1,ISEDIMR
- ZRRS(JL) = PRRS(IR1(JL),IR2(JL),IR3(JL))
- ZRHODREFR(JL) = PRHODREF(IR1(JL),IR2(JL),IR3(JL))
- END DO
-!
- ILISTLENR = 0
- DO JL=1,ISEDIMR
- IF( ZRRS(JL) .GT. ZRTMIN(3) ) THEN
- ILISTLENR = ILISTLENR + 1
- ILISTR(ILISTLENR) = JL
- END IF
- END DO
- DO JJ = 1, ILISTLENR
- JL = ILISTR(JJ)
- ZWSED (IR1(JL),IR2(JL),IR3(JL))= XFSEDR * ZRRS(JL)**XEXSEDR * &
- ZRHODREFR(JL)**(XEXSEDR-XCEXVT)
- END DO
- END IF
- DO JK = IKTB , IKTE
- PRRS(:,:,JK) = PRRS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
- END DO
- IF (PRESENT(PFPR)) THEN
- DO JK = IKTB , IKTE
- PFPR(:,:,JK,3)=ZWSED(:,:,JK)
- ENDDO
- ENDIF
- PINPRR(:,:) = PINPRR(:,:) + ZWSED(:,:,IKB)/XRHOLW/KSPLITR
- PINPRR3D(:,:,:) = PINPRR3D(:,:,:) + ZWSED(:,:,1:IKT)/XRHOLW/KSPLITR
- IF( JN==KSPLITR ) THEN
- PRRS(:,:,:) = PRRS(:,:,:) * ZINVTSTEP
- END IF
-!
-!* 2.3 for pristine ice
-!
- IF( JN==1 ) PRIS(:,:,:) = PRIS(:,:,:) * PTSTEP
- ZWSED(:,:,:) = 0.
- IF( ISEDIMI >= 1 ) THEN
- IF ( ISEDIMI .GT. ILENALLOCI ) THEN
- IF ( ILENALLOCI .GT. 0 ) THEN
- DEALLOCATE (ZRIS, ZRHODREFI, ILISTI)
- END IF
- ILENALLOCI = MAX (IOLDALLOCI, 2*ISEDIMI )
- IOLDALLOCI = ILENALLOCI
- ALLOCATE(ZRIS(ILENALLOCI), ZRHODREFI(ILENALLOCI), ILISTI(ILENALLOCI))
- END IF
-!
- DO JL=1,ISEDIMI
- ZRIS(JL) = PRIS(II1(JL),II2(JL),II3(JL))
- ZRHODREFI(JL) = PRHODREF(II1(JL),II2(JL),II3(JL))
- END DO
-!
- ILISTLENI = 0
- DO JL=1,ISEDIMI
- IF( ZRIS(JL) .GT. MAX(ZRTMIN(4),1.0E-7 )) THEN ! limitation of the McF&H formula
- ILISTLENI = ILISTLENI + 1
- ILISTI(ILISTLENI) = JL
- END IF
- END DO
- DO JJ = 1, ILISTLENI
- JL = ILISTI(JJ)
- ZWSED (II1(JL),II2(JL),II3(JL))= XFSEDI * ZRIS(JL) * &
- ZRHODREFI(JL)**(1.0-XCEXVT) * & ! McF&H
- MAX( 0.05E6,-0.15319E6-0.021454E6* &
- ALOG(ZRHODREFI(JL)*ZRIS(JL)) )**XEXCSEDI
- END DO
- END IF
- DO JK = IKTB , IKTE
- PRIS(:,:,JK) = PRIS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
- END DO
- IF (PRESENT(PFPR)) THEN
- DO JK = IKTB , IKTE
- PFPR(:,:,JK,4)=ZWSED(:,:,JK)
- ENDDO
- ENDIF
- IF( JN==KSPLITR ) THEN
- PRIS(:,:,:) = PRIS(:,:,:) * ZINVTSTEP
- END IF
-!
-!* 2.4 for aggregates/snow
-!
- IF( JN==1 ) PRSS(:,:,:) = PRSS(:,:,:) * PTSTEP
- ZWSED(:,:,:) = 0.
- IF( ISEDIMS >= 1 ) THEN
- IF ( ISEDIMS .GT. ILENALLOCS ) THEN
- IF ( ILENALLOCS .GT. 0 ) THEN
- DEALLOCATE (ZRSS, ZRHODREFS, ILISTS)
- END IF
- ILENALLOCS = MAX (IOLDALLOCS, 2*ISEDIMS )
- IOLDALLOCS = ILENALLOCS
- ALLOCATE(ZRSS(ILENALLOCS), ZRHODREFS(ILENALLOCS), ILISTS(ILENALLOCS))
- END IF
-!
- DO JL=1,ISEDIMS
- ZRSS(JL) = PRSS(IS1(JL),IS2(JL),IS3(JL))
- ZRHODREFS(JL) = PRHODREF(IS1(JL),IS2(JL),IS3(JL))
- END DO
-!
- ILISTLENS = 0
- DO JL=1,ISEDIMS
- IF( ZRSS(JL) .GT. ZRTMIN(5) ) THEN
- ILISTLENS = ILISTLENS + 1
- ILISTS(ILISTLENS) = JL
- END IF
- END DO
- DO JJ = 1, ILISTLENS
- JL = ILISTS(JJ)
- ZWSED (IS1(JL),IS2(JL),IS3(JL))= XFSEDS * ZRSS(JL)**XEXSEDS * &
- ZRHODREFS(JL)**(XEXSEDS-XCEXVT)
- END DO
- END IF
- DO JK = IKTB , IKTE
- PRSS(:,:,JK) = PRSS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
- END DO
- IF (PRESENT(PFPR)) THEN
- DO JK = IKTB , IKTE
- PFPR(:,:,JK,5)=ZWSED(:,:,JK)
- ENDDO
- ENDIF
- PINPRS(:,:) = PINPRS(:,:) + ZWSED(:,:,IKB)/XRHOLW/KSPLITR
- IF( JN==KSPLITR ) THEN
- PRSS(:,:,:) = PRSS(:,:,:) * ZINVTSTEP
- END IF
-!
-!* 2.5 for graupeln
-!
- ZWSED(:,:,:) = 0.
- IF( JN==1 ) PRGS(:,:,:) = PRGS(:,:,:) * PTSTEP
- IF( ISEDIMG >= 1 ) THEN
- IF ( ISEDIMG .GT. ILENALLOCG ) THEN
- IF ( ILENALLOCG .GT. 0 ) THEN
- DEALLOCATE (ZRGS, ZRHODREFG, ILISTG)
- END IF
- ILENALLOCG = MAX (IOLDALLOCG, 2*ISEDIMG )
- IOLDALLOCG = ILENALLOCG
- ALLOCATE(ZRGS(ILENALLOCG), ZRHODREFG(ILENALLOCG), ILISTG(ILENALLOCG))
- END IF
-!
- DO JL=1,ISEDIMG
- ZRGS(JL) = PRGS(IG1(JL),IG2(JL),IG3(JL))
- ZRHODREFG(JL) = PRHODREF(IG1(JL),IG2(JL),IG3(JL))
- END DO
-!
- ILISTLENG = 0
- DO JL=1,ISEDIMG
- IF( ZRGS(JL) .GT. ZRTMIN(6) ) THEN
- ILISTLENG = ILISTLENG + 1
- ILISTG(ILISTLENG) = JL
- END IF
- END DO
- DO JJ = 1, ILISTLENG
- JL = ILISTG(JJ)
- ZWSED (IG1(JL),IG2(JL),IG3(JL))= XFSEDG * ZRGS(JL)**XEXSEDG * &
- ZRHODREFG(JL)**(XEXSEDG-XCEXVT)
- END DO
-END IF
- DO JK = IKTB , IKTE
- PRGS(:,:,JK) = PRGS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
- END DO
- IF (PRESENT(PFPR)) THEN
- DO JK = IKTB , IKTE
- PFPR(:,:,JK,6)=ZWSED(:,:,JK)
- ENDDO
- ENDIF
- PINPRG(:,:) = PINPRG(:,:) + ZWSED(:,:,IKB)/XRHOLW/KSPLITR
- IF( JN==KSPLITR ) THEN
- PRGS(:,:,:) = PRGS(:,:,:) * ZINVTSTEP
- END IF
+LOGICAL, DIMENSION(:,:,:) :: LTAB ! Mask
+INTEGER, DIMENSION(:) :: I1,I2,I3 ! Used to replace the COUNT and PACK
+INTEGER :: JI,JJ,JK,IC
!
-!* 2.6 for hail
+!-------------------------------------------------------------------------------
!
- IF ( KRR == 7 ) THEN
- IF( JN==1 ) PRHS(:,:,:) = PRHS(:,:,:) * PTSTEP
- ZWSED(:,:,:) = 0.
- IF( ISEDIMH >= 1 ) THEN
- IF ( ISEDIMH .GT. ILENALLOCH ) THEN
- IF ( ILENALLOCH .GT. 0 ) THEN
- DEALLOCATE (ZRHS, ZRHODREFH, ILISTH)
+IC = 0
+DO JK = 1,SIZE(LTAB,3)
+ DO JJ = 1,SIZE(LTAB,2)
+ DO JI = 1,SIZE(LTAB,1)
+ IF( LTAB(JI,JJ,JK) ) THEN
+ IC = IC +1
+ I1(IC) = JI
+ I2(IC) = JJ
+ I3(IC) = JK
END IF
- ILENALLOCH = MAX (IOLDALLOCH, 2*ISEDIMH )
- IOLDALLOCH = ILENALLOCH
- ALLOCATE(ZRHS(ILENALLOCH), ZRHODREFH(ILENALLOCH), ILISTH(ILENALLOCH))
- END IF
-!
- DO JL=1,ISEDIMH
- ZRHS(JL) = PRHS(IH1(JL),IH2(JL),IH3(JL))
- ZRHODREFH(JL) = PRHODREF(IH1(JL),IH2(JL),IH3(JL))
- END DO
-!
- ILISTLENH = 0
- DO JL=1,ISEDIMH
- IF( ZRHS(JL) .GT. ZRTMIN(7) ) THEN
- ILISTLENH = ILISTLENH + 1
- ILISTH(ILISTLENH) = JL
- END IF
END DO
- DO JJ = 1, ILISTLENH
- JL = ILISTH(JJ)
- ZWSED (IH1(JL),IH2(JL),IH3(JL))= XFSEDH * ZRHS(JL)**XEXSEDH * &
- ZRHODREFH(JL)**(XEXSEDH-XCEXVT)
- END DO
- END IF
- DO JK = IKTB , IKTE
- PRHS(:,:,JK) = PRHS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
- END DO
- IF (PRESENT(PFPR)) THEN
- DO JK = IKTB , IKTE
- PFPR(:,:,JK,7)=ZWSED(:,:,JK)
- ENDDO
- ENDIF
- PINPRH(:,:) = PINPRH(:,:) + ZWSED(:,:,IKB)/XRHOLW/KSPLITR
- IF( JN==KSPLITR ) THEN
- PRHS(:,:,:) = PRHS(:,:,:) * ZINVTSTEP
- END IF
- END IF
-!
-END DO
-!
-IF (OSEDIC) THEN
- IF (ILENALLOCC .GT. 0) DEALLOCATE (ZRCS, ZRHODREFC, &
- ILISTC,ZWLBDC,ZCONC,ZRCT, ZZT,ZPRES,ZRAY1D,ZFSEDC1D, ZWLBDA,ZCC)
-END IF
-IF (ILENALLOCR .GT. 0 ) DEALLOCATE(ZRHODREFR,ZRRS,ILISTR)
-IF (ILENALLOCI .GT. 0 ) DEALLOCATE(ZRHODREFI,ZRIS,ILISTI)
-IF (ILENALLOCS .GT. 0 ) DEALLOCATE(ZRHODREFS,ZRSS,ILISTS)
-IF (ILENALLOCG .GT. 0 ) DEALLOCATE(ZRHODREFG,ZRGS,ILISTG)
-IF (KRR == 7 .AND. (ILENALLOCH .GT. 0 )) DEALLOCATE(ZRHODREFH,ZRHS,ILISTH)
-!
-!* 2.3 budget storage
-!
-IF (LBUDGET_RC .AND. OSEDIC) &
- CALL BUDGET (PRCS(:,:,:)*PRHODJ(:,:,:),7 ,'SEDI_BU_RRC')
-IF (LBUDGET_RR) CALL BUDGET (PRRS(:,:,:)*PRHODJ(:,:,:),8 ,'SEDI_BU_RRR')
-IF (LBUDGET_RI) CALL BUDGET (PRIS(:,:,:)*PRHODJ(:,:,:),9 ,'SEDI_BU_RRI')
-IF (LBUDGET_RS) CALL BUDGET (PRSS(:,:,:)*PRHODJ(:,:,:),10,'SEDI_BU_RRS')
-IF (LBUDGET_RG) CALL BUDGET (PRGS(:,:,:)*PRHODJ(:,:,:),11,'SEDI_BU_RRG')
-IF ( KRR == 7 .AND. LBUDGET_RH) &
- CALL BUDGET (PRHS(:,:,:)*PRHODJ(:,:,:),12,'SEDI_BU_RRH')
-!
-!
-!
-!* 2.4 DROPLET DEPOSITION AT THE 1ST LEVEL ABOVE GROUND
-!
-IF (LDEPOSC) THEN
- GDEP(:,:) = .FALSE.
- GDEP(IIB:IIE,IJB:IJE) = PRCS(IIB:IIE,IJB:IJE,IKB) >0
- WHERE (GDEP)
- PRCS(:,:,IKB) = PRCS(:,:,IKB) - XVDEPOSC * PRCT(:,:,IKB) / PDZZ(:,:,IKB)
- PINPRC(:,:) = PINPRC(:,:) + XVDEPOSC * PRCT(:,:,IKB) * PRHODREF(:,:,IKB) /XRHOLW
- PINDEP(:,:) = XVDEPOSC * PRCT(:,:,IKB) * PRHODREF(:,:,IKB) /XRHOLW
- END WHERE
-END IF
-!
-!* 2.5 budget storage
-!
-IF ( LBUDGET_RC .AND. LDEPOSC ) &
- CALL BUDGET (PRCS(:,:,:)*PRHODJ(:,:,:),7 ,'DEPO_BU_RRC')
-!
-
- END SUBROUTINE RAIN_ICE_SEDIMENTATION_SPLIT
-!
-!-------------------------------------------------------------------------------
-!
- SUBROUTINE RAIN_ICE_SEDIMENTATION_STAT
-!
-!* 0. DECLARATIONS
-! ------------
-!
-IMPLICIT NONE
-!
-!* 0.2 declaration of local variables
-!
-!
-
-REAL :: ZP1,ZP2,ZH,ZZWLBDA,ZZWLBDC,ZZCC
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2)) :: ZQP
-INTEGER :: JI,JJ,JK
-INTEGER :: JCOUNT, JL
-INTEGER, DIMENSION(SIZE(PRHODREF,1)*SIZE(PRHODREF,2)) :: I1, I2
-!
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: ZCONC3D ! droplet condensation
-!-------------------------------------------------------------------------------
-!
-!
-!
-!* 1. Parameters for cloud sedimentation
-!
- IF (OSEDIC) THEN
- ZRAY(:,:,:) = 0.
- ZLBC(:,:,:) = XLBC(1)
- ZFSEDC(:,:,:) = XFSEDC(1)
- ZCONC3D(:,:,:)= XCONC_LAND
- ZCONC_TMP(:,:)= XCONC_LAND
- IF (PRESENT(PSEA)) THEN
- ZCONC_TMP(:,:)=PSEA(:,:)*XCONC_SEA+(1.-PSEA(:,:))*XCONC_LAND
-
- DO JK=IKTB,IKTE
- ZLBC(:,:,JK) = PSEA(:,:)*XLBC(2)+(1.-PSEA(:,:))*XLBC(1)
- ZFSEDC(:,:,JK) = (PSEA(:,:)*XFSEDC(2)+(1.-PSEA(:,:))*XFSEDC(1))
- ZFSEDC(:,:,JK) = MAX(MIN(XFSEDC(1),XFSEDC(2)),ZFSEDC(:,:,JK))
- ZCONC3D(:,:,JK)= (1.-PTOWN(:,:))*ZCONC_TMP(:,:)+PTOWN(:,:)*XCONC_URBAN
- ZRAY(:,:,JK) = 0.5*((1.-PSEA(:,:))*GAMMA(XNUC+1.0/XALPHAC)/(GAMMA(XNUC)) + &
- PSEA(:,:)*GAMMA(XNUC2+1.0/XALPHAC2)/(GAMMA(XNUC2)))
- END DO
- ELSE
- ZCONC3D(:,:,:) = XCONC_LAND
- ZRAY(:,:,:) = 0.5*(GAMMA(XNUC+1.0/XALPHAC)/(GAMMA(XNUC)))
- END IF
- ZRAY(:,:,:) = MAX(1.,ZRAY(:,:,:))
- ZLBC(:,:,:) = MAX(MIN(XLBC(1),XLBC(2)),ZLBC(:,:,:))
- ENDIF
- IF (LDEPOSC) PINDEP (:,:) = 0.
-!
-!* 2. compute the fluxes
-!
-
-
-ZRTMIN(:) = XRTMIN(:) * ZINVTSTEP
-!
-IF (OSEDIC) THEN
- ZPRCS(:,:,:) = 0.0
- ZPRCS(:,:,:) = PRCS(:,:,:)-PRCT(:,:,:)* ZINVTSTEP
- PRCS(:,:,:) = PRCT(:,:,:)* ZINVTSTEP
-END IF
-ZPRRS(:,:,:) = 0.0
-ZPRSS(:,:,:) = 0.0
-ZPRGS(:,:,:) = 0.0
-IF ( KRR == 7 ) ZPRHS(:,:,:) = 0.0
-!
-ZPRRS(:,:,:) = PRRS(:,:,:)-PRRT(:,:,:)* ZINVTSTEP
-ZPRSS(:,:,:) = PRSS(:,:,:)-PRST(:,:,:)* ZINVTSTEP
-ZPRGS(:,:,:) = PRGS(:,:,:)-PRGT(:,:,:)* ZINVTSTEP
-IF ( KRR == 7 ) ZPRHS(:,:,:) = PRHS(:,:,:)-PRHT(:,:,:)* ZINVTSTEP
-PRRS(:,:,:) = PRRT(:,:,:)* ZINVTSTEP
-PRSS(:,:,:) = PRST(:,:,:)* ZINVTSTEP
-PRGS(:,:,:) = PRGT(:,:,:)* ZINVTSTEP
-IF ( KRR == 7 ) PRHS(:,:,:) = PRHT(:,:,:)* ZINVTSTEP
-!
-IF (OSEDIC) PRCS(:,:,:) = PRCS(:,:,:) + ZPRCS(:,:,:)
-PRRS(:,:,:) = PRRS(:,:,:) + ZPRRS(:,:,:)
-PRSS(:,:,:) = PRSS(:,:,:) + ZPRSS(:,:,:)
-PRGS(:,:,:) = PRGS(:,:,:) + ZPRGS(:,:,:)
-IF ( KRR == 7 ) PRHS(:,:,:) = PRHS(:,:,:) + ZPRHS(:,:,:)
-DO JK = IKTB , IKTE
- ZW(:,:,JK) =PTSTEP/(PRHODREF(:,:,JK)* PDZZ(:,:,JK) )
-END DO
-
-!
-!* 2.1 for cloud
-!
- IF (OSEDIC) THEN
- PRCS(:,:,:) = PRCS(:,:,:) * PTSTEP
- ZWSED(:,:,:) = 0.
- ZWSEDW1(:,:,:) = 0.
- ZWSEDW2(:,:,:) = 0.
-
-! calculation of P1, P2 and sedimentation flux
- DO JK = IKE , IKB, -1*KKL
- !estimation of q' taking into account incomming ZWSED
- ZQP(:,:)=ZWSED(:,:,JK+KKL)*ZW(:,:,JK)
-
- JCOUNT=COUNTJV2((PRCS(:,:,JK) > ZRTMIN(2) .AND. PRCT(:,:,JK) > ZRTMIN(2)) .OR. &
- (ZQP(:,:) > ZRTMIN(2)),I1(:),I2(:))
- DO JL=1, JCOUNT
- JI=I1(JL)
- JJ=I2(JL)
- !calculation of w
- ! mars 2009 : ajout d'un test
- !IF ( PRCS(JI,JJ,JK) > ZRTMIN(2) ) THEN
- IF(PRCS(JI,JJ,JK) > ZRTMIN(2) .AND. PRCT(JI,JJ,JK) > ZRTMIN(2)) THEN
- ZZWLBDA=6.6E-8*(101325./PPABST(JI,JJ,JK))*(PTHT(JI,JJ,JK)/293.15)
- ZZWLBDC=(ZLBC(JI,JJ,JK)*ZCONC3D(JI,JJ,JK) &
- &/(PRHODREF(JI,JJ,JK)*PRCT(JI,JJ,JK)))**XLBEXC
- ZZCC=XCC*(1.+1.26*ZZWLBDA*ZZWLBDC/ZRAY(JI,JJ,JK)) !! ZCC : Fall speed
- ZWSEDW1 (JI,JJ,JK)=PRHODREF(JI,JJ,JK)**(-XCEXVT ) * &
- & ZZWLBDC**(-XDC)*ZZCC*ZFSEDC(JI,JJ,JK)
- ENDIF
- IF ( ZQP(JI,JJ) > ZRTMIN(2) ) THEN
- ZZWLBDA=6.6E-8*(101325./PPABST(JI,JJ,JK))*(PTHT(JI,JJ,JK)/293.15)
- ZZWLBDC=(ZLBC(JI,JJ,JK)*ZCONC3D(JI,JJ,JK) &
- &/(PRHODREF(JI,JJ,JK)*ZQP(JI,JJ)))**XLBEXC
- ZZCC=XCC*(1.+1.26*ZZWLBDA*ZZWLBDC/ZRAY(JI,JJ,JK)) !! ZCC : Fall speed
- ZWSEDW2 (JI,JJ,JK)=PRHODREF(JI,JJ,JK)**(-XCEXVT ) * &
- & ZZWLBDC**(-XDC)*ZZCC*ZFSEDC(JI,JJ,JK)
- ENDIF
- ENDDO
-
- DO JJ = IJB, IJE
- DO JI = IIB, IIE
- ZH=PDZZ(JI,JJ,JK)
- ZP1 = MIN(1., ZWSEDW1(JI,JJ,JK) * PTSTEP / ZH)
- ! mars 2009 : correction : ZWSEDW1 => ZWSEDW2
- !IF (ZWSEDW1(JI,JJ,JK) /= 0.) THEN
- IF (ZWSEDW2(JI,JJ,JK) /= 0.) THEN
- ZP2 = MAX(0.,1 - ZH &
- & / (PTSTEP*ZWSEDW2(JI,JJ,JK)) )
- ELSE
- ZP2 = 0.
- ENDIF
- ZWSED (JI,JJ,JK)=ZP1*PRHODREF(JI,JJ,JK)*&
- &ZH*PRCS(JI,JJ,JK)&
- &* ZINVTSTEP+ ZP2 * ZWSED (JI,JJ,JK+KKL)
- ENDDO
- ENDDO
- ENDDO
-
- DO JK = IKTB , IKTE
- PRCS(:,:,JK) = PRCS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
- END DO
- IF (PRESENT(PFPR)) THEN
- DO JK = IKTB , IKTE
- PFPR(:,:,JK,2)=ZWSED(:,:,JK)
- ENDDO
- ENDIF
-
- PINPRC(:,:) = ZWSED(:,:,IKB)/XRHOLW ! in m/s
- PRCS(:,:,:) = PRCS(:,:,:) * ZINVTSTEP
- ENDIF
-
-!
-!* 2.2 for rain
-!
-
- PRRS(:,:,:) = PRRS(:,:,:) * PTSTEP
- ZWSED(:,:,:) = 0.
- ZWSEDW1(:,:,:) = 0.
- ZWSEDW2(:,:,:) = 0.
-
-! calculation of ZP1, ZP2 and sedimentation flux
- DO JK = IKE , IKB, -1*KKL
- !estimation of q' taking into account incomming ZWSED
- ZQP(:,:)=ZWSED(:,:,JK+KKL)*ZW(:,:,JK)
-
- JCOUNT=COUNTJV2((PRRS(:,:,JK) > ZRTMIN(3)) .OR. &
- (ZQP(:,:) > ZRTMIN(3)),I1(:),I2(:))
- DO JL=1, JCOUNT
- JI=I1(JL)
- JJ=I2(JL)
- !calculation of w
- IF ( PRRS(JI,JJ,JK) > ZRTMIN(3) ) THEN
- ZWSEDW1 (JI,JJ,JK)= XFSEDR *PRRS(JI,JJ,JK)**(XEXSEDR-1)* &
- PRHODREF(JI,JJ,JK)**(XEXSEDR-XCEXVT-1)
- ENDIF
- IF ( ZQP(JI,JJ) > ZRTMIN(3) ) THEN
- ZWSEDW2 (JI,JJ,JK)= XFSEDR *(ZQP(JI,JJ))**(XEXSEDR-1)* &
- PRHODREF(JI,JJ,JK)**(XEXSEDR-XCEXVT-1)
- ENDIF
- ENDDO
- DO JJ = IJB, IJE
- DO JI = IIB, IIE
- ZH=PDZZ(JI,JJ,JK)
- ZP1 = MIN(1., ZWSEDW1(JI,JJ,JK) * PTSTEP / ZH )
- IF (ZWSEDW2(JI,JJ,JK) /= 0.) THEN
- ZP2 = MAX(0.,1 - ZH &
- & / (PTSTEP*ZWSEDW2(JI,JJ,JK)) )
- ELSE
- ZP2 = 0.
- ENDIF
- ZWSED (JI,JJ,JK)=ZP1*PRHODREF(JI,JJ,JK)*&
- &ZH*PRRS(JI,JJ,JK)&
- &* ZINVTSTEP+ ZP2 * ZWSED (JI,JJ,JK+KKL)
- ENDDO
- ENDDO
- ENDDO
-
- DO JK = IKTB , IKTE
- PRRS(:,:,JK) = PRRS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
- ENDDO
- IF (PRESENT(PFPR)) THEN
- DO JK = IKTB , IKTE
- PFPR(:,:,JK,3)=ZWSED(:,:,JK)
- ENDDO
- ENDIF
- PINPRR(:,:) = ZWSED(:,:,IKB)/XRHOLW ! in m/s
- PINPRR3D(:,:,:) = ZWSED(:,:,1:IKT)/XRHOLW ! in m/s
- PRRS(:,:,:) = PRRS(:,:,:) * ZINVTSTEP
-
-!
-!* 2.3 for pristine ice
-!
-
- PRIS(:,:,:) = PRIS(:,:,:) * PTSTEP
- ZWSED(:,:,:) = 0.
- ZWSEDW1(:,:,:) = 0.
- ZWSEDW2(:,:,:) = 0.
-! calculation of ZP1, ZP2 and sedimentation flux
- DO JK = IKE , IKB, -1*KKL
- !estimation of q' taking into account incomming ZWSED
- ZQP(:,:)=ZWSED(:,:,JK+KKL)*ZW(:,:,JK)
-
- JCOUNT=COUNTJV2((PRIS(:,:,JK) > MAX(ZRTMIN(4),1.0E-7 )) .OR. &
- (ZQP(:,:) > MAX(ZRTMIN(4),1.0E-7 )),I1(:),I2(:))
- DO JL=1, JCOUNT
- JI=I1(JL)
- JJ=I2(JL)
- !calculation of w
- IF ( PRIS(JI,JJ,JK) > MAX(ZRTMIN(4),1.0E-7 ) ) THEN
- ZWSEDW1 (JI,JJ,JK)= XFSEDI * &
- & PRHODREF(JI,JJ,JK)**(XCEXVT) * & ! McF&H
- & MAX( 0.05E6,-0.15319E6-0.021454E6* &
- & ALOG(PRHODREF(JI,JJ,JK)*PRIS(JI,JJ,JK)) )**XEXCSEDI
- ENDIF
- IF ( ZQP(JI,JJ) > MAX(ZRTMIN(4),1.0E-7 ) ) THEN
- ZWSEDW2 (JI,JJ,JK)= XFSEDI * &
- & PRHODREF(JI,JJ,JK)**(XCEXVT) * & ! McF&H
- & MAX( 0.05E6,-0.15319E6-0.021454E6* &
- & ALOG(PRHODREF(JI,JJ,JK)*ZQP(JI,JJ)) )**XEXCSEDI
- ENDIF
- ENDDO
- DO JJ = IJB, IJE
- DO JI = IIB, IIE
- ZH=PDZZ(JI,JJ,JK)
- ZP1 = MIN(1., ZWSEDW1(JI,JJ,JK) * PTSTEP / ZH )
- IF (ZWSEDW2(JI,JJ,JK) /= 0.) THEN
- ZP2 = MAX(0.,1 - ZH &
- & / (PTSTEP*ZWSEDW2(JI,JJ,JK)) )
- ELSE
- ZP2 = 0.
- ENDIF
- ZWSED (JI,JJ,JK)=ZP1*PRHODREF(JI,JJ,JK)*&
- &ZH*PRIS(JI,JJ,JK)&
- &* ZINVTSTEP+ ZP2 * ZWSED (JI,JJ,JK+KKL)
- ENDDO
- ENDDO
- ENDDO
-
- DO JK = IKTB , IKTE
- PRIS(:,:,JK) = PRIS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
- ENDDO
- IF (PRESENT(PFPR)) THEN
- DO JK = IKTB , IKTE
- PFPR(:,:,JK,4)=ZWSED(:,:,JK)
- ENDDO
- ENDIF
-
- PRIS(:,:,:) = PRIS(:,:,:) * ZINVTSTEP
-
-
-!
-!* 2.4 for aggregates/snow
-!
-
- PRSS(:,:,:) = PRSS(:,:,:) * PTSTEP
- ZWSED(:,:,:) = 0.
- ZWSEDW1(:,:,:) = 0.
- ZWSEDW2(:,:,:) = 0.
-
-! calculation of ZP1, ZP2 and sedimentation flux
- DO JK = IKE , IKB, -1*KKL
- !estimation of q' taking into account incomming ZWSED
- ZQP(:,:)=ZWSED(:,:,JK+KKL)*ZW(:,:,JK)
-
- JCOUNT=COUNTJV2((PRSS(:,:,JK) > ZRTMIN(5)) .OR. &
- (ZQP(:,:) > ZRTMIN(5)),I1(:),I2(:))
- DO JL=1, JCOUNT
- JI=I1(JL)
- JJ=I2(JL)
- !calculation of w
- IF (PRSS(JI,JJ,JK) > ZRTMIN(5) ) THEN
- ZWSEDW1(JI,JJ,JK)=XFSEDS*(PRSS(JI,JJ,JK))**(XEXSEDS-1)*&
- PRHODREF(JI,JJ,JK)**(XEXSEDS-XCEXVT-1)
- ENDIF
- IF ( ZQP(JI,JJ) > ZRTMIN(5) ) THEN
- ZWSEDW2(JI,JJ,JK)=XFSEDS*(ZQP(JI,JJ))**(XEXSEDS-1)*&
- PRHODREF(JI,JJ,JK)**(XEXSEDS-XCEXVT-1)
- ENDIF
- ENDDO
- DO JJ = IJB, IJE
- DO JI = IIB, IIE
- ZH=PDZZ(JI,JJ,JK)
- ZP1 = MIN(1., ZWSEDW1(JI,JJ,JK) * PTSTEP / ZH )
- IF (ZWSEDW2(JI,JJ,JK) /= 0.) THEN
- ZP2 = MAX(0.,1 - ZH&
- / (PTSTEP*ZWSEDW2(JI,JJ,JK)) )
- ELSE
- ZP2 = 0.
- ENDIF
- ZWSED (JI,JJ,JK)=ZP1*PRHODREF(JI,JJ,JK)*&
- &ZH*PRSS(JI,JJ,JK)&
- &* ZINVTSTEP+ ZP2 * ZWSED (JI,JJ,JK+KKL)
- ENDDO
- ENDDO
- ENDDO
-
- DO JK = IKTB , IKTE
- PRSS(:,:,JK) = PRSS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
- ENDDO
- IF (PRESENT(PFPR)) THEN
- DO JK = IKTB , IKTE
- PFPR(:,:,JK,5)=ZWSED(:,:,JK)
- ENDDO
- ENDIF
-
- PINPRS(:,:) = ZWSED(:,:,IKB)/XRHOLW ! in m/s
-
- PRSS(:,:,:) = PRSS(:,:,:) * ZINVTSTEP
-
-
-!
-!* 2.5 for graupeln
-!
-
- PRGS(:,:,:) = PRGS(:,:,:) * PTSTEP
- ZWSED(:,:,:) = 0.
- ZWSEDW1(:,:,:) = 0.
- ZWSEDW2(:,:,:) = 0.
-
-! calculation of ZP1, ZP2 and sedimentation flux
- DO JK = IKE, IKB, -1*KKL
- !estimation of q' taking into account incomming ZWSED
- ZQP(:,:)=ZWSED(:,:,JK+KKL)*ZW(:,:,JK)
-
- JCOUNT=COUNTJV2((PRGS(:,:,JK) > ZRTMIN(6)) .OR. &
- (ZQP(:,:) > ZRTMIN(6)),I1(:),I2(:))
- DO JL=1, JCOUNT
- JI=I1(JL)
- JJ=I2(JL)
- !calculation of w
- IF ( PRGS(JI,JJ,JK) > ZRTMIN(6) ) THEN
- ZWSEDW1 (JI,JJ,JK)= XFSEDG*(PRGS(JI,JJ,JK))**(XEXSEDG-1) * &
- PRHODREF(JI,JJ,JK)**(XEXSEDG-XCEXVT-1)
- ENDIF
- IF ( ZQP(JI,JJ) > ZRTMIN(6) ) THEN
- ZWSEDW2 (JI,JJ,JK)= XFSEDG*(ZQP(JI,JJ))**(XEXSEDG-1) * &
- PRHODREF(JI,JJ,JK)**(XEXSEDG-XCEXVT-1)
- ENDIF
- ENDDO
- DO JJ = IJB, IJE
- DO JI = IIB, IIE
- ZH=PDZZ(JI,JJ,JK)
- ZP1 = MIN(1., ZWSEDW1(JI,JJ,JK) * PTSTEP / ZH )
- IF (ZWSEDW2(JI,JJ,JK) /= 0.) THEN
- ZP2 = MAX(0.,1 - ZH &
- & / (PTSTEP*ZWSEDW2(JI,JJ,JK)) )
- ELSE
- ZP2 = 0.
- ENDIF
- ZWSED (JI,JJ,JK)=ZP1*PRHODREF(JI,JJ,JK)*&
- &ZH*PRGS(JI,JJ,JK)&
- &* ZINVTSTEP+ ZP2 * ZWSED (JI,JJ,JK+KKL)
- ENDDO
- ENDDO
- ENDDO
-
- DO JK = IKTB , IKTE
- PRGS(:,:,JK) = PRGS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
- ENDDO
- IF (PRESENT(PFPR)) THEN
- DO JK = IKTB , IKTE
- PFPR(:,:,JK,6)=ZWSED(:,:,JK)
- ENDDO
- ENDIF
-
- PINPRG(:,:) = ZWSED(:,:,IKB)/XRHOLW ! in m/s
-
- PRGS(:,:,:) = PRGS(:,:,:) * ZINVTSTEP
-
-!
-!* 2.6 for hail
-!
- IF ( KRR == 7 ) THEN
- PRHS(:,:,:) = PRHS(:,:,:) * PTSTEP
- ZWSED(:,:,:) = 0.
- ZWSEDW1(:,:,:) = 0.
- ZWSEDW2(:,:,:) = 0.
-! calculation of ZP1, ZP2 and sedimentation flux
- DO JK = IKE , IKB, -1*KKL
- !estimation of q' taking into account incomming ZWSED
- ZQP(:,:)=ZWSED(:,:,JK+KKL)*ZW(:,:,JK)
-
- JCOUNT=COUNTJV2((PRHS(:,:,JK)+ZQP(JI,JJ) > ZRTMIN(7)) .OR. &
- (ZQP(:,:) > ZRTMIN(7)),I1(:),I2(:))
- DO JL=1, JCOUNT
- JI=I1(JL)
- JJ=I2(JL)
- !calculation of w
- IF ((PRHS(JI,JJ,JK)+ZQP(JI,JJ)) > ZRTMIN(7) ) THEN
- ZWSEDW1 (JI,JJ,JK)= XFSEDH * (PRHS(JI,JJ,JK))**(XEXSEDH-1) * &
- PRHODREF(JI,JJ,JK)**(XEXSEDH-XCEXVT-1)
- ENDIF
- IF ( ZQP(JI,JJ) > ZRTMIN(7) ) THEN
- ZWSEDW2 (JI,JJ,JK)= XFSEDH * ZQP(JI,JJ)**(XEXSEDH-1) * &
- PRHODREF(JI,JJ,JK)**(XEXSEDH-XCEXVT-1)
- ENDIF
- ENDDO
- DO JJ = IJB, IJE
- DO JI = IIB, IIE
- ZH=PDZZ(JI,JJ,JK)
- ZP1 = MIN(1., ZWSEDW1(JI,JJ,JK) * PTSTEP / ZH)
- IF (ZWSEDW2(JI,JJ,JK) /= 0.) THEN
- ZP2 = MAX(0.,1 - ZH &
- & / (PTSTEP*ZWSEDW2(JI,JJ,JK)) )
- ELSE
- ZP2 = 0.
- ENDIF
- ZWSED (JI,JJ,JK)=ZP1*PRHODREF(JI,JJ,JK)*&
- &ZH*PRHS(JI,JJ,JK)&
- &* ZINVTSTEP+ ZP2 * ZWSED (JI,JJ,JK+KKL)
- ENDDO
- ENDDO
- ENDDO
-
- DO JK = IKTB , IKTE
- PRHS(:,:,JK) = PRHS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
- ENDDO
- IF (PRESENT(PFPR)) THEN
- DO JK = IKTB , IKTE
- PFPR(:,:,JK,7)=ZWSED(:,:,JK)
- ENDDO
- ENDIF
-
- PINPRH(:,:) = ZWSED(:,:,IKB)/XRHOLW ! in m/s
-
- PRHS(:,:,:) = PRHS(:,:,:) * ZINVTSTEP
-
- ENDIF
-!
-
-!
-!* 2.3 budget storage
-!
-IF (LBUDGET_RC .AND. OSEDIC) &
- CALL BUDGET (PRCS(:,:,:)*PRHODJ(:,:,:),7 ,'SEDI_BU_RRC')
-IF (LBUDGET_RR) CALL BUDGET (PRRS(:,:,:)*PRHODJ(:,:,:),8 ,'SEDI_BU_RRR')
-IF (LBUDGET_RI) CALL BUDGET (PRIS(:,:,:)*PRHODJ(:,:,:),9 ,'SEDI_BU_RRI')
-IF (LBUDGET_RS) CALL BUDGET (PRSS(:,:,:)*PRHODJ(:,:,:),10,'SEDI_BU_RRS')
-IF (LBUDGET_RG) CALL BUDGET (PRGS(:,:,:)*PRHODJ(:,:,:),11,'SEDI_BU_RRG')
-IF ( KRR == 7 .AND. LBUDGET_RH) &
- CALL BUDGET (PRHS(:,:,:)*PRHODJ(:,:,:),12,'SEDI_BU_RRH')
-!
-!
-!* 2.4 DROPLET DEPOSITION AT THE 1ST LEVEL ABOVE GROUND
-!
-IF (LDEPOSC) THEN
- GDEP(:,:) = .FALSE.
- GDEP(IIB:IIE,IJB:IJE) = PRCS(IIB:IIE,IJB:IJE,IKB) >0
- WHERE (GDEP)
- PRCS(:,:,IKB) = PRCS(:,:,IKB) - XVDEPOSC * PRCT(:,:,IKB) / PDZZ(:,:,IKB)
- PINPRC(:,:) = PINPRC(:,:) + XVDEPOSC * PRCT(:,:,IKB) * PRHODREF(:,:,IKB) /XRHOLW
- PINDEP(:,:) = XVDEPOSC * PRCT(:,:,IKB) * PRHODREF(:,:,IKB) /XRHOLW
- END WHERE
-END IF
-!
-!* 2.5 budget storage
-!
-IF ( LBUDGET_RC .AND. LDEPOSC ) &
- CALL BUDGET (PRCS(:,:,:)*PRHODJ(:,:,:),7 ,'DEPO_BU_RRC')
-
-!
- END SUBROUTINE RAIN_ICE_SEDIMENTATION_STAT
-!
-!-------------------------------------------------------------------------------
-!
-
-!
- SUBROUTINE RAIN_ICE_NUCLEATION
-!
-!* 0. DECLARATIONS
-! ------------
-!
-IMPLICIT NONE
-!
-!* 0.2 declaration of local variables
-!
-INTEGER , DIMENSION(SIZE(GNEGT)) :: I1,I2,I3 ! Used to replace the COUNT
-INTEGER :: JL ! and PACK intrinsics
-!
-!-------------------------------------------------------------------------------
-!
-!
-! compute the temperature and the pressure
-!
-ZT(:,:,:) = PTHT(:,:,:) * ( PPABST(:,:,:) / XP00 ) ** (XRD/XCPD)
-!
-! optimization by looking for locations where
-! the temperature is negative only !!!
-!
-GNEGT(:,:,:) = .FALSE.
-GNEGT(IIB:IIE,IJB:IJE,IKTB:IKTE) = ZT(IIB:IIE,IJB:IJE,IKTB:IKTE)<XTT
-INEGT = COUNTJV( GNEGT(:,:,:),I1(:),I2(:),I3(:))
-IF( INEGT >= 1 ) THEN
- ALLOCATE(ZRVT(INEGT)) ;
- ALLOCATE(ZCIT(INEGT)) ;
- ALLOCATE(ZZT(INEGT)) ;
- ALLOCATE(ZPRES(INEGT));
- DO JL=1,INEGT
- ZRVT(JL) = PRVT(I1(JL),I2(JL),I3(JL))
- ZCIT(JL) = PCIT(I1(JL),I2(JL),I3(JL))
- ZZT(JL) = ZT(I1(JL),I2(JL),I3(JL))
- ZPRES(JL) = PPABST(I1(JL),I2(JL),I3(JL))
- ENDDO
- ALLOCATE(ZZW(INEGT))
- ALLOCATE(ZUSW(INEGT))
- ALLOCATE(ZSSI(INEGT))
- ZZW(:) = EXP( XALPI - XBETAI/ZZT(:) - XGAMI*ALOG(ZZT(:) ) ) ! es_i
- ZZW(:) = MIN(ZPRES(:)/2., ZZW(:)) ! safety limitation
- ZSSI(:) = ZRVT(:)*( ZPRES(:)-ZZW(:) ) / ( (XMV/XMD) * ZZW(:) ) - 1.0
- ! Supersaturation over ice
- ZUSW(:) = EXP( XALPW - XBETAW/ZZT(:) - XGAMW*ALOG(ZZT(:) ) ) ! es_w
- ZUSW(:) = MIN(ZPRES(:)/2.,ZUSW(:)) ! safety limitation
- ZUSW(:) = ( ZUSW(:)/ZZW(:) )*( (ZPRES(:)-ZZW(:))/(ZPRES(:)-ZUSW(:)) ) - 1.0
- ! Supersaturation of saturated water vapor over ice
-!
-!* 3.1 compute the heterogeneous nucleation source: RVHENI
-!
-!* 3.1.1 compute the cloud ice concentration
-!
- ZZW(:) = 0.0
- ZSSI(:) = MIN( ZSSI(:), ZUSW(:) ) ! limitation of SSi according to SSw=0
- WHERE( (ZZT(:)<XTT-5.0) .AND. (ZSSI(:)>0.0) )
- ZZW(:) = XNU20 * EXP( XALPHA2*ZSSI(:)-XBETA2 )
- END WHERE
- WHERE( (ZZT(:)<=XTT-2.0) .AND. (ZZT(:)>=XTT-5.0) .AND. (ZSSI(:)>0.0) )
- ZZW(:) = MAX( XNU20 * EXP( -XBETA2 ),XNU10 * EXP( -XBETA1*(ZZT(:)-XTT) ) * &
- ( ZSSI(:)/ZUSW(:) )**XALPHA1 )
- END WHERE
- ZZW(:) = ZZW(:) - ZCIT(:)
- IF( MAXVAL(ZZW(:)) > 0.0 ) THEN
-!
-!* 3.1.2 update the r_i and r_v mixing ratios
-!
- ZZW(:) = MIN( ZZW(:),50.E3 ) ! limitation provisoire a 50 l^-1
- ZW(:,:,:) = UNPACK( ZZW(:),MASK=GNEGT(:,:,:),FIELD=0.0 )
- ZW(:,:,:) = MAX( ZW(:,:,:) ,0.0 ) *XMNU0/(PRHODREF(:,:,:)*PTSTEP)
- PRIS(:,:,:) = PRIS(:,:,:) + ZW(:,:,:)
- PRVS(:,:,:) = PRVS(:,:,:) - ZW(:,:,:)
- IF ( KRR == 7 ) THEN
- PTHS(:,:,:) = PTHS(:,:,:) + ZW(:,:,:)*(XLSTT+(XCPV-XCI)*(ZT(:,:,:)-XTT)) &
- /( (XCPD + XCPV*PRVT(:,:,:) + XCL*(PRCT(:,:,:)+PRRT(:,:,:)) &
- + XCI*(PRIT(:,:,:)+PRST(:,:,:)+PRGT(:,:,:)+PRHT(:,:,:)))*PEXNREF(:,:,:) )
- ELSE IF( KRR == 6 ) THEN
- PTHS(:,:,:) = PTHS(:,:,:) + ZW(:,:,:)*(XLSTT+(XCPV-XCI)*(ZT(:,:,:)-XTT)) &
- /( (XCPD + XCPV*PRVT(:,:,:) + XCL*(PRCT(:,:,:)+PRRT(:,:,:)) &
- + XCI*(PRIT(:,:,:)+PRST(:,:,:)+PRGT(:,:,:)))*PEXNREF(:,:,:) )
- END IF
- ! f(L_s*(RVHENI))
- ZZW(:) = MAX( ZZW(:)+ZCIT(:),ZCIT(:) )
- PCIT(:,:,:) = MAX( UNPACK( ZZW(:),MASK=GNEGT(:,:,:),FIELD=0.0 ) , &
- PCIT(:,:,:) )
- END IF
- DEALLOCATE(ZSSI)
- DEALLOCATE(ZUSW)
- DEALLOCATE(ZZW)
- DEALLOCATE(ZPRES)
- DEALLOCATE(ZZT)
- DEALLOCATE(ZCIT)
- DEALLOCATE(ZRVT)
-END IF
-!
-!* 3.1.3 budget storage
-!
-IF (LBUDGET_TH) CALL BUDGET (PTHS(:,:,:)*PRHODJ(:,:,:),4,'HENU_BU_RTH')
-IF (LBUDGET_RV) CALL BUDGET (PRVS(:,:,:)*PRHODJ(:,:,:),6,'HENU_BU_RRV')
-IF (LBUDGET_RI) CALL BUDGET (PRIS(:,:,:)*PRHODJ(:,:,:),9,'HENU_BU_RRI')
-!
- END SUBROUTINE RAIN_ICE_NUCLEATION
-!
-!-------------------------------------------------------------------------------
-!
-!
- SUBROUTINE RAIN_ICE_SLOW
-!
-!* 0. DECLARATIONS
-! ------------
-!
-IMPLICIT NONE
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 3.2 compute the homogeneous nucleation source: RCHONI
-!
- ZZW(:) = 0.0
- WHERE( (ZZT(:)<XTT-35.0) .AND. (ZRCT(:)>XRTMIN(2)) .AND. (ZRCS(:)>0.) )
- ZZW(:) = MIN( ZRCS(:),XHON*ZRHODREF(:)*ZRCT(:) &
- *EXP( MIN(XMNH_HUGE_12_LOG,XALPHA3*(ZZT(:)-XTT)-XBETA3) ) )
- ! *EXP( XALPHA3*(ZZT(:)-XTT)-XBETA3 ) )
- ZRIS(:) = ZRIS(:) + ZZW(:)
- ZRCS(:) = ZRCS(:) - ZZW(:)
- ZTHS(:) = ZTHS(:) + ZZW(:)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(RCHONI))
- ENDWHERE
-!
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'HON_BU_RTH')
- IF (LBUDGET_RC) CALL BUDGET ( &
- UNPACK(ZRCS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 7,'HON_BU_RRC')
- IF (LBUDGET_RI) CALL BUDGET ( &
- UNPACK(ZRIS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 9,'HON_BU_RRI')
-!
-!* 3.3 compute the spontaneous freezing source: RRHONG
-!
- ZZW(:) = 0.0
- WHERE( (ZZT(:)<XTT-35.0) .AND. (ZRRT(:)>XRTMIN(3)) .AND. (ZRRS(:)>0.) )
- ZZW(:) = MIN( ZRRS(:),ZRRT(:)* ZINVTSTEP )
- ZRGS(:) = ZRGS(:) + ZZW(:)
- ZRRS(:) = ZRRS(:) - ZZW(:)
- ZTHS(:) = ZTHS(:) + ZZW(:)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(RRHONG))
- ENDWHERE
-!
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'SFR_BU_RTH')
- IF (LBUDGET_RR) CALL BUDGET ( &
- UNPACK(ZRRS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 8,'SFR_BU_RRR')
- IF (LBUDGET_RG) CALL BUDGET ( &
- UNPACK(ZRGS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 11,'SFR_BU_RRG')
-!
-!* 3.4 compute the deposition, aggregation and autoconversion sources
-!
- ZKA(:) = 2.38E-2 + 0.0071E-2 * ( ZZT(:) - XTT ) ! k_a
- ZDV(:) = 0.211E-4 * (ZZT(:)/XTT)**1.94 * (XP00/ZPRES(:)) ! D_v
-!
-!* 3.4.1 compute the thermodynamical function A_i(T,P)
-!* and the c^prime_j (in the ventilation factor)
-!
-
- ZAI(:) = EXP( XALPI - XBETAI/ZZT(:) - XGAMI*ALOG(ZZT(:) ) ) ! es_i
- ZAI(:) = ( XLSTT + (XCPV-XCI)*(ZZT(:)-XTT) )**2 / (ZKA(:)*XRV*ZZT(:)**2) &
- + ( XRV*ZZT(:) ) / (ZDV(:)*ZAI(:))
- ZCJ(:) = XSCFAC * ZRHODREF(:)**0.3 / SQRT( 1.718E-5+0.0049E-5*(ZZT(:)-XTT) )
-!
-!* 3.4.2 compute the riming-conversion of r_c for r_i production: RCAUTI
-!
-! ZZW(:) = 0.0
-! ZTIMAUTIC = SQRT( XTIMAUTI*XTIMAUTC )
-! WHERE ( (ZRCT(:)>0.0) .AND. (ZRIT(:)>0.0) .AND. (ZRCS(:)>0.0) )
-! ZZW(:) = MIN( ZRCS(:),ZTIMAUTIC * MAX( SQRT( ZRIT(:)*ZRCT(:) ),0.0 ) )
-! ZRIS(:) = ZRIS(:) + ZZW(:)
-! ZRCS(:) = ZRCS(:) - ZZW(:)
-! ZTHS(:) = ZTHS(:) + ZZW(:)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(RCAUTI))
-! END WHERE
-!
-!* 3.4.3 compute the deposition on r_s: RVDEPS
-!
- WHERE ( ZRST(:)>0.0 )
- ZLBDAS(:) = MIN( XLBDAS_MAX, &
- XLBS*( ZRHODREF(:)*MAX( ZRST(:),XRTMIN(5) ) )**XLBEXS )
- END WHERE
- ZZW(:) = 0.0
- WHERE ( (ZRST(:)>XRTMIN(5)) .AND. (ZRSS(:)>0.0) )
- ZZW(:) = ( ZSSI(:)/(ZRHODREF(:)*ZAI(:)) ) * &
- ( X0DEPS*ZLBDAS(:)**XEX0DEPS + X1DEPS*ZCJ(:)*ZLBDAS(:)**XEX1DEPS )
- ZZW(:) = MIN( ZRVS(:),ZZW(:) )*(0.5+SIGN(0.5,ZZW(:))) &
- - MIN( ZRSS(:),ABS(ZZW(:)) )*(0.5-SIGN(0.5,ZZW(:)))
- ZRSS(:) = ZRSS(:) + ZZW(:)
- ZRVS(:) = ZRVS(:) - ZZW(:)
- ZTHS(:) = ZTHS(:) + ZZW(:)*ZLSFACT(:)
- END WHERE
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'DEPS_BU_RTH')
- IF (LBUDGET_RV) CALL BUDGET ( &
- UNPACK(ZRVS(:),MASK=GMICRO(:,:,:),FIELD=PRVS)*PRHODJ(:,:,:), &
- 6,'DEPS_BU_RRV')
- IF (LBUDGET_RS) CALL BUDGET ( &
- UNPACK(ZRSS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 10,'DEPS_BU_RRS')
-!
-!* 3.4.4 compute the aggregation on r_s: RIAGGS
-!
- ZZW(:) = 0.0
- WHERE ( (ZRIT(:)>XRTMIN(4)) .AND. (ZRST(:)>XRTMIN(5)) .AND. (ZRIS(:)>0.0) )
- ZZW(:) = MIN( ZRIS(:),XFIAGGS * EXP( XCOLEXIS*(ZZT(:)-XTT) ) &
- * ZRIT(:) &
- * ZLBDAS(:)**XEXIAGGS &
- * ZRHODREF(:)**(-XCEXVT) )
- ZRSS(:) = ZRSS(:) + ZZW(:)
- ZRIS(:) = ZRIS(:) - ZZW(:)
- END WHERE
- IF (LBUDGET_RI) CALL BUDGET ( &
- UNPACK(ZRIS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 9,'AGGS_BU_RRI')
- IF (LBUDGET_RS) CALL BUDGET ( &
- UNPACK(ZRSS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 10,'AGGS_BU_RRS')
-!
-!* 3.4.5 compute the autoconversion of r_i for r_s production: RIAUTS
-!
- ALLOCATE(ZCRIAUTI(IMICRO))
-! ZCRIAUTI(:)=MIN(XCRIAUTI,10**(0.06*(ZZT(:)-XTT)-3.5))
- ZCRIAUTI(:)=MIN(XCRIAUTI,10**(XACRIAUTI*(ZZT(:)-XTT)+XBCRIAUTI))
- ZZW(:) = 0.0
- WHERE ( (ZRIT(:)>XRTMIN(4)) .AND. (ZRIS(:)>0.0) )
- ZZW(:) = MIN( ZRIS(:),XTIMAUTI * EXP( XTEXAUTI*(ZZT(:)-XTT) ) &
- * MAX( ZRIT(:)-ZCRIAUTI(:),0.0 ) )
- ZRSS(:) = ZRSS(:) + ZZW(:)
- ZRIS(:) = ZRIS(:) - ZZW(:)
- END WHERE
- DEALLOCATE(ZCRIAUTI)
- IF (LBUDGET_RI) CALL BUDGET ( &
- UNPACK(ZRIS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 9,'AUTS_BU_RRI')
- IF (LBUDGET_RS) CALL BUDGET ( &
- UNPACK(ZRSS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 10,'AUTS_BU_RRS')
-!
-!* 3.4.6 compute the deposition on r_g: RVDEPG
-!
-!
- WHERE ( ZRGT(:)>0.0 )
- ZLBDAG(:) = XLBG*( ZRHODREF(:)*MAX( ZRGT(:),XRTMIN(6) ) )**XLBEXG
- END WHERE
- ZZW(:) = 0.0
- WHERE ( (ZRGT(:)>XRTMIN(6)) .AND. (ZRGS(:)>0.0) )
- ZZW(:) = ( ZSSI(:)/(ZRHODREF(:)*ZAI(:)) ) * &
- ( X0DEPG*ZLBDAG(:)**XEX0DEPG + X1DEPG*ZCJ(:)*ZLBDAG(:)**XEX1DEPG )
- ZZW(:) = MIN( ZRVS(:),ZZW(:) )*(0.5+SIGN(0.5,ZZW(:))) &
- - MIN( ZRGS(:),ABS(ZZW(:)) )*(0.5-SIGN(0.5,ZZW(:)))
- ZRGS(:) = ZRGS(:) + ZZW(:)
- ZRVS(:) = ZRVS(:) - ZZW(:)
- ZTHS(:) = ZTHS(:) + ZZW(:)*ZLSFACT(:)
- END WHERE
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'DEPG_BU_RTH')
- IF (LBUDGET_RV) CALL BUDGET ( &
- UNPACK(ZRVS(:),MASK=GMICRO(:,:,:),FIELD=PRVS)*PRHODJ(:,:,:), &
- 6,'DEPG_BU_RRV')
- IF (LBUDGET_RG) CALL BUDGET ( &
- UNPACK(ZRGS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 11,'DEPG_BU_RRG')
-!
- END SUBROUTINE RAIN_ICE_SLOW
-!
-!-------------------------------------------------------------------------------
-!
-!
- SUBROUTINE RAIN_ICE_WARM
-!
-!* 0. DECLARATIONS
-! ------------
-!
-IMPLICIT NONE
-!
-!
-!-------------------------------------------------------------------------------
-!
-!* 4.2 compute the autoconversion of r_c for r_r production: RCAUTR
-!
-
- WHERE( ZRCS(:)>0.0 .AND. ZHLC_HCF(:).GT.0.0 )
- ZZW(:) = XTIMAUTC*MAX( ZHLC_HRC(:)/ZHLC_HCF(:) - XCRIAUTC/ZRHODREF(:),0.0)
- ZZW(:) = MIN( ZRCS(:),ZHLC_HCF(:)*ZZW(:))
- ZRCS(:) = ZRCS(:) - ZZW(:)
- ZRRS(:) = ZRRS(:) + ZZW(:)
- END WHERE
-!
- IF (LBUDGET_RC) CALL BUDGET ( &
- UNPACK(ZRCS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 7,'AUTO_BU_RRC')
- IF (LBUDGET_RR) CALL BUDGET ( &
- UNPACK(ZRRS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 8,'AUTO_BU_RRR')
-!
-!* 4.3 compute the accretion of r_c for r_r production: RCACCR
-!
- IF (CSUBG_RC_RR_ACCR=='NONE') THEN
- !CLoud water and rain are diluted over the grid box
- WHERE( ZRCT(:)>XRTMIN(2) .AND. ZRRT(:)>XRTMIN(3) .AND. ZRCS(:)>0.0 )
- ZZW(:) = MIN( ZRCS(:), XFCACCR * ZRCT(:) &
- * ZLBDAR(:)**XEXCACCR &
- * ZRHODREF(:)**(-XCEXVT) )
- ZRCS(:) = ZRCS(:) - ZZW(:)
- ZRRS(:) = ZRRS(:) + ZZW(:)
- END WHERE
-
- ELSEIF (CSUBG_RC_RR_ACCR=='PRFR') THEN
- !Cloud water is concentrated over its fraction with possibly to parts with high and low content as set for autoconversion
- !Rain is concnetrated over its fraction
- !Rain in high content area fraction: ZHLC_HCF
- !Rain in low content area fraction:
- ! if ZRF<ZCF (rain is entirely falling in cloud): ZRF-ZHLC_HCF
- ! if ZRF>ZCF (rain is falling in cloud and in clear sky): ZCF-ZHLC_HCF
- ! => min(ZCF, ZRF)-ZHLC_HCF
- ZZW(:) = 0.
- WHERE( ZHLC_HRC(:)>XRTMIN(2) .AND. ZRRT(:)>XRTMIN(3) .AND. ZRCS(:)>0.0 &
- .AND. ZHLC_HCF(:)>0 )
- !Accretion due to rain falling in high cloud content
- ZZW(:) = XFCACCR * ( ZHLC_HRC(:)/ZHLC_HCF(:) ) &
- * ZLBDAR_RF(:)**XEXCACCR &
- * ZRHODREF(:)**(-XCEXVT) &
- * ZHLC_HCF
- END WHERE
- WHERE( ZHLC_LRC(:)>XRTMIN(2) .AND. ZRRT(:)>XRTMIN(3) .AND. ZRCS(:)>0.0 &
- .AND. ZHLC_LCF(:)>0 )
- !We add acrretion due to rain falling in low cloud content
- ZZW(:) = ZZW(:) + XFCACCR * ( ZHLC_LRC(:)/ZHLC_LCF(:) ) &
- * ZLBDAR_RF(:)**XEXCACCR &
- * ZRHODREF(:)**(-XCEXVT) &
- * (MIN(ZCF(:), ZRF(:))-ZHLC_HCF(:))
- END WHERE
- ZZW(:)=MIN(ZRCS(:), ZZW(:))
- ZRCS(:) = ZRCS(:) - ZZW(:)
- ZRRS(:) = ZRRS(:) + ZZW(:)
-
- ELSE
- !wrong CSUBG_RC_RR_ACCR case
- WRITE(*,*) 'wrong CSUBG_RC_RR_ACCR case'
- CALL PRINT_MSG(NVERB_FATAL,'GEN','RAIN_ICE_WARM','')
- ENDIF
-
- IF (LBUDGET_RC) CALL BUDGET ( &
- UNPACK(ZRCS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 7,'ACCR_BU_RRC')
- IF (LBUDGET_RR) CALL BUDGET ( &
- UNPACK(ZRRS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 8,'ACCR_BU_RRR')
-!
-!* 4.4 compute the evaporation of r_r: RREVAV
-!
- ZZW(:) = 0.0
-
- IF (CSUBG_RR_EVAP=='NONE') THEN
- !Evaporation only when there's no cloud (RC must be 0)
- WHERE( (ZRRT(:)>XRTMIN(3)) .AND. (ZRCT(:)<=XRTMIN(2)) )
- ZZW(:) = EXP( XALPW - XBETAW/ZZT(:) - XGAMW*ALOG(ZZT(:) ) ) ! es_w
- ZUSW(:) = 1.0 - ZRVT(:)*( ZPRES(:)-ZZW(:) ) / ( (XMV/XMD) * ZZW(:) )
- ! Undersaturation over water
- ZZW(:) = ( XLVTT+(XCPV-XCL)*(ZZT(:)-XTT) )**2 / ( ZKA(:)*XRV*ZZT(:)**2 ) &
- + ( XRV*ZZT(:) ) / ( ZDV(:)*ZZW(:) )
- ZZW(:) = MIN( ZRRS(:),( MAX( 0.0,ZUSW(:) )/(ZRHODREF(:)*ZZW(:)) ) * &
- ( X0EVAR*ZLBDAR(:)**XEX0EVAR+X1EVAR*ZCJ(:)*ZLBDAR(:)**XEX1EVAR ) )
- ZRRS(:) = ZRRS(:) - ZZW(:)
- ZRVS(:) = ZRVS(:) + ZZW(:)
- ZTHS(:) = ZTHS(:) - ZZW(:)*ZLVFACT(:)
- END WHERE
-
- ELSEIF (CSUBG_RR_EVAP=='CLFR' .OR. CSUBG_RR_EVAP=='PRFR') THEN
- !Evaporation in clear sky part
- !With CLFR, rain is diluted over the grid box
- !With PRFR, rain is concentrated in its fraction
- !Use temperature and humidity in clear sky part like Bechtold et al. (1993)
- IF (CSUBG_RR_EVAP=='CLFR') THEN
- ZZW4(:)=1. !Precipitation fraction
- ZZW3(:)=ZLBDAR(:)
- ELSE
- ZZW4(:)=ZRF(:) !Precipitation fraction
- ZZW3(:)=ZLBDAR_RF(:)
- ENDIF
-
- !ATTENTION
- !Il faudrait recalculer les variables ZKA, ZDV, ZCJ en tenant compte de la température T^u
- !Ces variables devraient être sorties de rain_ice_slow et on mettrait le calcul de T^u, T^s
- !et plusieurs versions (comme actuellement, en ciel clair, en ciel nuageux) de ZKA, ZDV, ZCJ dans rain_ice
- !On utiliserait la bonne version suivant l'option NONE, CLFR... dans l'évaporation et ailleurs
-
- WHERE( (ZRRT(:)>XRTMIN(3)) .AND. ( ZZW4(:) > ZCF(:) ) )
- ! outside the cloud (environment) the use of T^u (unsaturated) instead of T
- ! Bechtold et al. 1993
- !
- ! T^u = T_l = theta_l * (T/theta)
- ZZW2(:) = ZTHLT(:) * ZZT(:) / ZTHT(:)
- !
- ! es_w with new T^u
- ZZW(:) = EXP( XALPW - XBETAW/ZZW2(:) - XGAMW*ALOG(ZZW2(:) ) )
- !
- ! S, Undersaturation over water (with new theta^u)
- ZUSW(:) = 1.0 - ZRVT(:)*( ZPRES(:)-ZZW(:) ) / ( (XMV/XMD) * ZZW(:) )
- !
- ZZW(:) = ( XLVTT+(XCPV-XCL)*(ZZW2(:)-XTT) )**2 / ( ZKA(:)*XRV*ZZW2(:)**2 ) &
- + ( XRV*ZZW2(:) ) / ( ZDV(:)*ZZW(:) )
- !
- ZZW(:) = MAX( 0.0,ZUSW(:) )/(ZRHODREF(:)*ZZW(:)) * &
- ( X0EVAR*ZZW3(:)**XEX0EVAR+X1EVAR*ZCJ(:)*ZZW3(:)**XEX1EVAR )
- !
- ZZW(:) = MIN( ZRRS(:), ZZW(:) *( ZZW4(:) - ZCF(:) ) )
- !
- ZRRS(:) = ZRRS(:) - ZZW(:)
- ZRVS(:) = ZRVS(:) + ZZW(:)
- ZTHS(:) = ZTHS(:) - ZZW(:)*ZLVFACT(:)
- END WHERE
-
- ELSE
- !wrong CSUBG_RR_EVAP case
- WRITE(*,*) 'wrong CSUBG_RR_EVAP case'
- CALL PRINT_MSG(NVERB_FATAL,'GEN','RAIN_ICE_WARM','')
- END IF
-
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'REVA_BU_RTH')
- IF (LBUDGET_RV) CALL BUDGET ( &
- UNPACK(ZRVS(:),MASK=GMICRO(:,:,:),FIELD=PRVS)*PRHODJ(:,:,:), &
- 6,'REVA_BU_RRV')
- IF (LBUDGET_RR) CALL BUDGET ( &
- UNPACK(ZRRS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 8,'REVA_BU_RRR')
- ZW(:,:,:)=PEVAP3D(:,:,:)
- PEVAP3D(:,:,:)=UNPACK(ZZW(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:))
-!
- END SUBROUTINE RAIN_ICE_WARM
-!
-!-------------------------------------------------------------------------------
-!
-!
- SUBROUTINE RAIN_ICE_FAST_RS
-!
-!* 0. DECLARATIONS
-! ------------
-!
-IMPLICIT NONE
-!
-!-------------------------------------------------------------------------------
-!
-!* 5.1 cloud droplet riming of the aggregates
-!
- ZZW1(:,:) = 0.0
-!
- ALLOCATE(GRIM(IMICRO))
-! GRIM(:) = (ZRCT(:)>0.0) .AND. (ZRST(:)>0.0) .AND. &
- GRIM(:) = (ZRCT(:)>XRTMIN(2)) .AND. (ZRST(:)>XRTMIN(5)) .AND. &
- (ZRCS(:)>0.0) .AND. (ZZT(:)<XTT)
- IGRIM = COUNT( GRIM(:) )
-!
- IF( IGRIM>0 ) THEN
-!
-! 5.1.0 allocations
-!
- ALLOCATE(ZVEC1(IGRIM))
- ALLOCATE(ZVEC2(IGRIM))
- ALLOCATE(IVEC1(IGRIM))
- ALLOCATE(IVEC2(IGRIM))
-!
-! 5.1.1 select the ZLBDAS
-!
- ZVEC1(:) = PACK( ZLBDAS(:),MASK=GRIM(:) )
-!
-! 5.1.2 find the next lower indice for the ZLBDAS in the geometrical
-! set of Lbda_s used to tabulate some moments of the incomplete
-! gamma function
-!
- ZVEC2(1:IGRIM) = MAX( 1.00001, MIN( FLOAT(NGAMINC)-0.00001, &
- XRIMINTP1 * LOG( ZVEC1(1:IGRIM) ) + XRIMINTP2 ) )
- IVEC2(1:IGRIM) = INT( ZVEC2(1:IGRIM) )
- ZVEC2(1:IGRIM) = ZVEC2(1:IGRIM) - FLOAT( IVEC2(1:IGRIM) )
-!
-! 5.1.3 perform the linear interpolation of the normalized
-! "2+XDS"-moment of the incomplete gamma function
-!
- ZVEC1(1:IGRIM) = XGAMINC_RIM1( IVEC2(1:IGRIM)+1 )* ZVEC2(1:IGRIM) &
- - XGAMINC_RIM1( IVEC2(1:IGRIM) )*(ZVEC2(1:IGRIM) - 1.0)
- ZZW(:) = UNPACK( VECTOR=ZVEC1(:),MASK=GRIM,FIELD=0.0 )
-!
-! 5.1.4 riming of the small sized aggregates
-!
- WHERE ( GRIM(:) )
- ZZW1(:,1) = MIN( ZRCS(:), &
- XCRIMSS * ZZW(:) * ZRCT(:) & ! RCRIMSS
- * ZLBDAS(:)**XEXCRIMSS &
- * ZRHODREF(:)**(-XCEXVT) )
- ZRCS(:) = ZRCS(:) - ZZW1(:,1)
- ZRSS(:) = ZRSS(:) + ZZW1(:,1)
- ZTHS(:) = ZTHS(:) + ZZW1(:,1)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(RCRIMSS))
- END WHERE
-!
-! 5.1.5 perform the linear interpolation of the normalized
-! "XBS"-moment of the incomplete gamma function
-!
- ZVEC1(1:IGRIM) = XGAMINC_RIM2( IVEC2(1:IGRIM)+1 )* ZVEC2(1:IGRIM) &
- - XGAMINC_RIM2( IVEC2(1:IGRIM) )*(ZVEC2(1:IGRIM) - 1.0)
- ZZW(:) = UNPACK( VECTOR=ZVEC1(:),MASK=GRIM,FIELD=0.0 )
-!
-! 5.1.6 riming-conversion of the large sized aggregates into graupeln
-!
-!
- WHERE ( GRIM(:) .AND. (ZRSS(:)>0.0) )
- ZZW1(:,2) = MIN( ZRCS(:), &
- XCRIMSG * ZRCT(:) & ! RCRIMSG
- * ZLBDAS(:)**XEXCRIMSG &
- * ZRHODREF(:)**(-XCEXVT) &
- - ZZW1(:,1) )
- ZZW1(:,3) = MIN( ZRSS(:), &
- XSRIMCG * ZLBDAS(:)**XEXSRIMCG & ! RSRIMCG
- * (1.0 - ZZW(:) )/(PTSTEP*ZRHODREF(:)) )
- ZRCS(:) = ZRCS(:) - ZZW1(:,2)
- ZRSS(:) = ZRSS(:) - ZZW1(:,3)
- ZRGS(:) = ZRGS(:) + ZZW1(:,2)+ZZW1(:,3)
- ZTHS(:) = ZTHS(:) + ZZW1(:,2)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(RCRIMSG))
- END WHERE
- DEALLOCATE(IVEC2)
- DEALLOCATE(IVEC1)
- DEALLOCATE(ZVEC2)
- DEALLOCATE(ZVEC1)
- END IF
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'RIM_BU_RTH')
- IF (LBUDGET_RC) CALL BUDGET ( &
- UNPACK(ZRCS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 7,'RIM_BU_RRC')
- IF (LBUDGET_RS) CALL BUDGET ( &
- UNPACK(ZRSS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 10,'RIM_BU_RRS')
- IF (LBUDGET_RG) CALL BUDGET ( &
- UNPACK(ZRGS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 11,'RIM_BU_RRG')
- DEALLOCATE(GRIM)
-!
-!* 5.2 rain accretion onto the aggregates
-!
- ZZW1(:,2:3) = 0.0
- ALLOCATE(GACC(IMICRO))
- GACC(:) = (ZRRT(:)>XRTMIN(3)) .AND. (ZRST(:)>XRTMIN(5)) .AND. &
- (ZRRS(:)>0.0) .AND. (ZZT(:)<XTT)
- IGACC = COUNT( GACC(:) )
-!
- IF( IGACC>0 ) THEN
-!
-! 5.2.0 allocations
-!
- ALLOCATE(ZVEC1(IGACC))
- ALLOCATE(ZVEC2(IGACC))
- ALLOCATE(ZVEC3(IGACC))
- ALLOCATE(IVEC1(IGACC))
- ALLOCATE(IVEC2(IGACC))
-!
-! 5.2.1 select the (ZLBDAS,ZLBDAR) couplet
-!
- ZVEC1(:) = PACK( ZLBDAS(:),MASK=GACC(:) )
- ZVEC2(:) = PACK( ZLBDAR(:),MASK=GACC(:) )
-!
-! 5.2.2 find the next lower indice for the ZLBDAS and for the ZLBDAR
-! in the geometrical set of (Lbda_s,Lbda_r) couplet use to
-! tabulate the RACCSS-kernel
-!
- ZVEC1(1:IGACC) = MAX( 1.00001, MIN( FLOAT(NACCLBDAS)-0.00001, &
- XACCINTP1S * LOG( ZVEC1(1:IGACC) ) + XACCINTP2S ) )
- IVEC1(1:IGACC) = INT( ZVEC1(1:IGACC) )
- ZVEC1(1:IGACC) = ZVEC1(1:IGACC) - FLOAT( IVEC1(1:IGACC) )
-!
- ZVEC2(1:IGACC) = MAX( 1.00001, MIN( FLOAT(NACCLBDAR)-0.00001, &
- XACCINTP1R * LOG( ZVEC2(1:IGACC) ) + XACCINTP2R ) )
- IVEC2(1:IGACC) = INT( ZVEC2(1:IGACC) )
- ZVEC2(1:IGACC) = ZVEC2(1:IGACC) - FLOAT( IVEC2(1:IGACC) )
-!
-! 5.2.3 perform the bilinear interpolation of the normalized
-! RACCSS-kernel
-!
- DO JJ = 1,IGACC
- ZVEC3(JJ) = ( XKER_RACCSS(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_RACCSS(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * ZVEC1(JJ) &
- - ( XKER_RACCSS(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_RACCSS(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * (ZVEC1(JJ) - 1.0)
- END DO
- ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GACC,FIELD=0.0 )
-!
-! 5.2.4 raindrop accretion on the small sized aggregates
-!
- WHERE ( GACC(:) )
- ZZW1(:,2) = & !! coef of RRACCS
- XFRACCSS*( ZLBDAS(:)**XCXS )*( ZRHODREF(:)**(-XCEXVT-1.) ) &
- *( XLBRACCS1/((ZLBDAS(:)**2) ) + &
- XLBRACCS2/( ZLBDAS(:) * ZLBDAR(:) ) + &
- XLBRACCS3/( (ZLBDAR(:)**2)) )/ZLBDAR(:)**4
- ZZW1(:,4) = MIN( ZRRS(:),ZZW1(:,2)*ZZW(:) ) ! RRACCSS
- ZRRS(:) = ZRRS(:) - ZZW1(:,4)
- ZRSS(:) = ZRSS(:) + ZZW1(:,4)
- ZTHS(:) = ZTHS(:) + ZZW1(:,4)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(RRACCSS))
- END WHERE
-!
-! 5.2.4b perform the bilinear interpolation of the normalized
-! RACCS-kernel
-!
- DO JJ = 1,IGACC
- ZVEC3(JJ) = ( XKER_RACCS(IVEC2(JJ)+1,IVEC1(JJ)+1)* ZVEC1(JJ) &
- - XKER_RACCS(IVEC2(JJ)+1,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
- * ZVEC2(JJ) &
- - ( XKER_RACCS(IVEC2(JJ) ,IVEC1(JJ)+1)* ZVEC1(JJ) &
- - XKER_RACCS(IVEC2(JJ) ,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
- * (ZVEC2(JJ) - 1.0)
- END DO
- ZZW1(:,2) = ZZW1(:,2)*UNPACK( VECTOR=ZVEC3(:),MASK=GACC(:),FIELD=0.0 )
- !! RRACCS!
-! 5.2.5 perform the bilinear interpolation of the normalized
-! SACCRG-kernel
-!
- DO JJ = 1,IGACC
- ZVEC3(JJ) = ( XKER_SACCRG(IVEC2(JJ)+1,IVEC1(JJ)+1)* ZVEC1(JJ) &
- - XKER_SACCRG(IVEC2(JJ)+1,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
- * ZVEC2(JJ) &
- - ( XKER_SACCRG(IVEC2(JJ) ,IVEC1(JJ)+1)* ZVEC1(JJ) &
- - XKER_SACCRG(IVEC2(JJ) ,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
- * (ZVEC2(JJ) - 1.0)
- END DO
- ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GACC,FIELD=0.0 )
-!
-! 5.2.6 raindrop accretion-conversion of the large sized aggregates
-! into graupeln
-!
- WHERE ( GACC(:) .AND. (ZRSS(:)>0.0) )
- ZZW1(:,2) = MAX( MIN( ZRRS(:),ZZW1(:,2)-ZZW1(:,4) ),0.0 ) ! RRACCSG
- END WHERE
- WHERE ( GACC(:) .AND. (ZRSS(:)>0.0) .AND. ZZW1(:,2)>0.0 )
- ZZW1(:,3) = MIN( ZRSS(:),XFSACCRG*ZZW(:)* & ! RSACCRG
- ( ZLBDAS(:)**(XCXS-XBS) )*( ZRHODREF(:)**(-XCEXVT-1.) ) &
- *( XLBSACCR1/((ZLBDAR(:)**2) ) + &
- XLBSACCR2/( ZLBDAR(:) * ZLBDAS(:) ) + &
- XLBSACCR3/( (ZLBDAS(:)**2)) )/ZLBDAR(:) )
- ZRRS(:) = ZRRS(:) - ZZW1(:,2)
- ZRSS(:) = ZRSS(:) - ZZW1(:,3)
- ZRGS(:) = ZRGS(:) + ZZW1(:,2)+ZZW1(:,3)
- ZTHS(:) = ZTHS(:) + ZZW1(:,2)*(ZLSFACT(:)-ZLVFACT(:)) !
- ! f(L_f*(RRACCSG))
- END WHERE
- DEALLOCATE(IVEC2)
- DEALLOCATE(IVEC1)
- DEALLOCATE(ZVEC3)
- DEALLOCATE(ZVEC2)
- DEALLOCATE(ZVEC1)
- END IF
- DEALLOCATE(GACC)
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'ACC_BU_RTH')
- IF (LBUDGET_RR) CALL BUDGET ( &
- UNPACK(ZRRS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 8,'ACC_BU_RRR')
- IF (LBUDGET_RS) CALL BUDGET ( &
- UNPACK(ZRSS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 10,'ACC_BU_RRS')
- IF (LBUDGET_RG) CALL BUDGET ( &
- UNPACK(ZRGS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 11,'ACC_BU_RRG')
-!
-!* 5.3 Conversion-Melting of the aggregates
-!
- ZZW(:) = 0.0
- WHERE( (ZRST(:)>XRTMIN(5)) .AND. (ZRSS(:)>0.0) .AND. (ZZT(:)>XTT) )
- ZZW(:) = ZRVT(:)*ZPRES(:)/((XMV/XMD)+ZRVT(:)) ! Vapor pressure
- ZZW(:) = ZKA(:)*(XTT-ZZT(:)) + &
- ( ZDV(:)*(XLVTT + ( XCPV - XCL ) * ( ZZT(:) - XTT )) &
- *(XESTT-ZZW(:))/(XRV*ZZT(:)) )
-!
-! compute RSMLT
-!
- ZZW(:) = MIN( ZRSS(:), XFSCVMG*MAX( 0.0,( -ZZW(:) * &
- ( X0DEPS* ZLBDAS(:)**XEX0DEPS + &
- X1DEPS*ZCJ(:)*ZLBDAS(:)**XEX1DEPS ) - &
- ( ZZW1(:,1)+ZZW1(:,4) ) * &
- ( ZRHODREF(:)*XCL*(XTT-ZZT(:))) ) / &
- ( ZRHODREF(:)*XLMTT ) ) )
-!
-! note that RSCVMG = RSMLT*XFSCVMG but no heat is exchanged (at the rate RSMLT)
-! because the graupeln produced by this process are still icy!!!
-!
- ZRSS(:) = ZRSS(:) - ZZW(:)
- ZRGS(:) = ZRGS(:) + ZZW(:)
- END WHERE
- IF (LBUDGET_RS) CALL BUDGET ( &
- UNPACK(ZRSS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 10,'CMEL_BU_RRS')
- IF (LBUDGET_RG) CALL BUDGET ( &
- UNPACK(ZRGS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 11,'CMEL_BU_RRG')
-!
- END SUBROUTINE RAIN_ICE_FAST_RS
-!
-!-------------------------------------------------------------------------------
-!
-!
- SUBROUTINE RAIN_ICE_FAST_RG
-!
-!* 0. DECLARATIONS
-! ------------
-!
-IMPLICIT NONE
-!
-!-------------------------------------------------------------------------------
-!
-!* 6.1 rain contact freezing
-!
- ZZW1(:,3:4) = 0.0
- WHERE( (ZRIT(:)>XRTMIN(4)) .AND. (ZRRT(:)>XRTMIN(3)) .AND. &
- (ZRIS(:)>0.0) .AND. (ZRRS(:)>0.0) )
- ZZW1(:,3) = MIN( ZRIS(:),XICFRR * ZRIT(:) & ! RICFRRG
- * ZLBDAR(:)**XEXICFRR &
- * ZRHODREF(:)**(-XCEXVT) )
- ZZW1(:,4) = MIN( ZRRS(:),XRCFRI * ZCIT(:) & ! RRCFRIG
- * ZLBDAR(:)**XEXRCFRI &
- * ZRHODREF(:)**(-XCEXVT-1.) )
- ZRIS(:) = ZRIS(:) - ZZW1(:,3)
- ZRRS(:) = ZRRS(:) - ZZW1(:,4)
- ZRGS(:) = ZRGS(:) + ZZW1(:,3)+ZZW1(:,4)
- ZTHS(:) = ZTHS(:) + ZZW1(:,4)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*RRCFRIG)
- END WHERE
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'CFRZ_BU_RTH')
- IF (LBUDGET_RR) CALL BUDGET ( &
- UNPACK(ZRRS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 8,'CFRZ_BU_RRR')
- IF (LBUDGET_RI) CALL BUDGET ( &
- UNPACK(ZRIS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 9,'CFRZ_BU_RRI')
- IF (LBUDGET_RG) CALL BUDGET ( &
- UNPACK(ZRGS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 11,'CFRZ_BU_RRG')
-!
-!* 6.2 compute the Dry growth case
-!
- ZZW1(:,:) = 0.0
- WHERE( (ZRGT(:)>XRTMIN(6)) .AND. ((ZRCT(:)>XRTMIN(2) .AND. ZRCS(:)>0.0)) )
- ZZW(:) = ZLBDAG(:)**(XCXG-XDG-2.0) * ZRHODREF(:)**(-XCEXVT)
- ZZW1(:,1) = MIN( ZRCS(:),XFCDRYG * ZRCT(:) * ZZW(:) ) ! RCDRYG
- END WHERE
- WHERE( (ZRGT(:)>XRTMIN(6)) .AND. ((ZRIT(:)>XRTMIN(4) .AND. ZRIS(:)>0.0)) )
- ZZW(:) = ZLBDAG(:)**(XCXG-XDG-2.0) * ZRHODREF(:)**(-XCEXVT)
- ZZW1(:,2) = MIN( ZRIS(:),XFIDRYG * EXP( XCOLEXIG*(ZZT(:)-XTT) ) &
- * ZRIT(:) * ZZW(:) ) ! RIDRYG
- END WHERE
-!
-!* 6.2.1 accretion of aggregates on the graupeln
-!
- ALLOCATE(GDRY(IMICRO))
- GDRY(:) = (ZRST(:)>XRTMIN(5)) .AND. (ZRGT(:)>XRTMIN(6)) .AND. (ZRSS(:)>0.0)
- IGDRY = COUNT( GDRY(:) )
-!
- IF( IGDRY>0 ) THEN
-!
-!* 6.2.2 allocations
-!
- ALLOCATE(ZVEC1(IGDRY))
- ALLOCATE(ZVEC2(IGDRY))
- ALLOCATE(ZVEC3(IGDRY))
- ALLOCATE(IVEC1(IGDRY))
- ALLOCATE(IVEC2(IGDRY))
-!
-!* 6.2.3 select the (ZLBDAG,ZLBDAS) couplet
-!
- ZVEC1(:) = PACK( ZLBDAG(:),MASK=GDRY(:) )
- ZVEC2(:) = PACK( ZLBDAS(:),MASK=GDRY(:) )
-!
-!* 6.2.4 find the next lower indice for the ZLBDAG and for the ZLBDAS
-! in the geometrical set of (Lbda_g,Lbda_s) couplet use to
-! tabulate the SDRYG-kernel
-!
- ZVEC1(1:IGDRY) = MAX( 1.00001, MIN( FLOAT(NDRYLBDAG)-0.00001, &
- XDRYINTP1G * LOG( ZVEC1(1:IGDRY) ) + XDRYINTP2G ) )
- IVEC1(1:IGDRY) = INT( ZVEC1(1:IGDRY) )
- ZVEC1(1:IGDRY) = ZVEC1(1:IGDRY) - FLOAT( IVEC1(1:IGDRY) )
-!
- ZVEC2(1:IGDRY) = MAX( 1.00001, MIN( FLOAT(NDRYLBDAS)-0.00001, &
- XDRYINTP1S * LOG( ZVEC2(1:IGDRY) ) + XDRYINTP2S ) )
- IVEC2(1:IGDRY) = INT( ZVEC2(1:IGDRY) )
- ZVEC2(1:IGDRY) = ZVEC2(1:IGDRY) - FLOAT( IVEC2(1:IGDRY) )
-!
-!* 6.2.5 perform the bilinear interpolation of the normalized
-! SDRYG-kernel
-!
- DO JJ = 1,IGDRY
- ZVEC3(JJ) = ( XKER_SDRYG(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_SDRYG(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * ZVEC1(JJ) &
- - ( XKER_SDRYG(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_SDRYG(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * (ZVEC1(JJ) - 1.0)
- END DO
- ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GDRY,FIELD=0.0 )
-!
- WHERE( GDRY(:) )
- ZZW1(:,3) = MIN( ZRSS(:),XFSDRYG*ZZW(:) & ! RSDRYG
- * EXP( XCOLEXSG*(ZZT(:)-XTT) ) &
- *( ZLBDAS(:)**(XCXS-XBS) )*( ZLBDAG(:)**XCXG ) &
- *( ZRHODREF(:)**(-XCEXVT-1.) ) &
- *( XLBSDRYG1/( ZLBDAG(:)**2 ) + &
- XLBSDRYG2/( ZLBDAG(:) * ZLBDAS(:) ) + &
- XLBSDRYG3/( ZLBDAS(:)**2) ) )
- END WHERE
- DEALLOCATE(IVEC2)
- DEALLOCATE(IVEC1)
- DEALLOCATE(ZVEC3)
- DEALLOCATE(ZVEC2)
- DEALLOCATE(ZVEC1)
- END IF
-!
-!* 6.2.6 accretion of raindrops on the graupeln
-!
- GDRY(:) = (ZRRT(:)>XRTMIN(3)) .AND. (ZRGT(:)>XRTMIN(6)) .AND. (ZRRS(:)>0.0)
- IGDRY = COUNT( GDRY(:) )
-!
- IF( IGDRY>0 ) THEN
-!
-!* 6.2.7 allocations
-!
- ALLOCATE(ZVEC1(IGDRY))
- ALLOCATE(ZVEC2(IGDRY))
- ALLOCATE(ZVEC3(IGDRY))
- ALLOCATE(IVEC1(IGDRY))
- ALLOCATE(IVEC2(IGDRY))
-!
-!* 6.2.8 select the (ZLBDAG,ZLBDAR) couplet
-!
- ZVEC1(:) = PACK( ZLBDAG(:),MASK=GDRY(:) )
- ZVEC2(:) = PACK( ZLBDAR(:),MASK=GDRY(:) )
-!
-!* 6.2.9 find the next lower indice for the ZLBDAG and for the ZLBDAR
-! in the geometrical set of (Lbda_g,Lbda_r) couplet use to
-! tabulate the RDRYG-kernel
-!
- ZVEC1(1:IGDRY) = MAX( 1.00001, MIN( FLOAT(NDRYLBDAG)-0.00001, &
- XDRYINTP1G * LOG( ZVEC1(1:IGDRY) ) + XDRYINTP2G ) )
- IVEC1(1:IGDRY) = INT( ZVEC1(1:IGDRY) )
- ZVEC1(1:IGDRY) = ZVEC1(1:IGDRY) - FLOAT( IVEC1(1:IGDRY) )
-!
- ZVEC2(1:IGDRY) = MAX( 1.00001, MIN( FLOAT(NDRYLBDAR)-0.00001, &
- XDRYINTP1R * LOG( ZVEC2(1:IGDRY) ) + XDRYINTP2R ) )
- IVEC2(1:IGDRY) = INT( ZVEC2(1:IGDRY) )
- ZVEC2(1:IGDRY) = ZVEC2(1:IGDRY) - FLOAT( IVEC2(1:IGDRY) )
-!
-!* 6.2.10 perform the bilinear interpolation of the normalized
-! RDRYG-kernel
-!
- DO JJ = 1,IGDRY
- ZVEC3(JJ) = ( XKER_RDRYG(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_RDRYG(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * ZVEC1(JJ) &
- - ( XKER_RDRYG(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_RDRYG(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * (ZVEC1(JJ) - 1.0)
- END DO
- ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GDRY,FIELD=0.0 )
-!
- WHERE( GDRY(:) )
- ZZW1(:,4) = MIN( ZRRS(:),XFRDRYG*ZZW(:) & ! RRDRYG
- *( ZLBDAR(:)**(-4) )*( ZLBDAG(:)**XCXG ) &
- *( ZRHODREF(:)**(-XCEXVT-1.) ) &
- *( XLBRDRYG1/( ZLBDAG(:)**2 ) + &
- XLBRDRYG2/( ZLBDAG(:) * ZLBDAR(:) ) + &
- XLBRDRYG3/( ZLBDAR(:)**2) ) )
- END WHERE
- DEALLOCATE(IVEC2)
- DEALLOCATE(IVEC1)
- DEALLOCATE(ZVEC3)
- DEALLOCATE(ZVEC2)
- DEALLOCATE(ZVEC1)
- END IF
-!
- ZRDRYG(:) = ZZW1(:,1) + ZZW1(:,2) + ZZW1(:,3) + ZZW1(:,4)
- DEALLOCATE(GDRY)
-!
-!* 6.3 compute the Wet growth case
-!
- ZZW(:) = 0.0
- ZRWETG(:) = 0.0
- WHERE( ZRGT(:)>XRTMIN(6) )
- ZZW1(:,5) = MIN( ZRIS(:), &
- ZZW1(:,2) / (XCOLIG*EXP(XCOLEXIG*(ZZT(:)-XTT)) ) ) ! RIWETG
- ZZW1(:,6) = MIN( ZRSS(:), &
- ZZW1(:,3) / (XCOLSG*EXP(XCOLEXSG*(ZZT(:)-XTT)) ) ) ! RSWETG
-!
- ZZW(:) = ZRVT(:)*ZPRES(:)/((XMV/XMD)+ZRVT(:)) ! Vapor pressure
- ZZW(:) = ZKA(:)*(XTT-ZZT(:)) + &
- ( ZDV(:)*(XLVTT + ( XCPV - XCL ) * ( ZZT(:) - XTT )) &
- *(XESTT-ZZW(:))/(XRV*ZZT(:)) )
-!
-! compute RWETG
-!
- ZRWETG(:)=MAX( 0.0, &
- ( ZZW(:) * ( X0DEPG* ZLBDAG(:)**XEX0DEPG + &
- X1DEPG*ZCJ(:)*ZLBDAG(:)**XEX1DEPG ) + &
- ( ZZW1(:,5)+ZZW1(:,6) ) * &
- ( ZRHODREF(:)*(XLMTT+(XCI-XCL)*(XTT-ZZT(:))) ) ) / &
- ( ZRHODREF(:)*(XLMTT-XCL*(XTT-ZZT(:))) ) )
- END WHERE
-!
-!* 6.4 Select Wet or Dry case
-!
- ZZW(:) = 0.0
- IF ( KRR == 7 ) THEN
- WHERE( ZRGT(:)>XRTMIN(6) .AND. ZZT(:)<XTT &
- .AND. & ! Wet
- ZRDRYG(:)>=ZRWETG(:) .AND. ZRWETG(:)>0.0 ) ! case
- ZZW(:) = ZRWETG(:) - ZZW1(:,5) - ZZW1(:,6) ! RCWETG+RRWETG
-!
-! limitation of the available rainwater mixing ratio (RRWETH < RRS !)
-!
- ZZW1(:,7) = MAX( 0.0,MIN( ZZW(:),ZRRS(:)+ZZW1(:,1) ) )
- ZUSW(:) = ZZW1(:,7) / ZZW(:)
- ZZW1(:,5) = ZZW1(:,5)*ZUSW(:)
- ZZW1(:,6) = ZZW1(:,6)*ZUSW(:)
- ZRWETG(:) = ZZW1(:,7) + ZZW1(:,5) + ZZW1(:,6)
-!
- ZRCS(:) = ZRCS(:) - ZZW1(:,1)
- ZRIS(:) = ZRIS(:) - ZZW1(:,5)
- ZRSS(:) = ZRSS(:) - ZZW1(:,6)
-!
-! assume a linear percent of conversion of graupel into hail
-!
- ZRGS(:) = ZRGS(:) + ZRWETG(:) ! Wet growth
- ZZW(:) = ZRGS(:)*ZRDRYG(:)/(ZRWETG(:)+ZRDRYG(:)) ! and
- ZRGS(:) = ZRGS(:) - ZZW(:) ! partial conversion
- ZRHS(:) = ZRHS(:) + ZZW(:) ! of the graupel into hail
-!
- ZRRS(:) = MAX( 0.0,ZRRS(:) - ZZW1(:,7) + ZZW1(:,1) )
- ZTHS(:) = ZTHS(:) + ZZW1(:,7)*(ZLSFACT(:)-ZLVFACT(:))
- ! f(L_f*(RCWETG+RRWETG))
- END WHERE
- ELSE IF( KRR == 6 ) THEN
- WHERE( ZRGT(:)>XRTMIN(6) .AND. ZZT(:)<XTT &
- .AND. & ! Wet
- ZRDRYG(:)>=ZRWETG(:) .AND. ZRWETG(:)>0.0 ) ! case
- ZZW(:) = ZRWETG(:)
- ZRCS(:) = ZRCS(:) - ZZW1(:,1)
- ZRIS(:) = ZRIS(:) - ZZW1(:,5)
- ZRSS(:) = ZRSS(:) - ZZW1(:,6)
- ZRGS(:) = ZRGS(:) + ZZW(:)
-!
- ZRRS(:) = ZRRS(:) - ZZW(:) + ZZW1(:,5) + ZZW1(:,6) + ZZW1(:,1)
- ZTHS(:) = ZTHS(:) + (ZZW(:)-ZZW1(:,5)-ZZW1(:,6))*(ZLSFACT(:)-ZLVFACT(:))
- ! f(L_f*(RCWETG+RRWETG))
- END WHERE
- END IF
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'WETG_BU_RTH')
- IF (LBUDGET_RC) CALL BUDGET ( &
- UNPACK(ZRCS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 7,'WETG_BU_RRC')
- IF (LBUDGET_RR) CALL BUDGET ( &
- UNPACK(ZRRS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 8,'WETG_BU_RRR')
- IF (LBUDGET_RI) CALL BUDGET ( &
- UNPACK(ZRIS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 9,'WETG_BU_RRI')
- IF (LBUDGET_RS) CALL BUDGET ( &
- UNPACK(ZRSS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 10,'WETG_BU_RRS')
- IF (LBUDGET_RG) CALL BUDGET ( &
- UNPACK(ZRGS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 11,'WETG_BU_RRG')
- IF ( KRR == 7 ) THEN
- IF (LBUDGET_RH) CALL BUDGET ( &
- UNPACK(ZRHS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 12,'WETG_BU_RRH')
- END IF
-
-!
- WHERE( ZRGT(:)>XRTMIN(6) .AND. ZZT(:)<XTT &
- .AND. &
- ZRDRYG(:)<ZRWETG(:) .AND. ZRDRYG(:)>0.0 ) ! Dry
- ZRCS(:) = ZRCS(:) - ZZW1(:,1)
- ZRIS(:) = ZRIS(:) - ZZW1(:,2)
- ZRSS(:) = ZRSS(:) - ZZW1(:,3)
- ZRRS(:) = ZRRS(:) - ZZW1(:,4)
- ZRGS(:) = ZRGS(:) + ZRDRYG(:)
- ZTHS(:) = ZTHS(:) + (ZZW1(:,1)+ZZW1(:,4))*(ZLSFACT(:)-ZLVFACT(:)) !
- ! f(L_f*(RCDRYG+RRDRYG))
- END WHERE
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'DRYG_BU_RTH')
- IF (LBUDGET_RC) CALL BUDGET ( &
- UNPACK(ZRCS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 7,'DRYG_BU_RRC')
- IF (LBUDGET_RR) CALL BUDGET ( &
- UNPACK(ZRRS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 8,'DRYG_BU_RRR')
- IF (LBUDGET_RI) CALL BUDGET ( &
- UNPACK(ZRIS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 9,'DRYG_BU_RRI')
- IF (LBUDGET_RS) CALL BUDGET ( &
- UNPACK(ZRSS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 10,'DRYG_BU_RRS')
- IF (LBUDGET_RG) CALL BUDGET ( &
- UNPACK(ZRGS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 11,'DRYG_BU_RRG')
-!
-! WHERE ( ZZT(:) > XTT ) ! RSWETG case only
-! ZRSS(:) = ZRSS(:) - ZZW1(:,6)
-! ZRGS(:) = ZRGS(:) + ZZW1(:,6)
-! END WHERE
-!
-!* 6.5 Melting of the graupeln
-!
- ZZW(:) = 0.0
- WHERE( (ZRGT(:)>XRTMIN(6)) .AND. (ZRGS(:)>0.0) .AND. (ZZT(:)>XTT) )
- ZZW(:) = ZRVT(:)*ZPRES(:)/((XMV/XMD)+ZRVT(:)) ! Vapor pressure
- ZZW(:) = ZKA(:)*(XTT-ZZT(:)) + &
- ( ZDV(:)*(XLVTT + ( XCPV - XCL ) * ( ZZT(:) - XTT )) &
- *(XESTT-ZZW(:))/(XRV*ZZT(:)) )
-!
-! compute RGMLTR
-!
- ZZW(:) = MIN( ZRGS(:), MAX( 0.0,( -ZZW(:) * &
- ( X0DEPG* ZLBDAG(:)**XEX0DEPG + &
- X1DEPG*ZCJ(:)*ZLBDAG(:)**XEX1DEPG ) - &
- ( ZZW1(:,1)+ZZW1(:,4) ) * &
- ( ZRHODREF(:)*XCL*(XTT-ZZT(:))) ) / &
- ( ZRHODREF(:)*XLMTT ) ) )
- ZRRS(:) = ZRRS(:) + ZZW(:)
- ZRGS(:) = ZRGS(:) - ZZW(:)
- ZTHS(:) = ZTHS(:) - ZZW(:)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(-RGMLTR))
- END WHERE
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'GMLT_BU_RTH')
- IF (LBUDGET_RR) CALL BUDGET ( &
- UNPACK(ZRRS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 8,'GMLT_BU_RRR')
- IF (LBUDGET_RG) CALL BUDGET ( &
- UNPACK(ZRGS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 11,'GMLT_BU_RRG')
-!
- END SUBROUTINE RAIN_ICE_FAST_RG
-!
-!-------------------------------------------------------------------------------
-!
-!
- SUBROUTINE RAIN_ICE_FAST_RH
-!
-!* 0. DECLARATIONS
-! ------------
-!
-IMPLICIT NONE
-!
-!-------------------------------------------------------------------------------
-!
- ALLOCATE(GHAIL(IMICRO))
- GHAIL(:) = ZRHT(:)>XRTMIN(7)
- IHAIL = COUNT(GHAIL(:))
-!
- IF( IHAIL>0 ) THEN
-!
-!* 7.2 compute the Wet growth of hail
-!
- WHERE ( GHAIL(:) )
- ZLBDAH(:) = XLBH*( ZRHODREF(:)*MAX( ZRHT(:),XRTMIN(7) ) )**XLBEXH
- END WHERE
-!
- ZZW1(:,:) = 0.0
- WHERE( GHAIL(:) .AND. ((ZRCT(:)>XRTMIN(2) .AND. ZRCS(:)>0.0)) )
- ZZW(:) = ZLBDAH(:)**(XCXH-XDH-2.0) * ZRHODREF(:)**(-XCEXVT)
- ZZW1(:,1) = MIN( ZRCS(:),XFWETH * ZRCT(:) * ZZW(:) ) ! RCWETH
- END WHERE
- WHERE( GHAIL(:) .AND. ((ZRIT(:)>XRTMIN(4) .AND. ZRIS(:)>0.0)) )
- ZZW(:) = ZLBDAH(:)**(XCXH-XDH-2.0) * ZRHODREF(:)**(-XCEXVT)
- ZZW1(:,2) = MIN( ZRIS(:),XFWETH * ZRIT(:) * ZZW(:) ) ! RIWETH
- END WHERE
-!
-!* 7.2.1 accretion of aggregates on the hailstones
-!
- ALLOCATE(GWET(IMICRO))
- GWET(:) = GHAIL(:) .AND. (ZRST(:)>XRTMIN(5) .AND. ZRSS(:)>0.0)
- IGWET = COUNT( GWET(:) )
-!
- IF( IGWET>0 ) THEN
-!
-!* 7.2.2 allocations
-!
- ALLOCATE(ZVEC1(IGWET))
- ALLOCATE(ZVEC2(IGWET))
- ALLOCATE(ZVEC3(IGWET))
- ALLOCATE(IVEC1(IGWET))
- ALLOCATE(IVEC2(IGWET))
-!
-!* 7.2.3 select the (ZLBDAH,ZLBDAS) couplet
-!
- ZVEC1(:) = PACK( ZLBDAH(:),MASK=GWET(:) )
- ZVEC2(:) = PACK( ZLBDAS(:),MASK=GWET(:) )
-!
-!* 7.2.4 find the next lower indice for the ZLBDAG and for the ZLBDAS
-! in the geometrical set of (Lbda_h,Lbda_s) couplet use to
-! tabulate the SWETH-kernel
-!
- ZVEC1(1:IGWET) = MAX( 1.00001, MIN( FLOAT(NWETLBDAH)-0.00001, &
- XWETINTP1H * LOG( ZVEC1(1:IGWET) ) + XWETINTP2H ) )
- IVEC1(1:IGWET) = INT( ZVEC1(1:IGWET) )
- ZVEC1(1:IGWET) = ZVEC1(1:IGWET) - FLOAT( IVEC1(1:IGWET) )
-!
- ZVEC2(1:IGWET) = MAX( 1.00001, MIN( FLOAT(NWETLBDAS)-0.00001, &
- XWETINTP1S * LOG( ZVEC2(1:IGWET) ) + XWETINTP2S ) )
- IVEC2(1:IGWET) = INT( ZVEC2(1:IGWET) )
- ZVEC2(1:IGWET) = ZVEC2(1:IGWET) - FLOAT( IVEC2(1:IGWET) )
-!
-!* 7.2.5 perform the bilinear interpolation of the normalized
-! SWETH-kernel
-!
- DO JJ = 1,IGWET
- ZVEC3(JJ) = ( XKER_SWETH(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_SWETH(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * ZVEC1(JJ) &
- - ( XKER_SWETH(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_SWETH(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * (ZVEC1(JJ) - 1.0)
- END DO
- ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GWET,FIELD=0.0 )
-!
- WHERE( GWET(:) )
- ZZW1(:,3) = MIN( ZRSS(:),XFSWETH*ZZW(:) & ! RSWETH
- *( ZLBDAS(:)**(XCXS-XBS) )*( ZLBDAH(:)**XCXH ) &
- *( ZRHODREF(:)**(-XCEXVT-1.) ) &
- *( XLBSWETH1/( ZLBDAH(:)**2 ) + &
- XLBSWETH2/( ZLBDAH(:) * ZLBDAS(:) ) + &
- XLBSWETH3/( ZLBDAS(:)**2) ) )
- END WHERE
- DEALLOCATE(IVEC2)
- DEALLOCATE(IVEC1)
- DEALLOCATE(ZVEC3)
- DEALLOCATE(ZVEC2)
- DEALLOCATE(ZVEC1)
- END IF
-!
-!* 7.2.6 accretion of graupeln on the hailstones
-!
- GWET(:) = GHAIL(:) .AND. (ZRGT(:)>XRTMIN(6) .AND. ZRGS(:)>0.0)
- IGWET = COUNT( GWET(:) )
-!
- IF( IGWET>0 ) THEN
-!
-!* 7.2.7 allocations
-!
- ALLOCATE(ZVEC1(IGWET))
- ALLOCATE(ZVEC2(IGWET))
- ALLOCATE(ZVEC3(IGWET))
- ALLOCATE(IVEC1(IGWET))
- ALLOCATE(IVEC2(IGWET))
-!
-!* 7.2.8 select the (ZLBDAH,ZLBDAG) couplet
-!
- ZVEC1(:) = PACK( ZLBDAH(:),MASK=GWET(:) )
- ZVEC2(:) = PACK( ZLBDAG(:),MASK=GWET(:) )
-!
-!* 7.2.9 find the next lower indice for the ZLBDAH and for the ZLBDAG
-! in the geometrical set of (Lbda_h,Lbda_g) couplet use to
-! tabulate the GWETH-kernel
-!
- ZVEC1(1:IGWET) = MAX( 1.00001, MIN( FLOAT(NWETLBDAG)-0.00001, &
- XWETINTP1H * LOG( ZVEC1(1:IGWET) ) + XWETINTP2H ) )
- IVEC1(1:IGWET) = INT( ZVEC1(1:IGWET) )
- ZVEC1(1:IGWET) = ZVEC1(1:IGWET) - FLOAT( IVEC1(1:IGWET) )
-!
- ZVEC2(1:IGWET) = MAX( 1.00001, MIN( FLOAT(NWETLBDAG)-0.00001, &
- XWETINTP1G * LOG( ZVEC2(1:IGWET) ) + XWETINTP2G ) )
- IVEC2(1:IGWET) = INT( ZVEC2(1:IGWET) )
- ZVEC2(1:IGWET) = ZVEC2(1:IGWET) - FLOAT( IVEC2(1:IGWET) )
-!
-!* 7.2.10 perform the bilinear interpolation of the normalized
-! GWETH-kernel
-!
- DO JJ = 1,IGWET
- ZVEC3(JJ) = ( XKER_GWETH(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_GWETH(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * ZVEC1(JJ) &
- - ( XKER_GWETH(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_GWETH(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * (ZVEC1(JJ) - 1.0)
- END DO
- ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GWET,FIELD=0.0 )
-!
- WHERE( GWET(:) )
- ZZW1(:,5) = MAX(MIN( ZRGS(:),XFGWETH*ZZW(:) & ! RGWETH
- *( ZLBDAG(:)**(XCXG-XBG) )*( ZLBDAH(:)**XCXH ) &
- *( ZRHODREF(:)**(-XCEXVT-1.) ) &
- *( XLBGWETH1/( ZLBDAH(:)**2 ) + &
- XLBGWETH2/( ZLBDAH(:) * ZLBDAG(:) ) + &
- XLBGWETH3/( ZLBDAG(:)**2) ) ),0. )
- END WHERE
- DEALLOCATE(IVEC2)
- DEALLOCATE(IVEC1)
- DEALLOCATE(ZVEC3)
- DEALLOCATE(ZVEC2)
- DEALLOCATE(ZVEC1)
- END IF
- DEALLOCATE(GWET)
-!
-!* 7.3 compute the Wet growth of hail
-!
- ZZW(:) = 0.0
- WHERE( GHAIL(:) .AND. ZZT(:)<XTT )
- ZZW(:) = ZRVT(:)*ZPRES(:)/((XMV/XMD)+ZRVT(:)) ! Vapor pressure
- ZZW(:) = ZKA(:)*(XTT-ZZT(:)) + &
- ( ZDV(:)*(XLVTT + ( XCPV - XCL ) * ( ZZT(:) - XTT )) &
- *(XESTT-ZZW(:))/(XRV*ZZT(:)) )
-!
-! compute RWETH
-!
- ZZW(:) = MAX(0., ( ZZW(:) * ( X0DEPH* ZLBDAH(:)**XEX0DEPH + &
- X1DEPH*ZCJ(:)*ZLBDAH(:)**XEX1DEPH ) + &
- ( ZZW1(:,2)+ZZW1(:,3)+ZZW1(:,5) ) * &
- ( ZRHODREF(:)*(XLMTT+(XCI-XCL)*(XTT-ZZT(:))) ) ) / &
- ( ZRHODREF(:)*(XLMTT-XCL*(XTT-ZZT(:))) ) )
-!
- ZZW1(:,6) = MAX( ZZW(:) - ZZW1(:,2) - ZZW1(:,3) - ZZW1(:,5),0.) ! RCWETH+RRWETH
- END WHERE
- WHERE ( GHAIL(:) .AND. ZZT(:)<XTT .AND. ZZW1(:,6)/=0.)
-!
-! limitation of the available rainwater mixing ratio (RRWETH < RRS !)
-!
- ZZW1(:,4) = MAX( 0.0,MIN( ZZW1(:,6),ZRRS(:)+ZZW1(:,1) ) )
- ZUSW(:) = ZZW1(:,4) / ZZW1(:,6)
- ZZW1(:,2) = ZZW1(:,2)*ZUSW(:)
- ZZW1(:,3) = ZZW1(:,3)*ZUSW(:)
- ZZW1(:,5) = ZZW1(:,5)*ZUSW(:)
- ZZW(:) = ZZW1(:,4) + ZZW1(:,2) + ZZW1(:,3) + ZZW1(:,5)
-!
-!* 7.1.6 integrate the Wet growth of hail
-!
- ZRCS(:) = ZRCS(:) - ZZW1(:,1)
- ZRIS(:) = ZRIS(:) - ZZW1(:,2)
- ZRSS(:) = ZRSS(:) - ZZW1(:,3)
- ZRGS(:) = ZRGS(:) - ZZW1(:,5)
- ZRHS(:) = ZRHS(:) + ZZW(:)
- ZRRS(:) = MAX( 0.0,ZRRS(:) - ZZW1(:,4) + ZZW1(:,1) )
- ZTHS(:) = ZTHS(:) + ZZW1(:,4)*(ZLSFACT(:)-ZLVFACT(:))
- ! f(L_f*(RCWETH+RRWETH))
- END WHERE
- END IF
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'WETH_BU_RTH')
- IF (LBUDGET_RC) CALL BUDGET ( &
- UNPACK(ZRCS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 7,'WETH_BU_RRC')
- IF (LBUDGET_RR) CALL BUDGET ( &
- UNPACK(ZRRS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 8,'WETH_BU_RRR')
- IF (LBUDGET_RI) CALL BUDGET ( &
- UNPACK(ZRIS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 9,'WETH_BU_RRI')
- IF (LBUDGET_RS) CALL BUDGET ( &
- UNPACK(ZRSS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 10,'WETH_BU_RRS')
- IF (LBUDGET_RG) CALL BUDGET ( &
- UNPACK(ZRGS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 11,'WETH_BU_RRG')
- IF (LBUDGET_RH) CALL BUDGET ( &
- UNPACK(ZRHS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 12,'WETH_BU_RRH')
-!
-!
-! ici LRECONVH et un flag pour autoriser une reconversion partielle de
-!la grele en gresil
-!
-! IF( IHAIL>0 ) THEN
-!
-!UPG_CD
-!
-!
-!* 7.45 Conversion of the hailstones into graupel
-!
-! XDUMMY6=0.01E-3
-! XDUMMY7=0.001E-3
-! WHERE( ZRHT(:)<XDUMMY6 .AND. ZRCT(:)<XDUMMY7 .AND. ZZT(:)<XTT )
-! ZZW(:) = MIN( 1.0,MAX( 0.0,1.0-(ZRCT(:)/XDUMMY7) ) )
-!
-! assume a linear percent conversion rate of hail into graupel
-!
-! ZZW(:) = ZRHS(:)*ZZW(:)
-! ZRGS(:) = ZRGS(:) + ZZW(:) ! partial conversion
-! ZRHS(:) = ZRHS(:) - ZZW(:) ! of hail into graupel
-!
-! END WHERE
-! END IF
-
-
-
-
- IF( IHAIL>0 ) THEN
-!
-!* 7.5 Melting of the hailstones
-!
- ZZW(:) = 0.0
- WHERE( GHAIL(:) .AND. (ZRHS(:)>0.0) .AND. (ZZT(:)>XTT) )
- ZZW(:) = ZRVT(:)*ZPRES(:)/((XMV/XMD)+ZRVT(:)) ! Vapor pressure
- ZZW(:) = ZKA(:)*(XTT-ZZT(:)) + &
- ( ZDV(:)*(XLVTT + ( XCPV - XCL ) * ( ZZT(:) - XTT )) &
- *(XESTT-ZZW(:))/(XRV*ZZT(:)) )
-!
-! compute RHMLTR
-!
- ZZW(:) = MIN( ZRHS(:), MAX( 0.0,( -ZZW(:) * &
- ( X0DEPH* ZLBDAH(:)**XEX0DEPH + &
- X1DEPH*ZCJ(:)*ZLBDAH(:)**XEX1DEPH ) - &
- ZZW1(:,6)*( ZRHODREF(:)*XCL*(XTT-ZZT(:))) ) / &
- ( ZRHODREF(:)*XLMTT ) ) )
- ZRRS(:) = ZRRS(:) + ZZW(:)
- ZRHS(:) = ZRHS(:) - ZZW(:)
- ZTHS(:) = ZTHS(:) - ZZW(:)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(-RHMLTR))
- END WHERE
- END IF
- DEALLOCATE(GHAIL)
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'HMLT_BU_RTH')
- IF (LBUDGET_RR) CALL BUDGET ( &
- UNPACK(ZRRS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 8,'HMLT_BU_RRR')
- IF (LBUDGET_RH) CALL BUDGET ( &
- UNPACK(ZRHS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 12,'HMLT_BU_RRH')
-!
- END SUBROUTINE RAIN_ICE_FAST_RH
-!
-!-------------------------------------------------------------------------------
-!
-!
- SUBROUTINE RAIN_ICE_FAST_RI
-!
-!* 0. DECLARATIONS
-! ------------
-!
-IMPLICIT NONE
-!
-!-------------------------------------------------------------------------------
-!
-!* 7.1 cloud ice melting
-!
- ZZW(:) = 0.0
- WHERE( (ZRIS(:)>0.0) .AND. (ZZT(:)>XTT) )
- ZZW(:) = ZRIS(:)
- ZRCS(:) = ZRCS(:) + ZRIS(:)
- ZTHS(:) = ZTHS(:) - ZRIS(:)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(-RIMLTC))
- ZRIS(:) = 0.0
- ZCIT(:) = 0.0
- END WHERE
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'IMLT_BU_RTH')
- IF (LBUDGET_RC) CALL BUDGET ( &
- UNPACK(ZRCS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 7,'IMLT_BU_RRC')
- IF (LBUDGET_RI) CALL BUDGET ( &
- UNPACK(ZRIS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 9,'IMLT_BU_RRI')
-!
-!* 7.2 Bergeron-Findeisen effect: RCBERI
-!
- ZZW(:) = 0.0
- WHERE( (ZRCS(:)>0.0) .AND. (ZSSI(:)>0.0) .AND. &
- (ZRIT(:)>XRTMIN(4)) .AND. (ZCIT(:)>0.0) )
- ZZW(:) = MIN(1.E8,XLBI*( ZRHODREF(:)*ZRIT(:)/ZCIT(:) )**XLBEXI) ! Lbda_i
- ZZW(:) = MIN( ZRCS(:),( ZSSI(:) / (ZRHODREF(:)*ZAI(:)) ) * ZCIT(:) * &
- ( X0DEPI/ZZW(:) + X2DEPI*ZCJ(:)*ZCJ(:)/ZZW(:)**(XDI+2.0) ) )
- ZRCS(:) = ZRCS(:) - ZZW(:)
- ZRIS(:) = ZRIS(:) + ZZW(:)
- ZTHS(:) = ZTHS(:) + ZZW(:)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(RCBERI))
- END WHERE
- IF (LBUDGET_TH) CALL BUDGET ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'BERFI_BU_RTH')
- IF (LBUDGET_RC) CALL BUDGET ( &
- UNPACK(ZRCS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 7,'BERFI_BU_RRC')
- IF (LBUDGET_RI) CALL BUDGET ( &
- UNPACK(ZRIS(:)*ZRHODJ(:),MASK=GMICRO(:,:,:),FIELD=0.0), &
- 9,'BERFI_BU_RRI')
-!
- END SUBROUTINE RAIN_ICE_FAST_RI
-!
-SUBROUTINE RAINFR_VERT(ZPRFR, ZRR)
-
-IMPLICIT NONE
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: ZPRFR !Precipitation fraction
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZRR !Rain field
-!
-!-------------------------------------------------------------------------------
-INTEGER :: JI, JJ, JK
-!
-DO JI = IIB,IIE
- DO JJ = IJB, IJE
- ZPRFR(JI,JJ,IKE)=0.
- DO JK=IKE-KKL, IKB, -KKL
- IF (ZRR(JI,JJ,JK) .GT. XRTMIN(3)) THEN
- ZPRFR(JI,JJ,JK)=MAX(ZPRFR(JI,JJ,JK),ZPRFR(JI,JJ,JK+KKL))
- IF (ZPRFR(JI,JJ,JK)==0) THEN
- ZPRFR(JI,JJ,JK)=1.
- END IF
- ELSE
- ZPRFR(JI,JJ,JK)=0.
- END IF
- END DO
- END DO
-END DO
-!
-!
-END SUBROUTINE RAINFR_VERT
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
- FUNCTION COUNTJV(LTAB,I1,I2,I3) RESULT(IC)
-!
-!* 0. DECLARATIONS
-! ------------
-!
-IMPLICIT NONE
-!
-!* 0.2 declaration of local variables
-!
-!
-LOGICAL, DIMENSION(:,:,:) :: LTAB ! Mask
-INTEGER, DIMENSION(:) :: I1,I2,I3 ! Used to replace the COUNT and PACK
-INTEGER :: JI,JJ,JK,IC
-!
-!-------------------------------------------------------------------------------
-!
-IC = 0
-DO JK = 1,SIZE(LTAB,3)
- DO JJ = 1,SIZE(LTAB,2)
- DO JI = 1,SIZE(LTAB,1)
- IF( LTAB(JI,JJ,JK) ) THEN
- IC = IC +1
- I1(IC) = JI
- I2(IC) = JJ
- I3(IC) = JK
- END IF
- END DO
- END DO
+ END DO
END DO
!
END FUNCTION COUNTJV
- FUNCTION COUNTJV2(LTAB,I1,I2) RESULT(IC)
-!
-!* 0. DECLARATIONS
-! ------------
-!
-IMPLICIT NONE
-!
-!* 0.2 declaration of local variables
-!
-!
-LOGICAL, DIMENSION(:,:) :: LTAB ! Mask
-INTEGER, DIMENSION(:) :: I1,I2 ! Used to replace the COUNT and PACK
-INTEGER :: JI,JJ,IC
-!
-!-------------------------------------------------------------------------------
-!
-IC = 0
-DO JJ = 1,SIZE(LTAB,2)
- DO JI = 1,SIZE(LTAB,1)
- IF( LTAB(JI,JJ) ) THEN
- IC = IC +1
- I1(IC) = JI
- I2(IC) = JJ
- END IF
- END DO
-END DO
-!
-END FUNCTION COUNTJV2
!
!-------------------------------------------------------------------------------
!
diff --git a/src/MNH/rain_ice_fast_rg.f90 b/src/MNH/rain_ice_fast_rg.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1829f8ca02c85b9718e63e4499fd344ec08f09f6
--- /dev/null
+++ b/src/MNH/rain_ice_fast_rg.f90
@@ -0,0 +1,422 @@
+!MNH_LIC Copyright 1995-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! Modifications:
+! P. Wautelet 25/02/2019: split rain_ice (cleaner and easier to maintain/debug)
+!-----------------------------------------------------------------
+MODULE MODE_RAIN_ICE_FAST_RG
+
+ IMPLICIT NONE
+
+ PRIVATE
+
+ PUBLIC :: RAIN_ICE_FAST_RG
+
+CONTAINS
+
+SUBROUTINE RAIN_ICE_FAST_RG(KRR, OMICRO, PRHODREF, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, PCIT, &
+ PRHODJ, PPRES, PZT, PLBDAR, PLBDAS, PLBDAG, PLSFACT, PLVFACT, &
+ PCJ, PKA, PDV, PRHODJ3D, PTHS3D, PRCS, PRRS, PRIS, PRSS, PRGS, PRHS, PTHS, &
+ PUSW, PRDRYG, PRWETG)
+
+!
+!* 0. DECLARATIONS
+! ------------
+!
+use MODD_BUDGET, only: LBUDGET_RC, LBUDGET_RG, LBUDGET_RH, LBUDGET_RI, LBUDGET_RR, LBUDGET_RS, LBUDGET_TH
+use MODD_CST, only: XCI, XCL, XCPV, XESTT, XLMTT, XLVTT, XMD, XMV, XRV, XTT
+use MODD_RAIN_ICE_DESCR, only: XBS, XCEXVT, XCXG, XCXS, XDG, XRTMIN
+use MODD_RAIN_ICE_PARAM, only: NDRYLBDAG, NDRYLBDAR, NDRYLBDAS, X0DEPG, X1DEPG, XCOLEXIG, XCOLEXSG, XCOLIG, XCOLSG, XDRYINTP1G, &
+ XDRYINTP1R, XDRYINTP1S, XDRYINTP2G, XDRYINTP2R, XDRYINTP2S, XEX0DEPG, XEX1DEPG, XEXICFRR, &
+ XEXRCFRI, XFCDRYG, XFIDRYG, XFRDRYG, XFSDRYG, XICFRR, XKER_RDRYG, XKER_SDRYG, XLBRDRYG1, &
+ XLBRDRYG2, XLBRDRYG3, XLBSDRYG1, XLBSDRYG2, XLBSDRYG3, XRCFRI
+!
+use MODI_BUDGET
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+INTEGER, INTENT(IN) :: KRR ! Number of moist variables
+LOGICAL, DIMENSION(:,:,:), intent(in) :: OMICRO ! Test where to compute all processes
+REAL, DIMENSION(:), intent(in) :: PRHODREF ! RHO Dry REFerence
+REAL, DIMENSION(:), intent(in) :: PRVT ! Water vapor m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRCT ! Cloud water m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRRT ! Rain water m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRIT ! Pristine ice m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRST ! Snow/aggregate m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRGT ! Graupel m.r. at t
+REAL, DIMENSION(:), intent(in) :: PCIT ! Pristine ice conc. at t
+REAL, DIMENSION(:), intent(in) :: PRHODJ ! RHO times Jacobian
+REAL, DIMENSION(:), intent(in) :: PPRES ! Pressure
+REAL, DIMENSION(:), intent(in) :: PZT ! Temperature
+REAL, DIMENSION(:), intent(in) :: PLBDAR ! Slope parameter of the raindrop distribution
+REAL, DIMENSION(:), intent(in) :: PLBDAS ! Slope parameter of the aggregate distribution
+REAL, DIMENSION(:), intent(in) :: PLBDAG ! Slope parameter of the graupel distribution
+REAL, DIMENSION(:), intent(in) :: PLSFACT ! L_s/(Pi_ref*C_ph)
+REAL, DIMENSION(:), intent(in) :: PLVFACT ! L_v/(Pi_ref*C_ph)
+REAL, DIMENSION(:), intent(in) :: PCJ ! Function to compute the ventilation coefficient
+REAL, DIMENSION(:), intent(in) :: PKA ! Thermal conductivity of the air
+REAL, DIMENSION(:), intent(in) :: PDV ! Diffusivity of water vapor in the air
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ3D ! Dry density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHS3D ! Theta source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRSS ! Snow/aggregate m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRGS ! Graupel m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRHS ! Hail m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PTHS ! Theta source
+REAL, DIMENSION(:), intent(inout) :: PUSW ! Undersaturation over water
+REAL, DIMENSION(:), intent(out) :: PRDRYG ! Dry growth rate of the graupeln
+REAL, DIMENSION(:), intent(out) :: PRWETG ! Wet growth rate of the graupeln
+!
+!* 0.2 declaration of local variables
+!
+INTEGER :: IGDRY
+INTEGER :: JJ
+INTEGER, DIMENSION(:), ALLOCATABLE :: IVEC1, IVEC2 ! Vectors of indices for interpolations
+LOGICAL, DIMENSION(size(PRHODREF)) :: GDRY ! Test where to compute dry growth
+REAL, DIMENSION(size(PRHODREF)) :: ZZW ! Work array
+REAL, DIMENSION(:), ALLOCATABLE :: ZVEC1,ZVEC2,ZVEC3 ! Work vectors for interpolations
+REAL, DIMENSION(size(PRHODREF),7) :: ZZW1 ! Work arrays
+!
+!-------------------------------------------------------------------------------
+!
+!* 6.1 rain contact freezing
+!
+ ZZW1(:,3:4) = 0.0
+ WHERE( (PRIT(:)>XRTMIN(4)) .AND. (PRRT(:)>XRTMIN(3)) .AND. &
+ (PRIS(:)>0.0) .AND. (PRRS(:)>0.0) )
+ ZZW1(:,3) = MIN( PRIS(:),XICFRR * PRIT(:) & ! RICFRRG
+ * PLBDAR(:)**XEXICFRR &
+ * PRHODREF(:)**(-XCEXVT) )
+ ZZW1(:,4) = MIN( PRRS(:),XRCFRI * PCIT(:) & ! RRCFRIG
+ * PLBDAR(:)**XEXRCFRI &
+ * PRHODREF(:)**(-XCEXVT-1.) )
+ PRIS(:) = PRIS(:) - ZZW1(:,3)
+ PRRS(:) = PRRS(:) - ZZW1(:,4)
+ PRGS(:) = PRGS(:) + ZZW1(:,3)+ZZW1(:,4)
+ PTHS(:) = PTHS(:) + ZZW1(:,4)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*RRCFRIG)
+ END WHERE
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:), &
+ 4,'CFRZ_BU_RTH')
+ IF (LBUDGET_RR) CALL BUDGET ( &
+ UNPACK(PRRS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 8,'CFRZ_BU_RRR')
+ IF (LBUDGET_RI) CALL BUDGET ( &
+ UNPACK(PRIS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 9,'CFRZ_BU_RRI')
+ IF (LBUDGET_RG) CALL BUDGET ( &
+ UNPACK(PRGS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 11,'CFRZ_BU_RRG')
+!
+!* 6.2 compute the Dry growth case
+!
+ ZZW1(:,:) = 0.0
+ WHERE( (PRGT(:)>XRTMIN(6)) .AND. ((PRCT(:)>XRTMIN(2) .AND. PRCS(:)>0.0)) )
+ ZZW(:) = PLBDAG(:)**(XCXG-XDG-2.0) * PRHODREF(:)**(-XCEXVT)
+ ZZW1(:,1) = MIN( PRCS(:),XFCDRYG * PRCT(:) * ZZW(:) ) ! RCDRYG
+ END WHERE
+ WHERE( (PRGT(:)>XRTMIN(6)) .AND. ((PRIT(:)>XRTMIN(4) .AND. PRIS(:)>0.0)) )
+ ZZW(:) = PLBDAG(:)**(XCXG-XDG-2.0) * PRHODREF(:)**(-XCEXVT)
+ ZZW1(:,2) = MIN( PRIS(:),XFIDRYG * EXP( XCOLEXIG*(PZT(:)-XTT) ) &
+ * PRIT(:) * ZZW(:) ) ! RIDRYG
+ END WHERE
+!
+!* 6.2.1 accretion of aggregates on the graupeln
+!
+ GDRY(:) = (PRST(:)>XRTMIN(5)) .AND. (PRGT(:)>XRTMIN(6)) .AND. (PRSS(:)>0.0)
+ IGDRY = COUNT( GDRY(:) )
+!
+ IF( IGDRY>0 ) THEN
+!
+!* 6.2.2 allocations
+!
+ ALLOCATE(ZVEC1(IGDRY))
+ ALLOCATE(ZVEC2(IGDRY))
+ ALLOCATE(ZVEC3(IGDRY))
+ ALLOCATE(IVEC1(IGDRY))
+ ALLOCATE(IVEC2(IGDRY))
+!
+!* 6.2.3 select the (PLBDAG,PLBDAS) couplet
+!
+ ZVEC1(:) = PACK( PLBDAG(:),MASK=GDRY(:) )
+ ZVEC2(:) = PACK( PLBDAS(:),MASK=GDRY(:) )
+!
+!* 6.2.4 find the next lower indice for the PLBDAG and for the PLBDAS
+! in the geometrical set of (Lbda_g,Lbda_s) couplet use to
+! tabulate the SDRYG-kernel
+!
+ ZVEC1(1:IGDRY) = MAX( 1.00001, MIN( FLOAT(NDRYLBDAG)-0.00001, &
+ XDRYINTP1G * LOG( ZVEC1(1:IGDRY) ) + XDRYINTP2G ) )
+ IVEC1(1:IGDRY) = INT( ZVEC1(1:IGDRY) )
+ ZVEC1(1:IGDRY) = ZVEC1(1:IGDRY) - FLOAT( IVEC1(1:IGDRY) )
+!
+ ZVEC2(1:IGDRY) = MAX( 1.00001, MIN( FLOAT(NDRYLBDAS)-0.00001, &
+ XDRYINTP1S * LOG( ZVEC2(1:IGDRY) ) + XDRYINTP2S ) )
+ IVEC2(1:IGDRY) = INT( ZVEC2(1:IGDRY) )
+ ZVEC2(1:IGDRY) = ZVEC2(1:IGDRY) - FLOAT( IVEC2(1:IGDRY) )
+!
+!* 6.2.5 perform the bilinear interpolation of the normalized
+! SDRYG-kernel
+!
+ DO JJ = 1,IGDRY
+ ZVEC3(JJ) = ( XKER_SDRYG(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
+ - XKER_SDRYG(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
+ * ZVEC1(JJ) &
+ - ( XKER_SDRYG(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
+ - XKER_SDRYG(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
+ * (ZVEC1(JJ) - 1.0)
+ END DO
+ ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GDRY,FIELD=0.0 )
+!
+ WHERE( GDRY(:) )
+ ZZW1(:,3) = MIN( PRSS(:),XFSDRYG*ZZW(:) & ! RSDRYG
+ * EXP( XCOLEXSG*(PZT(:)-XTT) ) &
+ *( PLBDAS(:)**(XCXS-XBS) )*( PLBDAG(:)**XCXG ) &
+ *( PRHODREF(:)**(-XCEXVT-1.) ) &
+ *( XLBSDRYG1/( PLBDAG(:)**2 ) + &
+ XLBSDRYG2/( PLBDAG(:) * PLBDAS(:) ) + &
+ XLBSDRYG3/( PLBDAS(:)**2) ) )
+ END WHERE
+ DEALLOCATE(IVEC2)
+ DEALLOCATE(IVEC1)
+ DEALLOCATE(ZVEC3)
+ DEALLOCATE(ZVEC2)
+ DEALLOCATE(ZVEC1)
+ END IF
+!
+!* 6.2.6 accretion of raindrops on the graupeln
+!
+ GDRY(:) = (PRRT(:)>XRTMIN(3)) .AND. (PRGT(:)>XRTMIN(6)) .AND. (PRRS(:)>0.0)
+ IGDRY = COUNT( GDRY(:) )
+!
+ IF( IGDRY>0 ) THEN
+!
+!* 6.2.7 allocations
+!
+ ALLOCATE(ZVEC1(IGDRY))
+ ALLOCATE(ZVEC2(IGDRY))
+ ALLOCATE(ZVEC3(IGDRY))
+ ALLOCATE(IVEC1(IGDRY))
+ ALLOCATE(IVEC2(IGDRY))
+!
+!* 6.2.8 select the (PLBDAG,PLBDAR) couplet
+!
+ ZVEC1(:) = PACK( PLBDAG(:),MASK=GDRY(:) )
+ ZVEC2(:) = PACK( PLBDAR(:),MASK=GDRY(:) )
+!
+!* 6.2.9 find the next lower indice for the PLBDAG and for the PLBDAR
+! in the geometrical set of (Lbda_g,Lbda_r) couplet use to
+! tabulate the RDRYG-kernel
+!
+ ZVEC1(1:IGDRY) = MAX( 1.00001, MIN( FLOAT(NDRYLBDAG)-0.00001, &
+ XDRYINTP1G * LOG( ZVEC1(1:IGDRY) ) + XDRYINTP2G ) )
+ IVEC1(1:IGDRY) = INT( ZVEC1(1:IGDRY) )
+ ZVEC1(1:IGDRY) = ZVEC1(1:IGDRY) - FLOAT( IVEC1(1:IGDRY) )
+!
+ ZVEC2(1:IGDRY) = MAX( 1.00001, MIN( FLOAT(NDRYLBDAR)-0.00001, &
+ XDRYINTP1R * LOG( ZVEC2(1:IGDRY) ) + XDRYINTP2R ) )
+ IVEC2(1:IGDRY) = INT( ZVEC2(1:IGDRY) )
+ ZVEC2(1:IGDRY) = ZVEC2(1:IGDRY) - FLOAT( IVEC2(1:IGDRY) )
+!
+!* 6.2.10 perform the bilinear interpolation of the normalized
+! RDRYG-kernel
+!
+ DO JJ = 1,IGDRY
+ ZVEC3(JJ) = ( XKER_RDRYG(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
+ - XKER_RDRYG(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
+ * ZVEC1(JJ) &
+ - ( XKER_RDRYG(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
+ - XKER_RDRYG(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
+ * (ZVEC1(JJ) - 1.0)
+ END DO
+ ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GDRY,FIELD=0.0 )
+!
+ WHERE( GDRY(:) )
+ ZZW1(:,4) = MIN( PRRS(:),XFRDRYG*ZZW(:) & ! RRDRYG
+ *( PLBDAR(:)**(-4) )*( PLBDAG(:)**XCXG ) &
+ *( PRHODREF(:)**(-XCEXVT-1.) ) &
+ *( XLBRDRYG1/( PLBDAG(:)**2 ) + &
+ XLBRDRYG2/( PLBDAG(:) * PLBDAR(:) ) + &
+ XLBRDRYG3/( PLBDAR(:)**2) ) )
+ END WHERE
+ DEALLOCATE(IVEC2)
+ DEALLOCATE(IVEC1)
+ DEALLOCATE(ZVEC3)
+ DEALLOCATE(ZVEC2)
+ DEALLOCATE(ZVEC1)
+ END IF
+!
+ PRDRYG(:) = ZZW1(:,1) + ZZW1(:,2) + ZZW1(:,3) + ZZW1(:,4)
+!
+!* 6.3 compute the Wet growth case
+!
+ ZZW(:) = 0.0
+ PRWETG(:) = 0.0
+ WHERE( PRGT(:)>XRTMIN(6) )
+ ZZW1(:,5) = MIN( PRIS(:), &
+ ZZW1(:,2) / (XCOLIG*EXP(XCOLEXIG*(PZT(:)-XTT)) ) ) ! RIWETG
+ ZZW1(:,6) = MIN( PRSS(:), &
+ ZZW1(:,3) / (XCOLSG*EXP(XCOLEXSG*(PZT(:)-XTT)) ) ) ! RSWETG
+!
+ ZZW(:) = PRVT(:)*PPRES(:)/((XMV/XMD)+PRVT(:)) ! Vapor pressure
+ ZZW(:) = PKA(:)*(XTT-PZT(:)) + &
+ ( PDV(:)*(XLVTT + ( XCPV - XCL ) * ( PZT(:) - XTT )) &
+ *(XESTT-ZZW(:))/(XRV*PZT(:)) )
+!
+! compute RWETG
+!
+ PRWETG(:)=MAX( 0.0, &
+ ( ZZW(:) * ( X0DEPG* PLBDAG(:)**XEX0DEPG + &
+ X1DEPG*PCJ(:)*PLBDAG(:)**XEX1DEPG ) + &
+ ( ZZW1(:,5)+ZZW1(:,6) ) * &
+ ( PRHODREF(:)*(XLMTT+(XCI-XCL)*(XTT-PZT(:))) ) ) / &
+ ( PRHODREF(:)*(XLMTT-XCL*(XTT-PZT(:))) ) )
+ END WHERE
+!
+!* 6.4 Select Wet or Dry case
+!
+ ZZW(:) = 0.0
+ IF ( KRR == 7 ) THEN
+ WHERE( PRGT(:)>XRTMIN(6) .AND. PZT(:)<XTT &
+ .AND. & ! Wet
+ PRDRYG(:)>=PRWETG(:) .AND. PRWETG(:)>0.0 ) ! case
+ ZZW(:) = PRWETG(:) - ZZW1(:,5) - ZZW1(:,6) ! RCWETG+RRWETG
+!
+! limitation of the available rainwater mixing ratio (RRWETH < RRS !)
+!
+ ZZW1(:,7) = MAX( 0.0,MIN( ZZW(:),PRRS(:)+ZZW1(:,1) ) )
+ PUSW(:) = ZZW1(:,7) / ZZW(:)
+ ZZW1(:,5) = ZZW1(:,5)*PUSW(:)
+ ZZW1(:,6) = ZZW1(:,6)*PUSW(:)
+ PRWETG(:) = ZZW1(:,7) + ZZW1(:,5) + ZZW1(:,6)
+!
+ PRCS(:) = PRCS(:) - ZZW1(:,1)
+ PRIS(:) = PRIS(:) - ZZW1(:,5)
+ PRSS(:) = PRSS(:) - ZZW1(:,6)
+!
+! assume a linear percent of conversion of graupel into hail
+!
+ PRGS(:) = PRGS(:) + PRWETG(:) ! Wet growth
+ ZZW(:) = PRGS(:)*PRDRYG(:)/(PRWETG(:)+PRDRYG(:)) ! and
+ PRGS(:) = PRGS(:) - ZZW(:) ! partial conversion
+ PRHS(:) = PRHS(:) + ZZW(:) ! of the graupel into hail
+!
+ PRRS(:) = MAX( 0.0,PRRS(:) - ZZW1(:,7) + ZZW1(:,1) )
+ PTHS(:) = PTHS(:) + ZZW1(:,7)*(PLSFACT(:)-PLVFACT(:))
+ ! f(L_f*(RCWETG+RRWETG))
+ END WHERE
+ ELSE IF( KRR == 6 ) THEN
+ WHERE( PRGT(:)>XRTMIN(6) .AND. PZT(:)<XTT &
+ .AND. & ! Wet
+ PRDRYG(:)>=PRWETG(:) .AND. PRWETG(:)>0.0 ) ! case
+ ZZW(:) = PRWETG(:)
+ PRCS(:) = PRCS(:) - ZZW1(:,1)
+ PRIS(:) = PRIS(:) - ZZW1(:,5)
+ PRSS(:) = PRSS(:) - ZZW1(:,6)
+ PRGS(:) = PRGS(:) + ZZW(:)
+!
+ PRRS(:) = PRRS(:) - ZZW(:) + ZZW1(:,5) + ZZW1(:,6) + ZZW1(:,1)
+ PTHS(:) = PTHS(:) + (ZZW(:)-ZZW1(:,5)-ZZW1(:,6))*(PLSFACT(:)-PLVFACT(:))
+ ! f(L_f*(RCWETG+RRWETG))
+ END WHERE
+ END IF
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:), &
+ 4,'WETG_BU_RTH')
+ IF (LBUDGET_RC) CALL BUDGET ( &
+ UNPACK(PRCS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 7,'WETG_BU_RRC')
+ IF (LBUDGET_RR) CALL BUDGET ( &
+ UNPACK(PRRS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 8,'WETG_BU_RRR')
+ IF (LBUDGET_RI) CALL BUDGET ( &
+ UNPACK(PRIS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 9,'WETG_BU_RRI')
+ IF (LBUDGET_RS) CALL BUDGET ( &
+ UNPACK(PRSS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 10,'WETG_BU_RRS')
+ IF (LBUDGET_RG) CALL BUDGET ( &
+ UNPACK(PRGS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 11,'WETG_BU_RRG')
+ IF ( KRR == 7 ) THEN
+ IF (LBUDGET_RH) CALL BUDGET ( &
+ UNPACK(PRHS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 12,'WETG_BU_RRH')
+ END IF
+
+!
+ WHERE( PRGT(:)>XRTMIN(6) .AND. PZT(:)<XTT &
+ .AND. &
+ PRDRYG(:)<PRWETG(:) .AND. PRDRYG(:)>0.0 ) ! Dry
+ PRCS(:) = PRCS(:) - ZZW1(:,1)
+ PRIS(:) = PRIS(:) - ZZW1(:,2)
+ PRSS(:) = PRSS(:) - ZZW1(:,3)
+ PRRS(:) = PRRS(:) - ZZW1(:,4)
+ PRGS(:) = PRGS(:) + PRDRYG(:)
+ PTHS(:) = PTHS(:) + (ZZW1(:,1)+ZZW1(:,4))*(PLSFACT(:)-PLVFACT(:)) !
+ ! f(L_f*(RCDRYG+RRDRYG))
+ END WHERE
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:), &
+ 4,'DRYG_BU_RTH')
+ IF (LBUDGET_RC) CALL BUDGET ( &
+ UNPACK(PRCS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 7,'DRYG_BU_RRC')
+ IF (LBUDGET_RR) CALL BUDGET ( &
+ UNPACK(PRRS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 8,'DRYG_BU_RRR')
+ IF (LBUDGET_RI) CALL BUDGET ( &
+ UNPACK(PRIS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 9,'DRYG_BU_RRI')
+ IF (LBUDGET_RS) CALL BUDGET ( &
+ UNPACK(PRSS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 10,'DRYG_BU_RRS')
+ IF (LBUDGET_RG) CALL BUDGET ( &
+ UNPACK(PRGS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 11,'DRYG_BU_RRG')
+!
+! WHERE ( PZT(:) > XTT ) ! RSWETG case only
+! PRSS(:) = PRSS(:) - ZZW1(:,6)
+! PRGS(:) = PRGS(:) + ZZW1(:,6)
+! END WHERE
+!
+!* 6.5 Melting of the graupeln
+!
+ ZZW(:) = 0.0
+ WHERE( (PRGT(:)>XRTMIN(6)) .AND. (PRGS(:)>0.0) .AND. (PZT(:)>XTT) )
+ ZZW(:) = PRVT(:)*PPRES(:)/((XMV/XMD)+PRVT(:)) ! Vapor pressure
+ ZZW(:) = PKA(:)*(XTT-PZT(:)) + &
+ ( PDV(:)*(XLVTT + ( XCPV - XCL ) * ( PZT(:) - XTT )) &
+ *(XESTT-ZZW(:))/(XRV*PZT(:)) )
+!
+! compute RGMLTR
+!
+ ZZW(:) = MIN( PRGS(:), MAX( 0.0,( -ZZW(:) * &
+ ( X0DEPG* PLBDAG(:)**XEX0DEPG + &
+ X1DEPG*PCJ(:)*PLBDAG(:)**XEX1DEPG ) - &
+ ( ZZW1(:,1)+ZZW1(:,4) ) * &
+ ( PRHODREF(:)*XCL*(XTT-PZT(:))) ) / &
+ ( PRHODREF(:)*XLMTT ) ) )
+ PRRS(:) = PRRS(:) + ZZW(:)
+ PRGS(:) = PRGS(:) - ZZW(:)
+ PTHS(:) = PTHS(:) - ZZW(:)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*(-RGMLTR))
+ END WHERE
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:), &
+ 4,'GMLT_BU_RTH')
+ IF (LBUDGET_RR) CALL BUDGET ( &
+ UNPACK(PRRS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 8,'GMLT_BU_RRR')
+ IF (LBUDGET_RG) CALL BUDGET ( &
+ UNPACK(PRGS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 11,'GMLT_BU_RRG')
+!
+END SUBROUTINE RAIN_ICE_FAST_RG
+
+END MODULE MODE_RAIN_ICE_FAST_RG
diff --git a/src/MNH/rain_ice_fast_rh.f90 b/src/MNH/rain_ice_fast_rh.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4691df965e77b57177a460b66366482acaa7a7da
--- /dev/null
+++ b/src/MNH/rain_ice_fast_rh.f90
@@ -0,0 +1,356 @@
+!MNH_LIC Copyright 1995-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! Modifications:
+! P. Wautelet 25/02/2019: split rain_ice (cleaner and easier to maintain/debug)
+!-----------------------------------------------------------------
+MODULE MODE_RAIN_ICE_FAST_RH
+
+ IMPLICIT NONE
+
+ PRIVATE
+
+ PUBLIC :: RAIN_ICE_FAST_RH
+
+CONTAINS
+
+SUBROUTINE RAIN_ICE_FAST_RH(OMICRO, PRHODREF, PRVT, PRCT, PRIT, PRST, PRGT, PRHT, PRHODJ, PPRES, &
+ PZT, PLBDAS, PLBDAG, PLBDAH, PLSFACT, PLVFACT, PCJ, PKA, PDV, PRHODJ3D, PTHS3D, &
+ PRCS, PRRS, PRIS, PRSS, PRGS, PRHS, PTHS, PUSW)
+!
+!* 0. DECLARATIONS
+! ------------
+!
+use MODD_BUDGET, only: LBUDGET_RC, LBUDGET_RG, LBUDGET_RH, LBUDGET_RI, LBUDGET_RR, LBUDGET_RS, LBUDGET_TH
+use MODD_CST, only: XCI, XCL, XCPV, XESTT, XLMTT, XLVTT, XMD, XMV, XRV, XTT
+use MODD_RAIN_ICE_DESCR, only: XBG, XBS, XCEXVT, XCXG, XCXH, XCXS, XDH, XLBEXH, XLBH, XRTMIN
+use MODD_RAIN_ICE_PARAM, only: NWETLBDAG, NWETLBDAH, NWETLBDAS, X0DEPH, X1DEPH, &
+ XEX0DEPH, XEX1DEPH, XFGWETH, XFSWETH, XFWETH, XKER_GWETH, XKER_SWETH, &
+ XLBGWETH1, XLBGWETH2, XLBGWETH3, XLBSWETH1, XLBSWETH2, XLBSWETH3, &
+ XWETINTP1G, XWETINTP1H, XWETINTP1S, XWETINTP2G, XWETINTP2H, XWETINTP2S
+!
+use MODI_BUDGET
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+LOGICAL, DIMENSION(:,:,:), intent(in) :: OMICRO ! Test where to compute all processes
+REAL, DIMENSION(:), intent(in) :: PRHODREF ! RHO Dry REFerence
+REAL, DIMENSION(:), intent(in) :: PRVT ! Water vapor m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRCT ! Cloud water m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRIT ! Pristine ice m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRST ! Snow/aggregate m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRGT ! Graupel m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRHT ! Hail m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRHODJ ! RHO times Jacobian
+REAL, DIMENSION(:), intent(in) :: PPRES ! Pressure
+REAL, DIMENSION(:), intent(in) :: PZT ! Temperature
+REAL, DIMENSION(:), intent(in) :: PLBDAS ! Slope parameter of the aggregate distribution
+REAL, DIMENSION(:), intent(in) :: PLBDAG ! Slope parameter of the graupel distribution
+REAL, DIMENSION(:), intent(inout) :: PLBDAH ! Slope parameter of the hail distribution
+REAL, DIMENSION(:), intent(in) :: PLSFACT ! L_s/(Pi_ref*C_ph)
+REAL, DIMENSION(:), intent(in) :: PLVFACT ! L_v/(Pi_ref*C_ph)
+REAL, DIMENSION(:), intent(in) :: PCJ ! Function to compute the ventilation coefficient
+REAL, DIMENSION(:), intent(in) :: PKA ! Thermal conductivity of the air
+REAL, DIMENSION(:), intent(in) :: PDV ! Diffusivity of water vapor in the air
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ3D ! Dry density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHS3D ! Theta source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRSS ! Snow/aggregate m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRGS ! Graupel m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRHS ! Hail m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PTHS ! Theta source
+REAL, DIMENSION(:), intent(inout) :: PUSW ! Undersaturation over water
+!
+!* 0.2 declaration of local variables
+!
+INTEGER :: IHAIL, IGWET
+INTEGER :: JJ
+INTEGER, DIMENSION(:), ALLOCATABLE :: IVEC1, IVEC2 ! Vectors of indices for interpolations
+LOGICAL, DIMENSION(size(PRHODREF)) :: GWET ! Test where to compute wet growth
+LOGICAL, DIMENSION(size(PRHODREF)) :: GHAIL ! Test where to compute hail growth
+REAL, DIMENSION(:), ALLOCATABLE :: ZVEC1,ZVEC2,ZVEC3 ! Work vectors for interpolations
+REAL, DIMENSION(size(PRHODREF)) :: ZZW ! Work array
+REAL, DIMENSION(size(PRHODREF),6) :: ZZW1 ! Work arrays
+!
+!-------------------------------------------------------------------------------
+!
+ GHAIL(:) = PRHT(:)>XRTMIN(7)
+ IHAIL = COUNT(GHAIL(:))
+!
+ IF( IHAIL>0 ) THEN
+!
+!* 7.2 compute the Wet growth of hail
+!
+ WHERE ( GHAIL(:) )
+ PLBDAH(:) = XLBH*( PRHODREF(:)*MAX( PRHT(:),XRTMIN(7) ) )**XLBEXH
+ END WHERE
+!
+ ZZW1(:,:) = 0.0
+ WHERE( GHAIL(:) .AND. ((PRCT(:)>XRTMIN(2) .AND. PRCS(:)>0.0)) )
+ ZZW(:) = PLBDAH(:)**(XCXH-XDH-2.0) * PRHODREF(:)**(-XCEXVT)
+ ZZW1(:,1) = MIN( PRCS(:),XFWETH * PRCT(:) * ZZW(:) ) ! RCWETH
+ END WHERE
+ WHERE( GHAIL(:) .AND. ((PRIT(:)>XRTMIN(4) .AND. PRIS(:)>0.0)) )
+ ZZW(:) = PLBDAH(:)**(XCXH-XDH-2.0) * PRHODREF(:)**(-XCEXVT)
+ ZZW1(:,2) = MIN( PRIS(:),XFWETH * PRIT(:) * ZZW(:) ) ! RIWETH
+ END WHERE
+!
+!* 7.2.1 accretion of aggregates on the hailstones
+!
+ GWET(:) = GHAIL(:) .AND. (PRST(:)>XRTMIN(5) .AND. PRSS(:)>0.0)
+ IGWET = COUNT( GWET(:) )
+!
+ IF( IGWET>0 ) THEN
+!
+!* 7.2.2 allocations
+!
+ ALLOCATE(ZVEC1(IGWET))
+ ALLOCATE(ZVEC2(IGWET))
+ ALLOCATE(ZVEC3(IGWET))
+ ALLOCATE(IVEC1(IGWET))
+ ALLOCATE(IVEC2(IGWET))
+!
+!* 7.2.3 select the (PLBDAH,PLBDAS) couplet
+!
+ ZVEC1(:) = PACK( PLBDAH(:),MASK=GWET(:) )
+ ZVEC2(:) = PACK( PLBDAS(:),MASK=GWET(:) )
+!
+!* 7.2.4 find the next lower indice for the PLBDAG and for the PLBDAS
+! in the geometrical set of (Lbda_h,Lbda_s) couplet use to
+! tabulate the SWETH-kernel
+!
+ ZVEC1(1:IGWET) = MAX( 1.00001, MIN( FLOAT(NWETLBDAH)-0.00001, &
+ XWETINTP1H * LOG( ZVEC1(1:IGWET) ) + XWETINTP2H ) )
+ IVEC1(1:IGWET) = INT( ZVEC1(1:IGWET) )
+ ZVEC1(1:IGWET) = ZVEC1(1:IGWET) - FLOAT( IVEC1(1:IGWET) )
+!
+ ZVEC2(1:IGWET) = MAX( 1.00001, MIN( FLOAT(NWETLBDAS)-0.00001, &
+ XWETINTP1S * LOG( ZVEC2(1:IGWET) ) + XWETINTP2S ) )
+ IVEC2(1:IGWET) = INT( ZVEC2(1:IGWET) )
+ ZVEC2(1:IGWET) = ZVEC2(1:IGWET) - FLOAT( IVEC2(1:IGWET) )
+!
+!* 7.2.5 perform the bilinear interpolation of the normalized
+! SWETH-kernel
+!
+ DO JJ = 1,IGWET
+ ZVEC3(JJ) = ( XKER_SWETH(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
+ - XKER_SWETH(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
+ * ZVEC1(JJ) &
+ - ( XKER_SWETH(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
+ - XKER_SWETH(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
+ * (ZVEC1(JJ) - 1.0)
+ END DO
+ ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GWET,FIELD=0.0 )
+!
+ WHERE( GWET(:) )
+ ZZW1(:,3) = MIN( PRSS(:),XFSWETH*ZZW(:) & ! RSWETH
+ *( PLBDAS(:)**(XCXS-XBS) )*( PLBDAH(:)**XCXH ) &
+ *( PRHODREF(:)**(-XCEXVT-1.) ) &
+ *( XLBSWETH1/( PLBDAH(:)**2 ) + &
+ XLBSWETH2/( PLBDAH(:) * PLBDAS(:) ) + &
+ XLBSWETH3/( PLBDAS(:)**2) ) )
+ END WHERE
+ DEALLOCATE(IVEC2)
+ DEALLOCATE(IVEC1)
+ DEALLOCATE(ZVEC3)
+ DEALLOCATE(ZVEC2)
+ DEALLOCATE(ZVEC1)
+ END IF
+!
+!* 7.2.6 accretion of graupeln on the hailstones
+!
+ GWET(:) = GHAIL(:) .AND. (PRGT(:)>XRTMIN(6) .AND. PRGS(:)>0.0)
+ IGWET = COUNT( GWET(:) )
+!
+ IF( IGWET>0 ) THEN
+!
+!* 7.2.7 allocations
+!
+ ALLOCATE(ZVEC1(IGWET))
+ ALLOCATE(ZVEC2(IGWET))
+ ALLOCATE(ZVEC3(IGWET))
+ ALLOCATE(IVEC1(IGWET))
+ ALLOCATE(IVEC2(IGWET))
+!
+!* 7.2.8 select the (PLBDAH,PLBDAG) couplet
+!
+ ZVEC1(:) = PACK( PLBDAH(:),MASK=GWET(:) )
+ ZVEC2(:) = PACK( PLBDAG(:),MASK=GWET(:) )
+!
+!* 7.2.9 find the next lower indice for the PLBDAH and for the PLBDAG
+! in the geometrical set of (Lbda_h,Lbda_g) couplet use to
+! tabulate the GWETH-kernel
+!
+ ZVEC1(1:IGWET) = MAX( 1.00001, MIN( FLOAT(NWETLBDAG)-0.00001, &
+ XWETINTP1H * LOG( ZVEC1(1:IGWET) ) + XWETINTP2H ) )
+ IVEC1(1:IGWET) = INT( ZVEC1(1:IGWET) )
+ ZVEC1(1:IGWET) = ZVEC1(1:IGWET) - FLOAT( IVEC1(1:IGWET) )
+!
+ ZVEC2(1:IGWET) = MAX( 1.00001, MIN( FLOAT(NWETLBDAG)-0.00001, &
+ XWETINTP1G * LOG( ZVEC2(1:IGWET) ) + XWETINTP2G ) )
+ IVEC2(1:IGWET) = INT( ZVEC2(1:IGWET) )
+ ZVEC2(1:IGWET) = ZVEC2(1:IGWET) - FLOAT( IVEC2(1:IGWET) )
+!
+!* 7.2.10 perform the bilinear interpolation of the normalized
+! GWETH-kernel
+!
+ DO JJ = 1,IGWET
+ ZVEC3(JJ) = ( XKER_GWETH(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
+ - XKER_GWETH(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
+ * ZVEC1(JJ) &
+ - ( XKER_GWETH(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
+ - XKER_GWETH(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
+ * (ZVEC1(JJ) - 1.0)
+ END DO
+ ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GWET,FIELD=0.0 )
+!
+ WHERE( GWET(:) )
+ ZZW1(:,5) = MAX(MIN( PRGS(:),XFGWETH*ZZW(:) & ! RGWETH
+ *( PLBDAG(:)**(XCXG-XBG) )*( PLBDAH(:)**XCXH ) &
+ *( PRHODREF(:)**(-XCEXVT-1.) ) &
+ *( XLBGWETH1/( PLBDAH(:)**2 ) + &
+ XLBGWETH2/( PLBDAH(:) * PLBDAG(:) ) + &
+ XLBGWETH3/( PLBDAG(:)**2) ) ),0. )
+ END WHERE
+ DEALLOCATE(IVEC2)
+ DEALLOCATE(IVEC1)
+ DEALLOCATE(ZVEC3)
+ DEALLOCATE(ZVEC2)
+ DEALLOCATE(ZVEC1)
+ END IF
+!
+!* 7.3 compute the Wet growth of hail
+!
+ ZZW(:) = 0.0
+ WHERE( GHAIL(:) .AND. PZT(:)<XTT )
+ ZZW(:) = PRVT(:)*PPRES(:)/((XMV/XMD)+PRVT(:)) ! Vapor pressure
+ ZZW(:) = PKA(:)*(XTT-PZT(:)) + &
+ ( PDV(:)*(XLVTT + ( XCPV - XCL ) * ( PZT(:) - XTT )) &
+ *(XESTT-ZZW(:))/(XRV*PZT(:)) )
+!
+! compute RWETH
+!
+ ZZW(:) = MAX(0., ( ZZW(:) * ( X0DEPH* PLBDAH(:)**XEX0DEPH + &
+ X1DEPH*PCJ(:)*PLBDAH(:)**XEX1DEPH ) + &
+ ( ZZW1(:,2)+ZZW1(:,3)+ZZW1(:,5) ) * &
+ ( PRHODREF(:)*(XLMTT+(XCI-XCL)*(XTT-PZT(:))) ) ) / &
+ ( PRHODREF(:)*(XLMTT-XCL*(XTT-PZT(:))) ) )
+!
+ ZZW1(:,6) = MAX( ZZW(:) - ZZW1(:,2) - ZZW1(:,3) - ZZW1(:,5),0.) ! RCWETH+RRWETH
+ END WHERE
+ WHERE ( GHAIL(:) .AND. PZT(:)<XTT .AND. ZZW1(:,6)/=0.)
+!
+! limitation of the available rainwater mixing ratio (RRWETH < RRS !)
+!
+ ZZW1(:,4) = MAX( 0.0,MIN( ZZW1(:,6),PRRS(:)+ZZW1(:,1) ) )
+ PUSW(:) = ZZW1(:,4) / ZZW1(:,6)
+ ZZW1(:,2) = ZZW1(:,2)*PUSW(:)
+ ZZW1(:,3) = ZZW1(:,3)*PUSW(:)
+ ZZW1(:,5) = ZZW1(:,5)*PUSW(:)
+ ZZW(:) = ZZW1(:,4) + ZZW1(:,2) + ZZW1(:,3) + ZZW1(:,5)
+!
+!* 7.1.6 integrate the Wet growth of hail
+!
+ PRCS(:) = PRCS(:) - ZZW1(:,1)
+ PRIS(:) = PRIS(:) - ZZW1(:,2)
+ PRSS(:) = PRSS(:) - ZZW1(:,3)
+ PRGS(:) = PRGS(:) - ZZW1(:,5)
+ PRHS(:) = PRHS(:) + ZZW(:)
+ PRRS(:) = MAX( 0.0,PRRS(:) - ZZW1(:,4) + ZZW1(:,1) )
+ PTHS(:) = PTHS(:) + ZZW1(:,4)*(PLSFACT(:)-PLVFACT(:))
+ ! f(L_f*(RCWETH+RRWETH))
+ END WHERE
+ END IF
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:),&
+ 4,'WETH_BU_RTH')
+ IF (LBUDGET_RC) CALL BUDGET ( &
+ UNPACK(PRCS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 7,'WETH_BU_RRC')
+ IF (LBUDGET_RR) CALL BUDGET ( &
+ UNPACK(PRRS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 8,'WETH_BU_RRR')
+ IF (LBUDGET_RI) CALL BUDGET ( &
+ UNPACK(PRIS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 9,'WETH_BU_RRI')
+ IF (LBUDGET_RS) CALL BUDGET ( &
+ UNPACK(PRSS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 10,'WETH_BU_RRS')
+ IF (LBUDGET_RG) CALL BUDGET ( &
+ UNPACK(PRGS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 11,'WETH_BU_RRG')
+ IF (LBUDGET_RH) CALL BUDGET ( &
+ UNPACK(PRHS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 12,'WETH_BU_RRH')
+!
+!
+! ici LRECONVH et un flag pour autoriser une reconversion partielle de
+!la grele en gresil
+!
+! IF( IHAIL>0 ) THEN
+!
+!UPG_CD
+!
+!
+!* 7.45 Conversion of the hailstones into graupel
+!
+! XDUMMY6=0.01E-3
+! XDUMMY7=0.001E-3
+! WHERE( PRHT(:)<XDUMMY6 .AND. PRCT(:)<XDUMMY7 .AND. PZT(:)<XTT )
+! ZZW(:) = MIN( 1.0,MAX( 0.0,1.0-(PRCT(:)/XDUMMY7) ) )
+!
+! assume a linear percent conversion rate of hail into graupel
+!
+! ZZW(:) = PRHS(:)*ZZW(:)
+! PRGS(:) = PRGS(:) + ZZW(:) ! partial conversion
+! PRHS(:) = PRHS(:) - ZZW(:) ! of hail into graupel
+!
+! END WHERE
+! END IF
+
+
+
+
+ IF( IHAIL>0 ) THEN
+!
+!* 7.5 Melting of the hailstones
+!
+ ZZW(:) = 0.0
+ WHERE( GHAIL(:) .AND. (PRHS(:)>0.0) .AND. (PZT(:)>XTT) )
+ ZZW(:) = PRVT(:)*PPRES(:)/((XMV/XMD)+PRVT(:)) ! Vapor pressure
+ ZZW(:) = PKA(:)*(XTT-PZT(:)) + &
+ ( PDV(:)*(XLVTT + ( XCPV - XCL ) * ( PZT(:) - XTT )) &
+ *(XESTT-ZZW(:))/(XRV*PZT(:)) )
+!
+! compute RHMLTR
+!
+ ZZW(:) = MIN( PRHS(:), MAX( 0.0,( -ZZW(:) * &
+ ( X0DEPH* PLBDAH(:)**XEX0DEPH + &
+ X1DEPH*PCJ(:)*PLBDAH(:)**XEX1DEPH ) - &
+ ZZW1(:,6)*( PRHODREF(:)*XCL*(XTT-PZT(:))) ) / &
+ ( PRHODREF(:)*XLMTT ) ) )
+ PRRS(:) = PRRS(:) + ZZW(:)
+ PRHS(:) = PRHS(:) - ZZW(:)
+ PTHS(:) = PTHS(:) - ZZW(:)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*(-RHMLTR))
+ END WHERE
+ END IF
+
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:),&
+ 4,'HMLT_BU_RTH')
+ IF (LBUDGET_RR) CALL BUDGET ( &
+ UNPACK(PRRS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 8,'HMLT_BU_RRR')
+ IF (LBUDGET_RH) CALL BUDGET ( &
+ UNPACK(PRHS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 12,'HMLT_BU_RRH')
+!
+END SUBROUTINE RAIN_ICE_FAST_RH
+
+END MODULE MODE_RAIN_ICE_FAST_RH
diff --git a/src/MNH/rain_ice_fast_ri.f90 b/src/MNH/rain_ice_fast_ri.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2ed51c7ffa059e697affd4a4bce0a4bebb3f32a6
--- /dev/null
+++ b/src/MNH/rain_ice_fast_ri.f90
@@ -0,0 +1,102 @@
+!MNH_LIC Copyright 1995-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! Modifications:
+! P. Wautelet 25/02/2019: split rain_ice (cleaner and easier to maintain/debug)
+!-----------------------------------------------------------------
+MODULE MODE_RAIN_ICE_FAST_RI
+
+ IMPLICIT NONE
+
+ PRIVATE
+
+ PUBLIC :: RAIN_ICE_FAST_RI
+
+CONTAINS
+
+SUBROUTINE RAIN_ICE_FAST_RI(OMICRO, PRHODREF, PRIT, PRHODJ, PZT, PSSI, PLSFACT, PLVFACT, &
+ PAI, PCJ, PRHODJ3D, PTHS3D, PCIT, PRCS, PRIS, PTHS)
+!
+!* 0. DECLARATIONS
+! ------------
+!
+use MODD_BUDGET, only: LBUDGET_RC, LBUDGET_RI, LBUDGET_TH
+use MODD_CST, only: XTT
+use MODD_RAIN_ICE_DESCR, only: XDI, XLBEXI, XLBI, XRTMIN
+use MODD_RAIN_ICE_PARAM, only: X0DEPI, X2DEPI
+!
+use MODI_BUDGET
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+LOGICAL, DIMENSION(:,:,:), intent(in) :: OMICRO ! Test where to compute all processes
+REAL, DIMENSION(:), intent(in) :: PRHODREF ! RHO Dry REFerence
+REAL, DIMENSION(:), intent(in) :: PRIT ! Pristine ice m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRHODJ ! RHO times Jacobian
+REAL, DIMENSION(:), intent(in) :: PZT ! Temperature
+REAL, DIMENSION(:), intent(in) :: PSSI ! Supersaturation over ice
+REAL, DIMENSION(:), intent(in) :: PLSFACT ! L_s/(Pi_ref*C_ph)
+REAL, DIMENSION(:), intent(in) :: PLVFACT ! L_v/(Pi_ref*C_ph)
+REAL, DIMENSION(:), intent(in) :: PAI ! Thermodynamical function
+REAL, DIMENSION(:), intent(in) :: PCJ ! Function to compute the ventilation coefficient
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ3D ! Dry density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHS3D ! Theta source
+REAL, DIMENSION(:), intent(inout) :: PCIT ! Pristine ice conc. at t
+REAL, DIMENSION(:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PTHS ! Theta source
+!
+!* 0.2 declaration of local variables
+!
+REAL, DIMENSION(size(PRHODREF)) :: ZZW ! Work array
+!-------------------------------------------------------------------------------
+!
+!* 7.1 cloud ice melting
+!
+ ZZW(:) = 0.0
+ WHERE( (PRIS(:)>0.0) .AND. (PZT(:)>XTT) )
+ ZZW(:) = PRIS(:)
+ PRCS(:) = PRCS(:) + PRIS(:)
+ PTHS(:) = PTHS(:) - PRIS(:)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*(-RIMLTC))
+ PRIS(:) = 0.0
+ PCIT(:) = 0.0
+ END WHERE
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:), &
+ 4,'IMLT_BU_RTH')
+ IF (LBUDGET_RC) CALL BUDGET ( &
+ UNPACK(PRCS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 7,'IMLT_BU_RRC')
+ IF (LBUDGET_RI) CALL BUDGET ( &
+ UNPACK(PRIS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 9,'IMLT_BU_RRI')
+!
+!* 7.2 Bergeron-Findeisen effect: RCBERI
+!
+ ZZW(:) = 0.0
+ WHERE( (PRCS(:)>0.0) .AND. (PSSI(:)>0.0) .AND. &
+ (PRIT(:)>XRTMIN(4)) .AND. (PCIT(:)>0.0) )
+ ZZW(:) = MIN(1.E8,XLBI*( PRHODREF(:)*PRIT(:)/PCIT(:) )**XLBEXI) ! Lbda_i
+ ZZW(:) = MIN( PRCS(:),( PSSI(:) / (PRHODREF(:)*PAI(:)) ) * PCIT(:) * &
+ ( X0DEPI/ZZW(:) + X2DEPI*PCJ(:)*PCJ(:)/ZZW(:)**(XDI+2.0) ) )
+ PRCS(:) = PRCS(:) - ZZW(:)
+ PRIS(:) = PRIS(:) + ZZW(:)
+ PTHS(:) = PTHS(:) + ZZW(:)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*(RCBERI))
+ END WHERE
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:), &
+ 4,'BERFI_BU_RTH')
+ IF (LBUDGET_RC) CALL BUDGET ( &
+ UNPACK(PRCS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 7,'BERFI_BU_RRC')
+ IF (LBUDGET_RI) CALL BUDGET ( &
+ UNPACK(PRIS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 9,'BERFI_BU_RRI')
+!
+END SUBROUTINE RAIN_ICE_FAST_RI
+
+END MODULE MODE_RAIN_ICE_FAST_RI
diff --git a/src/MNH/rain_ice_fast_rs.f90 b/src/MNH/rain_ice_fast_rs.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3a3749cfa3fe24c176ba0b45fedb7dac4a851fe4
--- /dev/null
+++ b/src/MNH/rain_ice_fast_rs.f90
@@ -0,0 +1,328 @@
+!MNH_LIC Copyright 1995-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! Modifications:
+! P. Wautelet 25/02/2019: split rain_ice (cleaner and easier to maintain/debug)
+!-----------------------------------------------------------------
+MODULE MODE_RAIN_ICE_FAST_RS
+
+ IMPLICIT NONE
+
+ PRIVATE
+
+ PUBLIC :: RAIN_ICE_FAST_RS
+
+CONTAINS
+
+SUBROUTINE RAIN_ICE_FAST_RS(PTSTEP, OMICRO, PRHODREF, PRVT, PRCT, PRRT, PRST, PRHODJ, PPRES, PZT, &
+ PLBDAR, PLBDAS, PLSFACT, PLVFACT, PCJ, PKA, PDV, PRHODJ3D, PTHS3D, &
+ PRCS, PRRS, PRSS, PRGS, PTHS)
+!
+!* 0. DECLARATIONS
+! ------------
+!
+use MODD_BUDGET, only: LBUDGET_RC, LBUDGET_RG, LBUDGET_RR, LBUDGET_RS, LBUDGET_TH
+use MODD_CST, only: XCL, XCPV, XESTT, XLMTT, XLVTT, XMD, XMV, XRV, XTT
+use MODD_RAIN_ICE_DESCR, only: XBS, XCEXVT, XCXS, XRTMIN
+use MODD_RAIN_ICE_PARAM, only: NACCLBDAR, NACCLBDAS, NGAMINC, X0DEPS, X1DEPS, XACCINTP1R, XACCINTP1S, XACCINTP2R, XACCINTP2S, &
+ XCRIMSG, XCRIMSS, XEX0DEPS, XEX1DEPS, XEXCRIMSG, XEXCRIMSS, XEXSRIMCG, XFRACCSS, &
+ XFSACCRG, XFSCVMG, XGAMINC_RIM1, XGAMINC_RIM1, XGAMINC_RIM2, XKER_RACCS, &
+ XKER_RACCSS, XKER_SACCRG, XLBRACCS1, XLBRACCS2, XLBRACCS3, XLBSACCR1, XLBSACCR2, XLBSACCR3, &
+ XRIMINTP1, XRIMINTP2, XSRIMCG
+!
+use MODI_BUDGET
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+REAL, intent(in) :: PTSTEP ! Double Time step
+ ! (single if cold start)
+LOGICAL, DIMENSION(:,:,:), intent(in) :: OMICRO ! Test where to compute all processes
+REAL, DIMENSION(:), intent(in) :: PRHODREF ! RHO Dry REFerence
+REAL, DIMENSION(:), intent(in) :: PRVT ! Water vapor m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRCT ! Cloud water m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRRT ! Rain water m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRST ! Snow/aggregate m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRHODJ ! RHO times Jacobian
+REAL, DIMENSION(:), intent(in) :: PPRES ! Pressure
+REAL, DIMENSION(:), intent(in) :: PZT ! Temperature
+REAL, DIMENSION(:), intent(in) :: PLBDAR ! Slope parameter of the raindrop distribution
+REAL, DIMENSION(:), intent(in) :: PLBDAS ! Slope parameter of the aggregate distribution
+REAL, DIMENSION(:), intent(in) :: PLSFACT ! L_s/(Pi_ref*C_ph)
+REAL, DIMENSION(:), intent(in) :: PLVFACT ! L_v/(Pi_ref*C_ph)
+REAL, DIMENSION(:), intent(in) :: PCJ ! Function to compute the ventilation coefficient
+REAL, DIMENSION(:), intent(in) :: PKA ! Thermal conductivity of the air
+REAL, DIMENSION(:), intent(in) :: PDV ! Diffusivity of water vapor in the air
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ3D ! Dry density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHS3D ! Theta source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRSS ! Snow/aggregate m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRGS ! Graupel m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PTHS ! Theta source
+!
+!* 0.2 declaration of local variables
+!
+INTEGER :: IGRIM, IGACC
+INTEGER :: JJ
+INTEGER, DIMENSION(:), ALLOCATABLE :: IVEC1, IVEC2 ! Vectors of indices for interpolations
+LOGICAL, DIMENSION(size(PRHODREF)) :: GRIM ! Test where to compute riming
+LOGICAL, DIMENSION(size(PRHODREF)) :: GACC ! Test where to compute accretion
+REAL, DIMENSION(size(PRHODREF)) :: ZZW ! Work array
+REAL, DIMENSION(:), ALLOCATABLE :: ZVEC1,ZVEC2,ZVEC3 ! Work vectors for interpolations
+REAL, DIMENSION(size(PRHODREF),4) :: ZZW1 ! Work arrays
+!-------------------------------------------------------------------------------
+!
+!* 5.1 cloud droplet riming of the aggregates
+!
+ ZZW1(:,:) = 0.0
+!
+! GRIM(:) = (PRCT(:)>0.0) .AND. (PRST(:)>0.0) .AND. &
+ GRIM(:) = (PRCT(:)>XRTMIN(2)) .AND. (PRST(:)>XRTMIN(5)) .AND. &
+ (PRCS(:)>0.0) .AND. (PZT(:)<XTT)
+ IGRIM = COUNT( GRIM(:) )
+!
+ IF( IGRIM>0 ) THEN
+!
+! 5.1.0 allocations
+!
+ ALLOCATE(ZVEC1(IGRIM))
+ ALLOCATE(ZVEC2(IGRIM))
+ ALLOCATE(IVEC2(IGRIM))
+!
+! 5.1.1 select the PLBDAS
+!
+ ZVEC1(:) = PACK( PLBDAS(:),MASK=GRIM(:) )
+!
+! 5.1.2 find the next lower indice for the PLBDAS in the geometrical
+! set of Lbda_s used to tabulate some moments of the incomplete
+! gamma function
+!
+ ZVEC2(1:IGRIM) = MAX( 1.00001, MIN( FLOAT(NGAMINC)-0.00001, &
+ XRIMINTP1 * LOG( ZVEC1(1:IGRIM) ) + XRIMINTP2 ) )
+ IVEC2(1:IGRIM) = INT( ZVEC2(1:IGRIM) )
+ ZVEC2(1:IGRIM) = ZVEC2(1:IGRIM) - FLOAT( IVEC2(1:IGRIM) )
+!
+! 5.1.3 perform the linear interpolation of the normalized
+! "2+XDS"-moment of the incomplete gamma function
+!
+ ZVEC1(1:IGRIM) = XGAMINC_RIM1( IVEC2(1:IGRIM)+1 )* ZVEC2(1:IGRIM) &
+ - XGAMINC_RIM1( IVEC2(1:IGRIM) )*(ZVEC2(1:IGRIM) - 1.0)
+ ZZW(:) = UNPACK( VECTOR=ZVEC1(:),MASK=GRIM,FIELD=0.0 )
+!
+! 5.1.4 riming of the small sized aggregates
+!
+ WHERE ( GRIM(:) )
+ ZZW1(:,1) = MIN( PRCS(:), &
+ XCRIMSS * ZZW(:) * PRCT(:) & ! RCRIMSS
+ * PLBDAS(:)**XEXCRIMSS &
+ * PRHODREF(:)**(-XCEXVT) )
+ PRCS(:) = PRCS(:) - ZZW1(:,1)
+ PRSS(:) = PRSS(:) + ZZW1(:,1)
+ PTHS(:) = PTHS(:) + ZZW1(:,1)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*(RCRIMSS))
+ END WHERE
+!
+! 5.1.5 perform the linear interpolation of the normalized
+! "XBS"-moment of the incomplete gamma function
+!
+ ZVEC1(1:IGRIM) = XGAMINC_RIM2( IVEC2(1:IGRIM)+1 )* ZVEC2(1:IGRIM) &
+ - XGAMINC_RIM2( IVEC2(1:IGRIM) )*(ZVEC2(1:IGRIM) - 1.0)
+ ZZW(:) = UNPACK( VECTOR=ZVEC1(:),MASK=GRIM,FIELD=0.0 )
+!
+! 5.1.6 riming-conversion of the large sized aggregates into graupeln
+!
+!
+ WHERE ( GRIM(:) .AND. (PRSS(:)>0.0) )
+ ZZW1(:,2) = MIN( PRCS(:), &
+ XCRIMSG * PRCT(:) & ! RCRIMSG
+ * PLBDAS(:)**XEXCRIMSG &
+ * PRHODREF(:)**(-XCEXVT) &
+ - ZZW1(:,1) )
+ ZZW1(:,3) = MIN( PRSS(:), &
+ XSRIMCG * PLBDAS(:)**XEXSRIMCG & ! RSRIMCG
+ * (1.0 - ZZW(:) )/(PTSTEP*PRHODREF(:)) )
+ PRCS(:) = PRCS(:) - ZZW1(:,2)
+ PRSS(:) = PRSS(:) - ZZW1(:,3)
+ PRGS(:) = PRGS(:) + ZZW1(:,2)+ZZW1(:,3)
+ PTHS(:) = PTHS(:) + ZZW1(:,2)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*(RCRIMSG))
+ END WHERE
+ DEALLOCATE(IVEC2)
+ DEALLOCATE(ZVEC2)
+ DEALLOCATE(ZVEC1)
+ END IF
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:), &
+ 4,'RIM_BU_RTH')
+ IF (LBUDGET_RC) CALL BUDGET ( &
+ UNPACK(PRCS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 7,'RIM_BU_RRC')
+ IF (LBUDGET_RS) CALL BUDGET ( &
+ UNPACK(PRSS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 10,'RIM_BU_RRS')
+ IF (LBUDGET_RG) CALL BUDGET ( &
+ UNPACK(PRGS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 11,'RIM_BU_RRG')
+!
+!* 5.2 rain accretion onto the aggregates
+!
+ ZZW1(:,2:3) = 0.0
+ GACC(:) = (PRRT(:)>XRTMIN(3)) .AND. (PRST(:)>XRTMIN(5)) .AND. &
+ (PRRS(:)>0.0) .AND. (PZT(:)<XTT)
+ IGACC = COUNT( GACC(:) )
+!
+ IF( IGACC>0 ) THEN
+!
+! 5.2.0 allocations
+!
+ ALLOCATE(ZVEC1(IGACC))
+ ALLOCATE(ZVEC2(IGACC))
+ ALLOCATE(ZVEC3(IGACC))
+ ALLOCATE(IVEC1(IGACC))
+ ALLOCATE(IVEC2(IGACC))
+!
+! 5.2.1 select the (PLBDAS,PLBDAR) couplet
+!
+ ZVEC1(:) = PACK( PLBDAS(:),MASK=GACC(:) )
+ ZVEC2(:) = PACK( PLBDAR(:),MASK=GACC(:) )
+!
+! 5.2.2 find the next lower indice for the PLBDAS and for the PLBDAR
+! in the geometrical set of (Lbda_s,Lbda_r) couplet use to
+! tabulate the RACCSS-kernel
+!
+ ZVEC1(1:IGACC) = MAX( 1.00001, MIN( FLOAT(NACCLBDAS)-0.00001, &
+ XACCINTP1S * LOG( ZVEC1(1:IGACC) ) + XACCINTP2S ) )
+ IVEC1(1:IGACC) = INT( ZVEC1(1:IGACC) )
+ ZVEC1(1:IGACC) = ZVEC1(1:IGACC) - FLOAT( IVEC1(1:IGACC) )
+!
+ ZVEC2(1:IGACC) = MAX( 1.00001, MIN( FLOAT(NACCLBDAR)-0.00001, &
+ XACCINTP1R * LOG( ZVEC2(1:IGACC) ) + XACCINTP2R ) )
+ IVEC2(1:IGACC) = INT( ZVEC2(1:IGACC) )
+ ZVEC2(1:IGACC) = ZVEC2(1:IGACC) - FLOAT( IVEC2(1:IGACC) )
+!
+! 5.2.3 perform the bilinear interpolation of the normalized
+! RACCSS-kernel
+!
+ DO JJ = 1,IGACC
+ ZVEC3(JJ) = ( XKER_RACCSS(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
+ - XKER_RACCSS(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
+ * ZVEC1(JJ) &
+ - ( XKER_RACCSS(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
+ - XKER_RACCSS(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
+ * (ZVEC1(JJ) - 1.0)
+ END DO
+ ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GACC,FIELD=0.0 )
+!
+! 5.2.4 raindrop accretion on the small sized aggregates
+!
+ WHERE ( GACC(:) )
+ ZZW1(:,2) = & !! coef of RRACCS
+ XFRACCSS*( PLBDAS(:)**XCXS )*( PRHODREF(:)**(-XCEXVT-1.) ) &
+ *( XLBRACCS1/((PLBDAS(:)**2) ) + &
+ XLBRACCS2/( PLBDAS(:) * PLBDAR(:) ) + &
+ XLBRACCS3/( (PLBDAR(:)**2)) )/PLBDAR(:)**4
+ ZZW1(:,4) = MIN( PRRS(:),ZZW1(:,2)*ZZW(:) ) ! RRACCSS
+ PRRS(:) = PRRS(:) - ZZW1(:,4)
+ PRSS(:) = PRSS(:) + ZZW1(:,4)
+ PTHS(:) = PTHS(:) + ZZW1(:,4)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*(RRACCSS))
+ END WHERE
+!
+! 5.2.4b perform the bilinear interpolation of the normalized
+! RACCS-kernel
+!
+ DO JJ = 1,IGACC
+ ZVEC3(JJ) = ( XKER_RACCS(IVEC2(JJ)+1,IVEC1(JJ)+1)* ZVEC1(JJ) &
+ - XKER_RACCS(IVEC2(JJ)+1,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
+ * ZVEC2(JJ) &
+ - ( XKER_RACCS(IVEC2(JJ) ,IVEC1(JJ)+1)* ZVEC1(JJ) &
+ - XKER_RACCS(IVEC2(JJ) ,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
+ * (ZVEC2(JJ) - 1.0)
+ END DO
+ ZZW1(:,2) = ZZW1(:,2)*UNPACK( VECTOR=ZVEC3(:),MASK=GACC(:),FIELD=0.0 )
+ !! RRACCS!
+! 5.2.5 perform the bilinear interpolation of the normalized
+! SACCRG-kernel
+!
+ DO JJ = 1,IGACC
+ ZVEC3(JJ) = ( XKER_SACCRG(IVEC2(JJ)+1,IVEC1(JJ)+1)* ZVEC1(JJ) &
+ - XKER_SACCRG(IVEC2(JJ)+1,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
+ * ZVEC2(JJ) &
+ - ( XKER_SACCRG(IVEC2(JJ) ,IVEC1(JJ)+1)* ZVEC1(JJ) &
+ - XKER_SACCRG(IVEC2(JJ) ,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
+ * (ZVEC2(JJ) - 1.0)
+ END DO
+ ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GACC,FIELD=0.0 )
+!
+! 5.2.6 raindrop accretion-conversion of the large sized aggregates
+! into graupeln
+!
+ WHERE ( GACC(:) .AND. (PRSS(:)>0.0) )
+ ZZW1(:,2) = MAX( MIN( PRRS(:),ZZW1(:,2)-ZZW1(:,4) ),0.0 ) ! RRACCSG
+ END WHERE
+ WHERE ( GACC(:) .AND. (PRSS(:)>0.0) .AND. ZZW1(:,2)>0.0 )
+ ZZW1(:,3) = MIN( PRSS(:),XFSACCRG*ZZW(:)* & ! RSACCRG
+ ( PLBDAS(:)**(XCXS-XBS) )*( PRHODREF(:)**(-XCEXVT-1.) ) &
+ *( XLBSACCR1/((PLBDAR(:)**2) ) + &
+ XLBSACCR2/( PLBDAR(:) * PLBDAS(:) ) + &
+ XLBSACCR3/( (PLBDAS(:)**2)) )/PLBDAR(:) )
+ PRRS(:) = PRRS(:) - ZZW1(:,2)
+ PRSS(:) = PRSS(:) - ZZW1(:,3)
+ PRGS(:) = PRGS(:) + ZZW1(:,2)+ZZW1(:,3)
+ PTHS(:) = PTHS(:) + ZZW1(:,2)*(PLSFACT(:)-PLVFACT(:)) !
+ ! f(L_f*(RRACCSG))
+ END WHERE
+ DEALLOCATE(IVEC2)
+ DEALLOCATE(IVEC1)
+ DEALLOCATE(ZVEC3)
+ DEALLOCATE(ZVEC2)
+ DEALLOCATE(ZVEC1)
+ END IF
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:), &
+ 4,'ACC_BU_RTH')
+ IF (LBUDGET_RR) CALL BUDGET ( &
+ UNPACK(PRRS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 8,'ACC_BU_RRR')
+ IF (LBUDGET_RS) CALL BUDGET ( &
+ UNPACK(PRSS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 10,'ACC_BU_RRS')
+ IF (LBUDGET_RG) CALL BUDGET ( &
+ UNPACK(PRGS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 11,'ACC_BU_RRG')
+!
+!* 5.3 Conversion-Melting of the aggregates
+!
+ ZZW(:) = 0.0
+ WHERE( (PRST(:)>XRTMIN(5)) .AND. (PRSS(:)>0.0) .AND. (PZT(:)>XTT) )
+ ZZW(:) = PRVT(:)*PPRES(:)/((XMV/XMD)+PRVT(:)) ! Vapor pressure
+ ZZW(:) = PKA(:)*(XTT-PZT(:)) + &
+ ( PDV(:)*(XLVTT + ( XCPV - XCL ) * ( PZT(:) - XTT )) &
+ *(XESTT-ZZW(:))/(XRV*PZT(:)) )
+!
+! compute RSMLT
+!
+ ZZW(:) = MIN( PRSS(:), XFSCVMG*MAX( 0.0,( -ZZW(:) * &
+ ( X0DEPS* PLBDAS(:)**XEX0DEPS + &
+ X1DEPS*PCJ(:)*PLBDAS(:)**XEX1DEPS ) - &
+ ( ZZW1(:,1)+ZZW1(:,4) ) * &
+ ( PRHODREF(:)*XCL*(XTT-PZT(:))) ) / &
+ ( PRHODREF(:)*XLMTT ) ) )
+!
+! note that RSCVMG = RSMLT*XFSCVMG but no heat is exchanged (at the rate RSMLT)
+! because the graupeln produced by this process are still icy!!!
+!
+ PRSS(:) = PRSS(:) - ZZW(:)
+ PRGS(:) = PRGS(:) + ZZW(:)
+ END WHERE
+ IF (LBUDGET_RS) CALL BUDGET ( &
+ UNPACK(PRSS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 10,'CMEL_BU_RRS')
+ IF (LBUDGET_RG) CALL BUDGET ( &
+ UNPACK(PRGS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 11,'CMEL_BU_RRG')
+!
+END SUBROUTINE RAIN_ICE_FAST_RS
+
+END MODULE MODE_RAIN_ICE_FAST_RS
diff --git a/src/MNH/rain_ice_nucleation.f90 b/src/MNH/rain_ice_nucleation.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4fd4b262504c3b33897ad10e7b435f1a1f02fce0
--- /dev/null
+++ b/src/MNH/rain_ice_nucleation.f90
@@ -0,0 +1,198 @@
+!MNH_LIC Copyright 1995-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! Modifications:
+! P. Wautelet 25/02/2019: split rain_ice (cleaner and easier to maintain/debug)
+!-----------------------------------------------------------------
+MODULE MODE_RAIN_ICE_NUCLEATION
+
+ IMPLICIT NONE
+
+ PRIVATE
+
+ PUBLIC RAIN_ICE_NUCLEATION
+
+CONTAINS
+
+SUBROUTINE RAIN_ICE_NUCLEATION(KIB, KIE, KJB, KJE, KKTB, KKTE,KRR,PTSTEP,&
+ PTHT,PPABST,PRHODJ,PRHODREF,PRVT,PRCT,PRRT,PRIT,PRST,PRGT,&
+ PCIT,PEXNREF,PTHS,PRVS,PRIS,PT,PRHT)
+!
+!* 0. DECLARATIONS
+! ------------
+!
+use MODD_BUDGET, only: LBUDGET_RI, LBUDGET_RV, LBUDGET_TH
+use MODD_CST, only: XALPI, XALPW, XBETAI, XBETAW, XCI, XCL, XCPD, XCPV, XGAMI, XGAMW, &
+ XLSTT, XMD, XMV, XP00, XRD, XTT
+use MODD_RAIN_ICE_PARAM, only: XALPHA1, XALPHA2, XBETA1, XBETA2, XMNU0, XNU10, XNU20
+!
+use MODI_BUDGET
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+INTEGER, INTENT(IN) :: KIB, KIE, KJB, KJE, KKTB, KKTE
+INTEGER, INTENT(IN) :: KRR ! Number of moist variable
+REAL, INTENT(IN) :: PTSTEP ! Double Time step
+ ! (single if cold start)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! absolute pressure at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Pristine ice m.r. at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGT ! Graupel/hail m.r. at t
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIT ! Pristine ice n.c. at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PT ! Temperature
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(IN) :: PRHT ! Hail m.r. at t
+!
+!* 0.2 declaration of local variables
+!
+INTEGER :: INEGT
+INTEGER :: JL ! and PACK intrinsics
+INTEGER, DIMENSION(SIZE(PEXNREF)) :: I1,I2,I3 ! Used to replace the COUNT
+LOGICAL, DIMENSION(SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) &
+ :: GNEGT ! Test where to compute the HEN process
+REAL, DIMENSION(:), ALLOCATABLE :: ZRVT ! Water vapor m.r. at t
+REAL, DIMENSION(:), ALLOCATABLE :: ZCIT ! Pristine ice conc. at t
+REAL, DIMENSION(:), ALLOCATABLE :: ZZT, & ! Temperature
+ ZPRES, & ! Pressure
+ ZZW, & ! Work array
+ ZUSW, & ! Undersaturation over water
+ ZSSI ! Supersaturation over ice
+REAL, DIMENSION(SIZE(PEXNREF,1),SIZE(PEXNREF,2),SIZE(PEXNREF,3)) &
+ :: ZW ! work array
+!
+!-------------------------------------------------------------------------------
+!
+!
+! compute the temperature and the pressure
+!
+PT(:,:,:) = PTHT(:,:,:) * ( PPABST(:,:,:) / XP00 ) ** (XRD/XCPD)
+!
+! optimization by looking for locations where
+! the temperature is negative only !!!
+!
+GNEGT(:,:,:) = .FALSE.
+GNEGT(KIB:KIE,KJB:KJE,KKTB:KKTE) = PT(KIB:KIE,KJB:KJE,KKTB:KKTE)<XTT
+INEGT = COUNTJV( GNEGT(:,:,:),I1(:),I2(:),I3(:))
+IF( INEGT >= 1 ) THEN
+ ALLOCATE(ZRVT(INEGT)) ;
+ ALLOCATE(ZCIT(INEGT)) ;
+ ALLOCATE(ZZT(INEGT)) ;
+ ALLOCATE(ZPRES(INEGT));
+ DO JL=1,INEGT
+ ZRVT(JL) = PRVT(I1(JL),I2(JL),I3(JL))
+ ZCIT(JL) = PCIT(I1(JL),I2(JL),I3(JL))
+ ZZT(JL) = PT(I1(JL),I2(JL),I3(JL))
+ ZPRES(JL) = PPABST(I1(JL),I2(JL),I3(JL))
+ ENDDO
+ ALLOCATE(ZZW(INEGT))
+ ALLOCATE(ZUSW(INEGT))
+ ALLOCATE(ZSSI(INEGT))
+ ZZW(:) = EXP( XALPI - XBETAI/ZZT(:) - XGAMI*ALOG(ZZT(:) ) ) ! es_i
+ ZZW(:) = MIN(ZPRES(:)/2., ZZW(:)) ! safety limitation
+ ZSSI(:) = ZRVT(:)*( ZPRES(:)-ZZW(:) ) / ( (XMV/XMD) * ZZW(:) ) - 1.0
+ ! Supersaturation over ice
+ ZUSW(:) = EXP( XALPW - XBETAW/ZZT(:) - XGAMW*ALOG(ZZT(:) ) ) ! es_w
+ ZUSW(:) = MIN(ZPRES(:)/2.,ZUSW(:)) ! safety limitation
+ ZUSW(:) = ( ZUSW(:)/ZZW(:) )*( (ZPRES(:)-ZZW(:))/(ZPRES(:)-ZUSW(:)) ) - 1.0
+ ! Supersaturation of saturated water vapor over ice
+!
+!* 3.1 compute the heterogeneous nucleation source: RVHENI
+!
+!* 3.1.1 compute the cloud ice concentration
+!
+ ZZW(:) = 0.0
+ ZSSI(:) = MIN( ZSSI(:), ZUSW(:) ) ! limitation of SSi according to SSw=0
+ WHERE( (ZZT(:)<XTT-5.0) .AND. (ZSSI(:)>0.0) )
+ ZZW(:) = XNU20 * EXP( XALPHA2*ZSSI(:)-XBETA2 )
+ END WHERE
+ WHERE( (ZZT(:)<=XTT-2.0) .AND. (ZZT(:)>=XTT-5.0) .AND. (ZSSI(:)>0.0) )
+ ZZW(:) = MAX( XNU20 * EXP( -XBETA2 ),XNU10 * EXP( -XBETA1*(ZZT(:)-XTT) ) * &
+ ( ZSSI(:)/ZUSW(:) )**XALPHA1 )
+ END WHERE
+ ZZW(:) = ZZW(:) - ZCIT(:)
+ IF( MAXVAL(ZZW(:)) > 0.0 ) THEN
+!
+!* 3.1.2 update the r_i and r_v mixing ratios
+!
+ ZZW(:) = MIN( ZZW(:),50.E3 ) ! limitation provisoire a 50 l^-1
+ ZW(:,:,:) = UNPACK( ZZW(:),MASK=GNEGT(:,:,:),FIELD=0.0 )
+ ZW(:,:,:) = MAX( ZW(:,:,:) ,0.0 ) *XMNU0/(PRHODREF(:,:,:)*PTSTEP)
+ PRIS(:,:,:) = PRIS(:,:,:) + ZW(:,:,:)
+ PRVS(:,:,:) = PRVS(:,:,:) - ZW(:,:,:)
+ IF ( KRR == 7 ) THEN
+ PTHS(:,:,:) = PTHS(:,:,:) + ZW(:,:,:)*(XLSTT+(XCPV-XCI)*(PT(:,:,:)-XTT)) &
+ /( (XCPD + XCPV*PRVT(:,:,:) + XCL*(PRCT(:,:,:)+PRRT(:,:,:)) &
+ + XCI*(PRIT(:,:,:)+PRST(:,:,:)+PRGT(:,:,:)+PRHT(:,:,:)))*PEXNREF(:,:,:) )
+ ELSE IF( KRR == 6 ) THEN
+ PTHS(:,:,:) = PTHS(:,:,:) + ZW(:,:,:)*(XLSTT+(XCPV-XCI)*(PT(:,:,:)-XTT)) &
+ /( (XCPD + XCPV*PRVT(:,:,:) + XCL*(PRCT(:,:,:)+PRRT(:,:,:)) &
+ + XCI*(PRIT(:,:,:)+PRST(:,:,:)+PRGT(:,:,:)))*PEXNREF(:,:,:) )
+ END IF
+ ! f(L_s*(RVHENI))
+ ZZW(:) = MAX( ZZW(:)+ZCIT(:),ZCIT(:) )
+ PCIT(:,:,:) = MAX( UNPACK( ZZW(:),MASK=GNEGT(:,:,:),FIELD=0.0 ) , &
+ PCIT(:,:,:) )
+ END IF
+ DEALLOCATE(ZSSI)
+ DEALLOCATE(ZUSW)
+ DEALLOCATE(ZZW)
+ DEALLOCATE(ZPRES)
+ DEALLOCATE(ZZT)
+ DEALLOCATE(ZCIT)
+ DEALLOCATE(ZRVT)
+END IF
+!
+!* 3.1.3 budget storage
+!
+IF (LBUDGET_TH) CALL BUDGET (PTHS(:,:,:)*PRHODJ(:,:,:),4,'HENU_BU_RTH')
+IF (LBUDGET_RV) CALL BUDGET (PRVS(:,:,:)*PRHODJ(:,:,:),6,'HENU_BU_RRV')
+IF (LBUDGET_RI) CALL BUDGET (PRIS(:,:,:)*PRHODJ(:,:,:),9,'HENU_BU_RRI')
+!
+END SUBROUTINE RAIN_ICE_NUCLEATION
+
+FUNCTION COUNTJV(LTAB,I1,I2,I3) RESULT(IC)
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.2 declaration of local variables
+!
+!
+LOGICAL, DIMENSION(:,:,:) :: LTAB ! Mask
+INTEGER, DIMENSION(:) :: I1,I2,I3 ! Used to replace the COUNT and PACK
+INTEGER :: JI,JJ,JK,IC
+!
+!-------------------------------------------------------------------------------
+!
+IC = 0
+DO JK = 1,SIZE(LTAB,3)
+ DO JJ = 1,SIZE(LTAB,2)
+ DO JI = 1,SIZE(LTAB,1)
+ IF( LTAB(JI,JJ,JK) ) THEN
+ IC = IC +1
+ I1(IC) = JI
+ I2(IC) = JJ
+ I3(IC) = JK
+ END IF
+ END DO
+ END DO
+END DO
+!
+END FUNCTION COUNTJV
+
+END MODULE MODE_RAIN_ICE_NUCLEATION
diff --git a/src/MNH/rain_ice_sedimentation_split.f90 b/src/MNH/rain_ice_sedimentation_split.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d7637345ed02225b6f2e448e91f151ffcf85d3ec
--- /dev/null
+++ b/src/MNH/rain_ice_sedimentation_split.f90
@@ -0,0 +1,643 @@
+!MNH_LIC Copyright 1995-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! Modifications:
+! P. Wautelet 25/02/2019: split rain_ice (cleaner and easier to maintain/debug)
+!-----------------------------------------------------------------
+MODULE MODE_RAIN_ICE_SEDIMENTATION_SPLIT
+
+ IMPLICIT NONE
+
+ PRIVATE
+
+ PUBLIC RAIN_ICE_SEDIMENTATION_SPLIT
+
+CONTAINS
+
+SUBROUTINE RAIN_ICE_SEDIMENTATION_SPLIT(KIB, KIE, KJB, KJE, KKB, KKE, KKTB, KKTE, KKT, KKL,&
+ KSPLITR,PTSTEP, &
+ KRR,OSEDIC,ODEPOSC,PINPRC,PINDEP,PINPRR,PINPRS,PINPRG,PDZZ,PRHODREF,PPABST,PTHT,PRHODJ,&
+ PINPRR3D,PRCS,PRCT,PRRS,PRRT,PRIS,PRIT,PRSS,PRST,PRGS,PRGT,PSEA,PTOWN,PINPRH,PRHS,PRHT,PFPR)
+!
+!* 0. DECLARATIONS
+! ------------
+!
+use MODD_BUDGET, only: LBUDGET_RC, LBUDGET_RG, LBUDGET_RH, LBUDGET_RI, LBUDGET_RR, LBUDGET_RS
+use MODD_CST, only: XCPD, XP00, XRD, XRHOLW
+use MODD_PARAM_ICE, only: XVDEPOSC
+use MODD_RAIN_ICE_DESCR, only: XCC, XCONC_LAND, xconc_sea, xconc_urban, XDC, XCEXVT, &
+ XALPHAC, XNUC, XALPHAC2, XNUC2, XLBEXC, XRTMIN, XLBEXC, XLBC
+use MODD_RAIN_ICE_PARAM, only: XEXSEDG, XEXSEDH, XEXCSEDI, XEXSEDR, XEXSEDS, &
+ XFSEDG, XFSEDH, XFSEDI, XFSEDR, XFSEDS, XFSEDC
+!
+use MODI_BUDGET
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+INTEGER, INTENT(IN) :: KIB, KIE, KJB, KJE, KKB, KKE, KKTB, KKTE, KKT
+INTEGER, INTENT(IN) :: KKL !vert. levels type 1=MNH -1=ARO
+INTEGER, INTENT(IN) :: KSPLITR ! Number of small time step
+ ! integration for rain sedimendation
+REAL, INTENT(IN) :: PTSTEP ! Double Time step
+ ! (single if cold start)
+INTEGER, INTENT(IN) :: KRR ! Number of moist variable
+LOGICAL, INTENT(IN) :: OSEDIC ! Switch for droplet sedim.
+LOGICAL, INTENT(IN) :: ODEPOSC ! Switch for droplet depos.
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRC ! Cloud instant precip
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINDEP ! Cloud instant deposition
+REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRR ! Rain instant precip
+REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRS ! Snow instant precip
+REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRG ! Graupel instant precip
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Layer thikness (m)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! absolute pressure at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PINPRR3D! Rain inst precip 3D
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Pristine ice m.r. at t
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRSS ! Snow/aggregate m.r. source
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRGS ! Graupel m.r. source
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGT ! Graupel/hail m.r. at t
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PSEA ! Sea Mask
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PTOWN ! Fraction that is town
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(OUT) :: PINPRH ! Hail instant precip
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(INOUT) :: PRHS ! Hail m.r. source
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(IN) :: PRHT ! Hail m.r. at t
+REAL, DIMENSION(:,:,:,:), OPTIONAL, INTENT(OUT) :: PFPR ! upper-air precipitation fluxes
+!
+!* 0.2 declaration of local variables
+!
+!
+INTEGER, SAVE :: IOLDALLOCC = 6000
+INTEGER, SAVE :: IOLDALLOCR = 6000
+INTEGER, SAVE :: IOLDALLOCI = 6000
+INTEGER, SAVE :: IOLDALLOCS = 6000
+INTEGER, SAVE :: IOLDALLOCG = 6000
+INTEGER, SAVE :: IOLDALLOCH = 6000
+INTEGER :: ILENALLOCC,ILENALLOCR,ILENALLOCI,ILENALLOCS,ILENALLOCG,ILENALLOCH
+INTEGER :: ILISTLENC,ILISTLENR,ILISTLENI,ILISTLENS,ILISTLENG,ILISTLENH
+INTEGER :: ISEDIMR,ISEDIMC, ISEDIMI, ISEDIMS, ISEDIMG, ISEDIMH
+INTEGER :: JK ! Vertical loop index for the rain sedimentation
+INTEGER :: JN ! Temporal loop index for the rain sedimentation
+INTEGER :: JJ ! Loop index for the interpolation
+INTEGER :: JL
+INTEGER, DIMENSION(SIZE(PRCS)) :: IC1,IC2,IC3 ! Used to replace the COUNT
+INTEGER, DIMENSION(SIZE(PRCS)) :: IR1,IR2,IR3 ! Used to replace the COUNT
+INTEGER, DIMENSION(SIZE(PRCS)) :: IS1,IS2,IS3 ! Used to replace the COUNT
+INTEGER, DIMENSION(SIZE(PRCS)) :: II1,II2,II3 ! Used to replace the COUNT
+INTEGER, DIMENSION(SIZE(PRCS)) :: IG1,IG2,IG3 ! Used to replace the COUNT
+INTEGER, DIMENSION(SIZE(PRCS)) :: IH1,IH2,IH3 ! Used to replace the COUNT
+INTEGER, DIMENSION(:), ALLOCATABLE :: ILISTR,ILISTC,ILISTI,ILISTS,ILISTG,ILISTH
+LOGICAL, DIMENSION(SIZE(PRCS,1),SIZE(PRCS,2)):: GDEP
+LOGICAL, DIMENSION(SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) &
+ :: GSEDIMR,GSEDIMC, GSEDIMI, GSEDIMS, GSEDIMG, GSEDIMH ! Test where to compute the SED processes
+REAL :: ZINVTSTEP
+REAL :: ZTSPLITR ! Small time step for rain sedimentation
+REAL, DIMENSION(SIZE(XRTMIN)) :: ZRTMIN
+! XRTMIN = Minimum value for the mixing ratio
+! ZRTMIN = Minimum value for the source (tendency)
+REAL, DIMENSION(:), ALLOCATABLE :: ZRCS ! Cloud water m.r. source
+REAL, DIMENSION(:), ALLOCATABLE :: ZRRS ! Rain water m.r. source
+REAL, DIMENSION(:), ALLOCATABLE :: ZRIS ! Pristine ice m.r. source
+REAL, DIMENSION(:), ALLOCATABLE :: ZRSS ! Snow/aggregate m.r. source
+REAL, DIMENSION(:), ALLOCATABLE :: ZRGS ! Graupel m.r. source
+REAL, DIMENSION(:), ALLOCATABLE :: ZRHS ! Hail m.r. source
+REAL, DIMENSION(:), ALLOCATABLE :: ZRCT ! Cloud water m.r. at t
+REAL, DIMENSION(:), ALLOCATABLE :: ZRHODREFC,& ! RHO Dry REFerence
+ ZRHODREFR,& ! RHO Dry REFerence
+ ZRHODREFI,& ! RHO Dry REFerence
+ ZRHODREFS,& ! RHO Dry REFerence
+ ZRHODREFG,& ! RHO Dry REFerence
+ ZRHODREFH,& ! RHO Dry REFerence
+ ZCC, & ! terminal velocity
+ ZFSEDC1D, & ! For cloud sedimentation
+ ZWLBDC, & ! Slope parameter of the droplet distribution
+ ZCONC, & ! Concentration des aerosols
+ ZRAY1D, & ! Mean radius
+ ZWLBDA, & ! Libre parcours moyen
+ ZZT, & ! Temperature
+ ZPRES ! Pressure
+REAL, DIMENSION(SIZE(PRCS,1),SIZE(PRCS,2)) &
+ :: ZCONC_TMP ! Weighted concentration
+REAL, DIMENSION(SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) :: ZCONC3D ! droplet condensation
+REAL, DIMENSION(SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) :: &
+ ZRAY, & ! Cloud Mean radius
+ ZLBC, & ! XLBC weighted by sea fraction
+ ZFSEDC
+REAL, DIMENSION(SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) &
+ :: ZPRCS,ZPRRS,ZPRSS,ZPRGS,ZPRHS ! Mixing ratios created during the time step
+REAL, DIMENSION(SIZE(PRCS,1),SIZE(PRCS,2),SIZE(PRCS,3)) &
+ :: ZW ! work array
+REAL, DIMENSION(SIZE(PRCS,1),SIZE(PRCS,2),0:SIZE(PRCS,3)+1) &
+ :: ZWSED ! sedimentation fluxes
+!-------------------------------------------------------------------------------
+!
+!
+! O. Initialization of for sedimentation
+!
+ZINVTSTEP=1./PTSTEP
+ZTSPLITR= PTSTEP / FLOAT(KSPLITR)
+!
+IF (OSEDIC) PINPRC (:,:) = 0.
+IF (ODEPOSC) PINDEP (:,:) = 0.
+PINPRR (:,:) = 0.
+PINPRR3D (:,:,:) = 0.
+PINPRS (:,:) = 0.
+PINPRG (:,:) = 0.
+IF ( KRR == 7 ) PINPRH (:,:) = 0.
+IF (PRESENT(PFPR)) PFPR(:,:,:,:) = 0.
+!
+!* 1. Parameters for cloud sedimentation
+!
+ IF (OSEDIC) THEN
+ ZRAY(:,:,:) = 0.
+ ZLBC(:,:,:) = XLBC(1)
+ ZFSEDC(:,:,:) = XFSEDC(1)
+ ZCONC3D(:,:,:)= XCONC_LAND
+ ZCONC_TMP(:,:)= XCONC_LAND
+ IF (PRESENT(PSEA)) THEN
+ ZCONC_TMP(:,:)=PSEA(:,:)*XCONC_SEA+(1.-PSEA(:,:))*XCONC_LAND
+
+ DO JK=KKTB,KKTE
+ ZLBC(:,:,JK) = PSEA(:,:)*XLBC(2)+(1.-PSEA(:,:))*XLBC(1)
+ ZFSEDC(:,:,JK) = (PSEA(:,:)*XFSEDC(2)+(1.-PSEA(:,:))*XFSEDC(1))
+ ZFSEDC(:,:,JK) = MAX(MIN(XFSEDC(1),XFSEDC(2)),ZFSEDC(:,:,JK))
+ ZCONC3D(:,:,JK)= (1.-PTOWN(:,:))*ZCONC_TMP(:,:)+PTOWN(:,:)*XCONC_URBAN
+ ZRAY(:,:,JK) = 0.5*((1.-PSEA(:,:))*GAMMA(XNUC+1.0/XALPHAC)/(GAMMA(XNUC)) + &
+ PSEA(:,:)*GAMMA(XNUC2+1.0/XALPHAC2)/(GAMMA(XNUC2)))
+ END DO
+ ELSE
+ ZCONC3D(:,:,:) = XCONC_LAND
+ ZRAY(:,:,:) = 0.5*(GAMMA(XNUC+1.0/XALPHAC)/(GAMMA(XNUC)))
+ END IF
+ ZRAY(:,:,:) = MAX(1.,ZRAY(:,:,:))
+ ZLBC(:,:,:) = MAX(MIN(XLBC(1),XLBC(2)),ZLBC(:,:,:))
+ ENDIF
+!
+!* 2. compute the fluxes
+!
+! optimization by looking for locations where
+! the precipitating fields are larger than a minimal value only !!!
+! For optimization we consider each variable separately
+
+ZRTMIN(:) = XRTMIN(:) * ZINVTSTEP
+IF (OSEDIC) GSEDIMC(:,:,:) = .FALSE.
+GSEDIMR(:,:,:) = .FALSE.
+GSEDIMI(:,:,:) = .FALSE.
+GSEDIMS(:,:,:) = .FALSE.
+GSEDIMG(:,:,:) = .FALSE.
+IF ( KRR == 7 ) GSEDIMH(:,:,:) = .FALSE.
+!
+ILENALLOCR = 0
+IF (OSEDIC) ILENALLOCC = 0
+ILENALLOCI = 0
+ILENALLOCS = 0
+ILENALLOCG = 0
+IF ( KRR == 7 ) ILENALLOCH = 0
+!
+! ZPiS = Specie i source creating during the current time step
+! PRiS = Source of the previous time step
+!
+IF (OSEDIC) THEN
+ ZPRCS(:,:,:) = 0.0
+ ZPRCS(:,:,:) = PRCS(:,:,:)-PRCT(:,:,:)* ZINVTSTEP
+ PRCS(:,:,:) = PRCT(:,:,:)* ZINVTSTEP
+END IF
+ZPRRS(:,:,:) = 0.0
+ZPRSS(:,:,:) = 0.0
+ZPRGS(:,:,:) = 0.0
+IF ( KRR == 7 ) ZPRHS(:,:,:) = 0.0
+!
+ZPRRS(:,:,:) = PRRS(:,:,:)-PRRT(:,:,:)* ZINVTSTEP
+ZPRSS(:,:,:) = PRSS(:,:,:)-PRST(:,:,:)* ZINVTSTEP
+ZPRGS(:,:,:) = PRGS(:,:,:)-PRGT(:,:,:)* ZINVTSTEP
+IF ( KRR == 7 ) ZPRHS(:,:,:) = PRHS(:,:,:)-PRHT(:,:,:)* ZINVTSTEP
+PRRS(:,:,:) = PRRT(:,:,:)* ZINVTSTEP
+PRSS(:,:,:) = PRST(:,:,:)* ZINVTSTEP
+PRGS(:,:,:) = PRGT(:,:,:)* ZINVTSTEP
+IF ( KRR == 7 ) PRHS(:,:,:) = PRHT(:,:,:)* ZINVTSTEP
+!
+! PRiS = Source of the previous time step + source created during the subtime
+! step
+!
+DO JN = 1 , KSPLITR
+ IF( JN==1 ) THEN
+ IF (OSEDIC) PRCS(:,:,:) = PRCS(:,:,:) + ZPRCS(:,:,:)/KSPLITR
+ PRRS(:,:,:) = PRRS(:,:,:) + ZPRRS(:,:,:)/KSPLITR
+ PRSS(:,:,:) = PRSS(:,:,:) + ZPRSS(:,:,:)/KSPLITR
+ PRGS(:,:,:) = PRGS(:,:,:) + ZPRGS(:,:,:)/KSPLITR
+ IF ( KRR == 7 ) PRHS(:,:,:) = PRHS(:,:,:) + ZPRHS(:,:,:)/KSPLITR
+ DO JK = KKTB , KKTE
+ ZW(:,:,JK) =ZTSPLITR/(PRHODREF(:,:,JK)* PDZZ(:,:,JK))
+ END DO
+ ELSE
+ IF (OSEDIC) PRCS(:,:,:) = PRCS(:,:,:) + ZPRCS(:,:,:)*ZTSPLITR
+ PRRS(:,:,:) = PRRS(:,:,:) + ZPRRS(:,:,:)*ZTSPLITR
+ PRSS(:,:,:) = PRSS(:,:,:) + ZPRSS(:,:,:)*ZTSPLITR
+ PRGS(:,:,:) = PRGS(:,:,:) + ZPRGS(:,:,:)*ZTSPLITR
+ IF ( KRR == 7 ) PRHS(:,:,:) = PRHS(:,:,:) + ZPRHS(:,:,:)*ZTSPLITR
+ END IF
+ !
+ IF (OSEDIC) GSEDIMC(KIB:KIE,KJB:KJE,KKTB:KKTE) = &
+ PRCS(KIB:KIE,KJB:KJE,KKTB:KKTE)>ZRTMIN(2)
+ GSEDIMR(KIB:KIE,KJB:KJE,KKTB:KKTE) = &
+ PRRS(KIB:KIE,KJB:KJE,KKTB:KKTE)>ZRTMIN(3)
+ GSEDIMI(KIB:KIE,KJB:KJE,KKTB:KKTE) = &
+ PRIS(KIB:KIE,KJB:KJE,KKTB:KKTE)>ZRTMIN(4)
+ GSEDIMS(KIB:KIE,KJB:KJE,KKTB:KKTE) = &
+ PRSS(KIB:KIE,KJB:KJE,KKTB:KKTE)>ZRTMIN(5)
+ GSEDIMG(KIB:KIE,KJB:KJE,KKTB:KKTE) = &
+ PRGS(KIB:KIE,KJB:KJE,KKTB:KKTE)>ZRTMIN(6)
+ IF ( KRR == 7 ) GSEDIMH(KIB:KIE,KJB:KJE,KKTB:KKTE) = &
+ PRHS(KIB:KIE,KJB:KJE,KKTB:KKTE)>ZRTMIN(7)
+!
+ IF (OSEDIC) ISEDIMC = COUNTJV( GSEDIMC(:,:,:),IC1(:),IC2(:),IC3(:))
+ ISEDIMR = COUNTJV( GSEDIMR(:,:,:),IR1(:),IR2(:),IR3(:))
+ ISEDIMI = COUNTJV( GSEDIMI(:,:,:),II1(:),II2(:),II3(:))
+ ISEDIMS = COUNTJV( GSEDIMS(:,:,:),IS1(:),IS2(:),IS3(:))
+ ISEDIMG = COUNTJV( GSEDIMG(:,:,:),IG1(:),IG2(:),IG3(:))
+ IF ( KRR == 7 ) ISEDIMH = COUNTJV( GSEDIMH(:,:,:),IH1(:),IH2(:),IH3(:))
+!
+!* 2.1 for cloud
+!
+ IF (OSEDIC) THEN
+ ZWSED(:,:,:) = 0.
+ IF( JN==1 ) PRCS(:,:,:) = PRCS(:,:,:) * PTSTEP
+ IF( ISEDIMC >= 1 ) THEN
+ IF ( ISEDIMC .GT. ILENALLOCC ) THEN
+ IF ( ILENALLOCC .GT. 0 ) THEN
+ DEALLOCATE (ZRCS, ZRHODREFC, ILISTC,ZWLBDC,ZCONC,ZRCT, &
+ ZZT,ZPRES,ZRAY1D,ZFSEDC1D,ZWLBDA,ZCC )
+ END IF
+ ILENALLOCC = MAX (IOLDALLOCC, 2*ISEDIMC )
+ IOLDALLOCC = ILENALLOCC
+ ALLOCATE(ZRCS(ILENALLOCC), ZRHODREFC(ILENALLOCC), ILISTC(ILENALLOCC), &
+ ZWLBDC(ILENALLOCC), ZCONC(ILENALLOCC), ZRCT(ILENALLOCC), ZZT(ILENALLOCC), &
+ ZPRES(ILENALLOCC), ZRAY1D(ILENALLOCC), ZFSEDC1D(ILENALLOCC), &
+ ZWLBDA(ILENALLOCC), ZCC(ILENALLOCC) )
+ END IF
+!
+ DO JL=1,ISEDIMC
+ ZRCS(JL) = PRCS(IC1(JL),IC2(JL),IC3(JL))
+ ZRHODREFC(JL) = PRHODREF(IC1(JL),IC2(JL),IC3(JL))
+ ZWLBDC(JL) = ZLBC(IC1(JL),IC2(JL),IC3(JL))
+ ZCONC(JL) = ZCONC3D(IC1(JL),IC2(JL),IC3(JL))
+ ZRCT(JL) = PRCT(IC1(JL),IC2(JL),IC3(JL))
+ ZZT(JL) = PTHT(IC1(JL),IC2(JL),IC3(JL))
+ ZPRES(JL) = PPABST(IC1(JL),IC2(JL),IC3(JL))
+ ZRAY1D(JL) = ZRAY(IC1(JL),IC2(JL),IC3(JL))
+ ZFSEDC1D(JL) = ZFSEDC(IC1(JL),IC2(JL),IC3(JL))
+ END DO
+!
+ ILISTLENC = 0
+ DO JL=1,ISEDIMC
+ IF( ZRCS(JL) .GT. ZRTMIN(2) ) THEN
+ ILISTLENC = ILISTLENC + 1
+ ILISTC(ILISTLENC) = JL
+ END IF
+ END DO
+ DO JJ = 1, ILISTLENC
+ JL = ILISTC(JJ)
+ IF (ZRCS(JL) .GT. ZRTMIN(2) .AND. ZRCT(JL) .GT. XRTMIN(2)) THEN
+ ZWLBDC(JL) = ZWLBDC(JL) * ZCONC(JL) / (ZRHODREFC(JL) * ZRCT(JL))
+ ZWLBDC(JL) = ZWLBDC(JL)**XLBEXC
+ ZRAY1D(JL) = ZRAY1D(JL) / ZWLBDC(JL) !! ZRAY : mean diameter=M(1)/2
+ ZZT(JL) = ZZT(JL) * (ZPRES(JL)/XP00)**(XRD/XCPD)
+ ZWLBDA(JL) = 6.6E-8*(101325./ZPRES(JL))*(ZZT(JL)/293.15)
+ ZCC(JL) = XCC*(1.+1.26*ZWLBDA(JL)/ZRAY1D(JL)) !! XCC modified for cloud
+ ZWSED (IC1(JL),IC2(JL),IC3(JL))= ZRHODREFC(JL)**(-XCEXVT +1 ) * &
+ ZWLBDC(JL)**(-XDC)*ZCC(JL)*ZFSEDC1D(JL) * ZRCS(JL)
+ END IF
+ END DO
+ END IF
+ DO JK = KKTB , KKTE
+ PRCS(:,:,JK) = PRCS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
+ END DO
+ IF (PRESENT(PFPR)) THEN
+ DO JK = KKTB , KKTE
+ PFPR(:,:,JK,2)=ZWSED(:,:,JK)
+ ENDDO
+ ENDIF
+ PINPRC(:,:) = PINPRC(:,:) + ZWSED(:,:,KKB) / XRHOLW / KSPLITR
+ IF( JN==KSPLITR ) THEN
+ PRCS(:,:,:) = PRCS(:,:,:) * ZINVTSTEP
+ END IF
+ END IF
+!
+!* 2.2 for rain
+!
+ IF( JN==1 ) PRRS(:,:,:) = PRRS(:,:,:) * PTSTEP
+ ZWSED(:,:,:) = 0.
+ IF( ISEDIMR >= 1 ) THEN
+ IF ( ISEDIMR .GT. ILENALLOCR ) THEN
+ IF ( ILENALLOCR .GT. 0 ) THEN
+ DEALLOCATE (ZRRS, ZRHODREFR, ILISTR)
+ END IF
+ ILENALLOCR = MAX (IOLDALLOCR, 2*ISEDIMR )
+ IOLDALLOCR = ILENALLOCR
+ ALLOCATE(ZRRS(ILENALLOCR), ZRHODREFR(ILENALLOCR), ILISTR(ILENALLOCR))
+ END IF
+!
+ DO JL=1,ISEDIMR
+ ZRRS(JL) = PRRS(IR1(JL),IR2(JL),IR3(JL))
+ ZRHODREFR(JL) = PRHODREF(IR1(JL),IR2(JL),IR3(JL))
+ END DO
+!
+ ILISTLENR = 0
+ DO JL=1,ISEDIMR
+ IF( ZRRS(JL) .GT. ZRTMIN(3) ) THEN
+ ILISTLENR = ILISTLENR + 1
+ ILISTR(ILISTLENR) = JL
+ END IF
+ END DO
+ DO JJ = 1, ILISTLENR
+ JL = ILISTR(JJ)
+ ZWSED (IR1(JL),IR2(JL),IR3(JL))= XFSEDR * ZRRS(JL)**XEXSEDR * &
+ ZRHODREFR(JL)**(XEXSEDR-XCEXVT)
+ END DO
+ END IF
+ DO JK = KKTB , KKTE
+ PRRS(:,:,JK) = PRRS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
+ END DO
+ IF (PRESENT(PFPR)) THEN
+ DO JK = KKTB , KKTE
+ PFPR(:,:,JK,3)=ZWSED(:,:,JK)
+ ENDDO
+ ENDIF
+ PINPRR(:,:) = PINPRR(:,:) + ZWSED(:,:,KKB)/XRHOLW/KSPLITR
+ PINPRR3D(:,:,:) = PINPRR3D(:,:,:) + ZWSED(:,:,1:KKT)/XRHOLW/KSPLITR
+ IF( JN==KSPLITR ) THEN
+ PRRS(:,:,:) = PRRS(:,:,:) * ZINVTSTEP
+ END IF
+!
+!* 2.3 for pristine ice
+!
+ IF( JN==1 ) PRIS(:,:,:) = PRIS(:,:,:) * PTSTEP
+ ZWSED(:,:,:) = 0.
+ IF( ISEDIMI >= 1 ) THEN
+ IF ( ISEDIMI .GT. ILENALLOCI ) THEN
+ IF ( ILENALLOCI .GT. 0 ) THEN
+ DEALLOCATE (ZRIS, ZRHODREFI, ILISTI)
+ END IF
+ ILENALLOCI = MAX (IOLDALLOCI, 2*ISEDIMI )
+ IOLDALLOCI = ILENALLOCI
+ ALLOCATE(ZRIS(ILENALLOCI), ZRHODREFI(ILENALLOCI), ILISTI(ILENALLOCI))
+ END IF
+!
+ DO JL=1,ISEDIMI
+ ZRIS(JL) = PRIS(II1(JL),II2(JL),II3(JL))
+ ZRHODREFI(JL) = PRHODREF(II1(JL),II2(JL),II3(JL))
+ END DO
+!
+ ILISTLENI = 0
+ DO JL=1,ISEDIMI
+ IF( ZRIS(JL) .GT. MAX(ZRTMIN(4),1.0E-7 )) THEN ! limitation of the McF&H formula
+ ILISTLENI = ILISTLENI + 1
+ ILISTI(ILISTLENI) = JL
+ END IF
+ END DO
+ DO JJ = 1, ILISTLENI
+ JL = ILISTI(JJ)
+ ZWSED (II1(JL),II2(JL),II3(JL))= XFSEDI * ZRIS(JL) * &
+ ZRHODREFI(JL)**(1.0-XCEXVT) * & ! McF&H
+ MAX( 0.05E6,-0.15319E6-0.021454E6* &
+ ALOG(ZRHODREFI(JL)*ZRIS(JL)) )**XEXCSEDI
+ END DO
+ END IF
+ DO JK = KKTB , KKTE
+ PRIS(:,:,JK) = PRIS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
+ END DO
+ IF (PRESENT(PFPR)) THEN
+ DO JK = KKTB , KKTE
+ PFPR(:,:,JK,4)=ZWSED(:,:,JK)
+ ENDDO
+ ENDIF
+ IF( JN==KSPLITR ) THEN
+ PRIS(:,:,:) = PRIS(:,:,:) * ZINVTSTEP
+ END IF
+!
+!* 2.4 for aggregates/snow
+!
+ IF( JN==1 ) PRSS(:,:,:) = PRSS(:,:,:) * PTSTEP
+ ZWSED(:,:,:) = 0.
+ IF( ISEDIMS >= 1 ) THEN
+ IF ( ISEDIMS .GT. ILENALLOCS ) THEN
+ IF ( ILENALLOCS .GT. 0 ) THEN
+ DEALLOCATE (ZRSS, ZRHODREFS, ILISTS)
+ END IF
+ ILENALLOCS = MAX (IOLDALLOCS, 2*ISEDIMS )
+ IOLDALLOCS = ILENALLOCS
+ ALLOCATE(ZRSS(ILENALLOCS), ZRHODREFS(ILENALLOCS), ILISTS(ILENALLOCS))
+ END IF
+!
+ DO JL=1,ISEDIMS
+ ZRSS(JL) = PRSS(IS1(JL),IS2(JL),IS3(JL))
+ ZRHODREFS(JL) = PRHODREF(IS1(JL),IS2(JL),IS3(JL))
+ END DO
+!
+ ILISTLENS = 0
+ DO JL=1,ISEDIMS
+ IF( ZRSS(JL) .GT. ZRTMIN(5) ) THEN
+ ILISTLENS = ILISTLENS + 1
+ ILISTS(ILISTLENS) = JL
+ END IF
+ END DO
+ DO JJ = 1, ILISTLENS
+ JL = ILISTS(JJ)
+ ZWSED (IS1(JL),IS2(JL),IS3(JL))= XFSEDS * ZRSS(JL)**XEXSEDS * &
+ ZRHODREFS(JL)**(XEXSEDS-XCEXVT)
+ END DO
+ END IF
+ DO JK = KKTB , KKTE
+ PRSS(:,:,JK) = PRSS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
+ END DO
+ IF (PRESENT(PFPR)) THEN
+ DO JK = KKTB , KKTE
+ PFPR(:,:,JK,5)=ZWSED(:,:,JK)
+ ENDDO
+ ENDIF
+ PINPRS(:,:) = PINPRS(:,:) + ZWSED(:,:,KKB)/XRHOLW/KSPLITR
+ IF( JN==KSPLITR ) THEN
+ PRSS(:,:,:) = PRSS(:,:,:) * ZINVTSTEP
+ END IF
+!
+!* 2.5 for graupeln
+!
+ ZWSED(:,:,:) = 0.
+ IF( JN==1 ) PRGS(:,:,:) = PRGS(:,:,:) * PTSTEP
+ IF( ISEDIMG >= 1 ) THEN
+ IF ( ISEDIMG .GT. ILENALLOCG ) THEN
+ IF ( ILENALLOCG .GT. 0 ) THEN
+ DEALLOCATE (ZRGS, ZRHODREFG, ILISTG)
+ END IF
+ ILENALLOCG = MAX (IOLDALLOCG, 2*ISEDIMG )
+ IOLDALLOCG = ILENALLOCG
+ ALLOCATE(ZRGS(ILENALLOCG), ZRHODREFG(ILENALLOCG), ILISTG(ILENALLOCG))
+ END IF
+!
+ DO JL=1,ISEDIMG
+ ZRGS(JL) = PRGS(IG1(JL),IG2(JL),IG3(JL))
+ ZRHODREFG(JL) = PRHODREF(IG1(JL),IG2(JL),IG3(JL))
+ END DO
+!
+ ILISTLENG = 0
+ DO JL=1,ISEDIMG
+ IF( ZRGS(JL) .GT. ZRTMIN(6) ) THEN
+ ILISTLENG = ILISTLENG + 1
+ ILISTG(ILISTLENG) = JL
+ END IF
+ END DO
+ DO JJ = 1, ILISTLENG
+ JL = ILISTG(JJ)
+ ZWSED (IG1(JL),IG2(JL),IG3(JL))= XFSEDG * ZRGS(JL)**XEXSEDG * &
+ ZRHODREFG(JL)**(XEXSEDG-XCEXVT)
+ END DO
+END IF
+ DO JK = KKTB , KKTE
+ PRGS(:,:,JK) = PRGS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
+ END DO
+ IF (PRESENT(PFPR)) THEN
+ DO JK = KKTB , KKTE
+ PFPR(:,:,JK,6)=ZWSED(:,:,JK)
+ ENDDO
+ ENDIF
+ PINPRG(:,:) = PINPRG(:,:) + ZWSED(:,:,KKB)/XRHOLW/KSPLITR
+ IF( JN==KSPLITR ) THEN
+ PRGS(:,:,:) = PRGS(:,:,:) * ZINVTSTEP
+ END IF
+!
+!* 2.6 for hail
+!
+ IF ( KRR == 7 ) THEN
+ IF( JN==1 ) PRHS(:,:,:) = PRHS(:,:,:) * PTSTEP
+ ZWSED(:,:,:) = 0.
+ IF( ISEDIMH >= 1 ) THEN
+ IF ( ISEDIMH .GT. ILENALLOCH ) THEN
+ IF ( ILENALLOCH .GT. 0 ) THEN
+ DEALLOCATE (ZRHS, ZRHODREFH, ILISTH)
+ END IF
+ ILENALLOCH = MAX (IOLDALLOCH, 2*ISEDIMH )
+ IOLDALLOCH = ILENALLOCH
+ ALLOCATE(ZRHS(ILENALLOCH), ZRHODREFH(ILENALLOCH), ILISTH(ILENALLOCH))
+ END IF
+!
+ DO JL=1,ISEDIMH
+ ZRHS(JL) = PRHS(IH1(JL),IH2(JL),IH3(JL))
+ ZRHODREFH(JL) = PRHODREF(IH1(JL),IH2(JL),IH3(JL))
+ END DO
+!
+ ILISTLENH = 0
+ DO JL=1,ISEDIMH
+ IF( ZRHS(JL) .GT. ZRTMIN(7) ) THEN
+ ILISTLENH = ILISTLENH + 1
+ ILISTH(ILISTLENH) = JL
+ END IF
+ END DO
+ DO JJ = 1, ILISTLENH
+ JL = ILISTH(JJ)
+ ZWSED (IH1(JL),IH2(JL),IH3(JL))= XFSEDH * ZRHS(JL)**XEXSEDH * &
+ ZRHODREFH(JL)**(XEXSEDH-XCEXVT)
+ END DO
+ END IF
+ DO JK = KKTB , KKTE
+ PRHS(:,:,JK) = PRHS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
+ END DO
+ IF (PRESENT(PFPR)) THEN
+ DO JK = KKTB , KKTE
+ PFPR(:,:,JK,7)=ZWSED(:,:,JK)
+ ENDDO
+ ENDIF
+ PINPRH(:,:) = PINPRH(:,:) + ZWSED(:,:,KKB)/XRHOLW/KSPLITR
+ IF( JN==KSPLITR ) THEN
+ PRHS(:,:,:) = PRHS(:,:,:) * ZINVTSTEP
+ END IF
+ END IF
+!
+END DO
+!
+IF (OSEDIC) THEN
+ IF (ILENALLOCC .GT. 0) DEALLOCATE (ZRCS, ZRHODREFC, &
+ ILISTC,ZWLBDC,ZCONC,ZRCT, ZZT,ZPRES,ZRAY1D,ZFSEDC1D, ZWLBDA,ZCC)
+END IF
+IF (ILENALLOCR .GT. 0 ) DEALLOCATE(ZRHODREFR,ZRRS,ILISTR)
+IF (ILENALLOCI .GT. 0 ) DEALLOCATE(ZRHODREFI,ZRIS,ILISTI)
+IF (ILENALLOCS .GT. 0 ) DEALLOCATE(ZRHODREFS,ZRSS,ILISTS)
+IF (ILENALLOCG .GT. 0 ) DEALLOCATE(ZRHODREFG,ZRGS,ILISTG)
+IF (KRR == 7 .AND. (ILENALLOCH .GT. 0 )) DEALLOCATE(ZRHODREFH,ZRHS,ILISTH)
+!
+!* 2.3 budget storage
+!
+IF (LBUDGET_RC .AND. OSEDIC) &
+ CALL BUDGET (PRCS(:,:,:)*PRHODJ(:,:,:),7 ,'SEDI_BU_RRC')
+IF (LBUDGET_RR) CALL BUDGET (PRRS(:,:,:)*PRHODJ(:,:,:),8 ,'SEDI_BU_RRR')
+IF (LBUDGET_RI) CALL BUDGET (PRIS(:,:,:)*PRHODJ(:,:,:),9 ,'SEDI_BU_RRI')
+IF (LBUDGET_RS) CALL BUDGET (PRSS(:,:,:)*PRHODJ(:,:,:),10,'SEDI_BU_RRS')
+IF (LBUDGET_RG) CALL BUDGET (PRGS(:,:,:)*PRHODJ(:,:,:),11,'SEDI_BU_RRG')
+IF ( KRR == 7 .AND. LBUDGET_RH) &
+ CALL BUDGET (PRHS(:,:,:)*PRHODJ(:,:,:),12,'SEDI_BU_RRH')
+!
+!
+!
+!* 2.4 DROPLET DEPOSITION AT THE 1ST LEVEL ABOVE GROUND
+!
+IF (ODEPOSC) THEN
+ GDEP(:,:) = .FALSE.
+ GDEP(KIB:KIE,KJB:KJE) = PRCS(KIB:KIE,KJB:KJE,KKB) >0
+ WHERE (GDEP)
+ PRCS(:,:,KKB) = PRCS(:,:,KKB) - XVDEPOSC * PRCT(:,:,KKB) / PDZZ(:,:,KKB)
+ PINPRC(:,:) = PINPRC(:,:) + XVDEPOSC * PRCT(:,:,KKB) * PRHODREF(:,:,KKB) /XRHOLW
+ PINDEP(:,:) = XVDEPOSC * PRCT(:,:,KKB) * PRHODREF(:,:,KKB) /XRHOLW
+ END WHERE
+END IF
+!
+!* 2.5 budget storage
+!
+IF ( LBUDGET_RC .AND. ODEPOSC ) &
+ CALL BUDGET (PRCS(:,:,:)*PRHODJ(:,:,:),7 ,'DEPO_BU_RRC')
+!
+
+ END SUBROUTINE RAIN_ICE_SEDIMENTATION_SPLIT
+
+ FUNCTION COUNTJV(LTAB,I1,I2,I3) RESULT(IC)
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.2 declaration of local variables
+!
+!
+LOGICAL, DIMENSION(:,:,:) :: LTAB ! Mask
+INTEGER, DIMENSION(:) :: I1,I2,I3 ! Used to replace the COUNT and PACK
+INTEGER :: JI,JJ,JK,IC
+!
+!-------------------------------------------------------------------------------
+!
+IC = 0
+DO JK = 1,SIZE(LTAB,3)
+ DO JJ = 1,SIZE(LTAB,2)
+ DO JI = 1,SIZE(LTAB,1)
+ IF( LTAB(JI,JJ,JK) ) THEN
+ IC = IC +1
+ I1(IC) = JI
+ I2(IC) = JJ
+ I3(IC) = JK
+ END IF
+ END DO
+ END DO
+END DO
+!
+END FUNCTION COUNTJV
+
+END MODULE MODE_RAIN_ICE_SEDIMENTATION_SPLIT
diff --git a/src/MNH/rain_ice_sedimentation_stat.f90 b/src/MNH/rain_ice_sedimentation_stat.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e8d07221c69c3258d6849abc51262df27bbd12bb
--- /dev/null
+++ b/src/MNH/rain_ice_sedimentation_stat.f90
@@ -0,0 +1,606 @@
+!MNH_LIC Copyright 1995-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! Modifications:
+! P. Wautelet 25/02/2019: split rain_ice (cleaner and easier to maintain/debug)
+!-----------------------------------------------------------------
+MODULE MODE_RAIN_ICE_SEDIMENTATION_STAT
+
+ IMPLICIT NONE
+
+ PRIVATE
+
+ PUBLIC :: RAIN_ICE_SEDIMENTATION_STAT
+
+CONTAINS
+
+SUBROUTINE RAIN_ICE_SEDIMENTATION_STAT( KIB, KIE, KJB, KJE, KKB, KKE, KKTB, KKTE, KKT, KKL, KRR, &
+ PTSTEP, OSEDIC, PINPRC, PINDEP, &
+ PINPRR, PINPRS, PINPRG, PDZZ, PRHODREF, PPABST, PTHT, PRHODJ, PINPRR3D, &
+ PRCS, PRCT, PRRS, PRRT, PRIS, PRSS, PRST, PRGS, PRGT, &
+ PSEA, PTOWN, PINPRH, PRHS, PRHT, PFPR )
+!
+!* 0. DECLARATIONS
+! ------------
+!
+use MODD_BUDGET, only: LBUDGET_RC, LBUDGET_RG, LBUDGET_RH, LBUDGET_RI, LBUDGET_RR, LBUDGET_RS
+use MODD_CST, only: XRHOLW
+use MODD_PARAM_ICE, only: LDEPOSC, XVDEPOSC
+use MODD_RAIN_ICE_PARAM, only: XEXSEDG, XEXSEDH, XEXCSEDI, XEXSEDR, XEXSEDS, &
+ XFSEDC, XFSEDG, XFSEDH, XFSEDI, XFSEDR, XFSEDS
+use MODD_RAIN_ICE_DESCR, only: XALPHAC, XALPHAC2, XCC, XCEXVT, XCONC_LAND, XCONC_SEA, XCONC_URBAN, &
+ XDC, XLBC, XLBEXC, XNUC, XNUC2, XRTMIN
+!
+use MODI_BUDGET
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+INTEGER, INTENT(IN) :: KIB, KIE, KJB, KJE, KKB, KKE, KKTB, KKTE, KKT
+INTEGER, INTENT(IN) :: KKL ! vert. levels type 1=MNH -1=ARO
+INTEGER, INTENT(IN) :: KRR ! Number of moist variable
+REAL, INTENT(IN) :: PTSTEP ! Double Time step
+ ! (single if cold start)
+LOGICAL, INTENT(IN) :: OSEDIC ! Switch for droplet sedim.
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRC ! Cloud instant precip
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINDEP ! Cloud instant deposition
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRR ! Rain instant precip
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRS ! Snow instant precip
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRG ! Graupel instant precip
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDZZ ! Layer thikness (m)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! absolute pressure at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PINPRR3D! Rain inst precip 3D
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRSS ! Snow/aggregate m.r. source
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRGS ! Graupel m.r. source
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGT ! Graupel/hail m.r. at t
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PSEA ! Sea Mask
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(IN) :: PTOWN ! Fraction that is town
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: PINPRH ! Hail instant precip
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(INOUT) :: PRHS ! Hail m.r. source
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(IN) :: PRHT ! Hail m.r. at t
+REAL, DIMENSION(:,:,:,:), OPTIONAL, INTENT(OUT) :: PFPR ! upper-air precipitation fluxes
+!
+!* 0.2 declaration of local variables
+!
+INTEGER :: JI,JJ,JK
+INTEGER :: JCOUNT, JL
+INTEGER, DIMENSION(SIZE(PRHODREF,1)*SIZE(PRHODREF,2)) :: I1, I2
+LOGICAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2)) :: GDEP
+REAL :: ZINVTSTEP
+REAL :: ZP1,ZP2,ZH,ZZWLBDA,ZZWLBDC,ZZCC
+REAL, DIMENSION(SIZE(XRTMIN)) :: ZRTMIN
+! XRTMIN = Minimum value for the mixing ratio
+! ZRTMIN = Minimum value for the source (tendency)
+REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2)) :: ZQP
+REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2)) &
+ :: ZCONC_TMP ! Weighted concentration
+REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
+ :: ZPRCS,ZPRRS,ZPRSS,ZPRGS,ZPRHS ! Mixing ratios created during the time step
+REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: ZCONC3D ! droplet condensation
+REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: &
+ ZRAY, & ! Cloud Mean radius
+ ZLBC, & ! XLBC weighted by sea fraction
+ ZFSEDC
+REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
+ :: ZW ! work array
+REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),0:SIZE(PRHODREF,3)+1) &
+ :: ZWSED ! sedimentation fluxes
+REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),0:SIZE(PRHODREF,3)+1) &
+ :: ZWSEDW1 ! sedimentation speed
+REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),0:SIZE(PRHODREF,3)+1) &
+ :: ZWSEDW2 ! sedimentation speed
+!-------------------------------------------------------------------------------
+!
+!
+ZINVTSTEP=1./PTSTEP
+!
+!* 1. Parameters for cloud sedimentation
+!
+ IF (OSEDIC) THEN
+ ZRAY(:,:,:) = 0.
+ ZLBC(:,:,:) = XLBC(1)
+ ZFSEDC(:,:,:) = XFSEDC(1)
+ ZCONC3D(:,:,:)= XCONC_LAND
+ ZCONC_TMP(:,:)= XCONC_LAND
+ IF (PRESENT(PSEA)) THEN
+ ZCONC_TMP(:,:)=PSEA(:,:)*XCONC_SEA+(1.-PSEA(:,:))*XCONC_LAND
+
+ DO JK=KKTB,KKTE
+ ZLBC(:,:,JK) = PSEA(:,:)*XLBC(2)+(1.-PSEA(:,:))*XLBC(1)
+ ZFSEDC(:,:,JK) = (PSEA(:,:)*XFSEDC(2)+(1.-PSEA(:,:))*XFSEDC(1))
+ ZFSEDC(:,:,JK) = MAX(MIN(XFSEDC(1),XFSEDC(2)),ZFSEDC(:,:,JK))
+ ZCONC3D(:,:,JK)= (1.-PTOWN(:,:))*ZCONC_TMP(:,:)+PTOWN(:,:)*XCONC_URBAN
+ ZRAY(:,:,JK) = 0.5*((1.-PSEA(:,:))*GAMMA(XNUC+1.0/XALPHAC)/(GAMMA(XNUC)) + &
+ PSEA(:,:)*GAMMA(XNUC2+1.0/XALPHAC2)/(GAMMA(XNUC2)))
+ END DO
+ ELSE
+ ZCONC3D(:,:,:) = XCONC_LAND
+ ZRAY(:,:,:) = 0.5*(GAMMA(XNUC+1.0/XALPHAC)/(GAMMA(XNUC)))
+ END IF
+ ZRAY(:,:,:) = MAX(1.,ZRAY(:,:,:))
+ ZLBC(:,:,:) = MAX(MIN(XLBC(1),XLBC(2)),ZLBC(:,:,:))
+ ENDIF
+ IF (LDEPOSC) PINDEP (:,:) = 0.
+!
+!* 2. compute the fluxes
+!
+
+
+ZRTMIN(:) = XRTMIN(:) * ZINVTSTEP
+!
+IF (OSEDIC) THEN
+ ZPRCS(:,:,:) = 0.0
+ ZPRCS(:,:,:) = PRCS(:,:,:)-PRCT(:,:,:)* ZINVTSTEP
+ PRCS(:,:,:) = PRCT(:,:,:)* ZINVTSTEP
+END IF
+ZPRRS(:,:,:) = 0.0
+ZPRSS(:,:,:) = 0.0
+ZPRGS(:,:,:) = 0.0
+IF ( KRR == 7 ) ZPRHS(:,:,:) = 0.0
+!
+ZPRRS(:,:,:) = PRRS(:,:,:)-PRRT(:,:,:)* ZINVTSTEP
+ZPRSS(:,:,:) = PRSS(:,:,:)-PRST(:,:,:)* ZINVTSTEP
+ZPRGS(:,:,:) = PRGS(:,:,:)-PRGT(:,:,:)* ZINVTSTEP
+IF ( KRR == 7 ) ZPRHS(:,:,:) = PRHS(:,:,:)-PRHT(:,:,:)* ZINVTSTEP
+PRRS(:,:,:) = PRRT(:,:,:)* ZINVTSTEP
+PRSS(:,:,:) = PRST(:,:,:)* ZINVTSTEP
+PRGS(:,:,:) = PRGT(:,:,:)* ZINVTSTEP
+IF ( KRR == 7 ) PRHS(:,:,:) = PRHT(:,:,:)* ZINVTSTEP
+!
+IF (OSEDIC) PRCS(:,:,:) = PRCS(:,:,:) + ZPRCS(:,:,:)
+PRRS(:,:,:) = PRRS(:,:,:) + ZPRRS(:,:,:)
+PRSS(:,:,:) = PRSS(:,:,:) + ZPRSS(:,:,:)
+PRGS(:,:,:) = PRGS(:,:,:) + ZPRGS(:,:,:)
+IF ( KRR == 7 ) PRHS(:,:,:) = PRHS(:,:,:) + ZPRHS(:,:,:)
+IF (PRESENT(PFPR)) PFPR(:,:,:,:) = 0.
+DO JK = KKTB , KKTE
+ ZW(:,:,JK) =PTSTEP/(PRHODREF(:,:,JK)* PDZZ(:,:,JK) )
+END DO
+PINPRR3D (:,:,:) = 0.
+
+!
+!* 2.1 for cloud
+!
+ IF (OSEDIC) THEN
+ PRCS(:,:,:) = PRCS(:,:,:) * PTSTEP
+ ZWSED(:,:,:) = 0.
+ ZWSEDW1(:,:,:) = 0.
+ ZWSEDW2(:,:,:) = 0.
+
+! calculation of P1, P2 and sedimentation flux
+ DO JK = KKE , KKB, -1*KKL
+ !estimation of q' taking into account incomming ZWSED
+ ZQP(:,:)=ZWSED(:,:,JK+KKL)*ZW(:,:,JK)
+
+ JCOUNT=COUNTJV2((PRCS(:,:,JK) > ZRTMIN(2) .AND. PRCT(:,:,JK) > ZRTMIN(2)) .OR. &
+ (ZQP(:,:) > ZRTMIN(2)),I1(:),I2(:))
+ DO JL=1, JCOUNT
+ JI=I1(JL)
+ JJ=I2(JL)
+ !calculation of w
+ ! mars 2009 : ajout d'un test
+ !IF ( PRCS(JI,JJ,JK) > ZRTMIN(2) ) THEN
+ IF(PRCS(JI,JJ,JK) > ZRTMIN(2) .AND. PRCT(JI,JJ,JK) > ZRTMIN(2)) THEN
+ ZZWLBDA=6.6E-8*(101325./PPABST(JI,JJ,JK))*(PTHT(JI,JJ,JK)/293.15)
+ ZZWLBDC=(ZLBC(JI,JJ,JK)*ZCONC3D(JI,JJ,JK) &
+ &/(PRHODREF(JI,JJ,JK)*PRCT(JI,JJ,JK)))**XLBEXC
+ ZZCC=XCC*(1.+1.26*ZZWLBDA*ZZWLBDC/ZRAY(JI,JJ,JK)) !! ZCC : Fall speed
+ ZWSEDW1 (JI,JJ,JK)=PRHODREF(JI,JJ,JK)**(-XCEXVT ) * &
+ & ZZWLBDC**(-XDC)*ZZCC*ZFSEDC(JI,JJ,JK)
+ ENDIF
+ IF ( ZQP(JI,JJ) > ZRTMIN(2) ) THEN
+ ZZWLBDA=6.6E-8*(101325./PPABST(JI,JJ,JK))*(PTHT(JI,JJ,JK)/293.15)
+ ZZWLBDC=(ZLBC(JI,JJ,JK)*ZCONC3D(JI,JJ,JK) &
+ &/(PRHODREF(JI,JJ,JK)*ZQP(JI,JJ)))**XLBEXC
+ ZZCC=XCC*(1.+1.26*ZZWLBDA*ZZWLBDC/ZRAY(JI,JJ,JK)) !! ZCC : Fall speed
+ ZWSEDW2 (JI,JJ,JK)=PRHODREF(JI,JJ,JK)**(-XCEXVT ) * &
+ & ZZWLBDC**(-XDC)*ZZCC*ZFSEDC(JI,JJ,JK)
+ ENDIF
+ ENDDO
+
+ DO JJ = KJB, KJE
+ DO JI = KIB, KIE
+ ZH=PDZZ(JI,JJ,JK)
+ ZP1 = MIN(1., ZWSEDW1(JI,JJ,JK) * PTSTEP / ZH)
+ ! mars 2009 : correction : ZWSEDW1 => ZWSEDW2
+ !IF (ZWSEDW1(JI,JJ,JK) /= 0.) THEN
+ IF (ZWSEDW2(JI,JJ,JK) /= 0.) THEN
+ ZP2 = MAX(0.,1 - ZH &
+ & / (PTSTEP*ZWSEDW2(JI,JJ,JK)) )
+ ELSE
+ ZP2 = 0.
+ ENDIF
+ ZWSED (JI,JJ,JK)=ZP1*PRHODREF(JI,JJ,JK)*&
+ &ZH*PRCS(JI,JJ,JK)&
+ &* ZINVTSTEP+ ZP2 * ZWSED (JI,JJ,JK+KKL)
+ ENDDO
+ ENDDO
+ ENDDO
+
+ DO JK = KKTB , KKTE
+ PRCS(:,:,JK) = PRCS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
+ END DO
+ IF (PRESENT(PFPR)) THEN
+ DO JK = KKTB , KKTE
+ PFPR(:,:,JK,2)=ZWSED(:,:,JK)
+ ENDDO
+ ENDIF
+
+ PINPRC(:,:) = ZWSED(:,:,KKB)/XRHOLW ! in m/s
+ PRCS(:,:,:) = PRCS(:,:,:) * ZINVTSTEP
+ ENDIF
+
+!
+!* 2.2 for rain
+!
+
+ PRRS(:,:,:) = PRRS(:,:,:) * PTSTEP
+ ZWSED(:,:,:) = 0.
+ ZWSEDW1(:,:,:) = 0.
+ ZWSEDW2(:,:,:) = 0.
+
+! calculation of ZP1, ZP2 and sedimentation flux
+ DO JK = KKE , KKB, -1*KKL
+ !estimation of q' taking into account incomming ZWSED
+ ZQP(:,:)=ZWSED(:,:,JK+KKL)*ZW(:,:,JK)
+
+ JCOUNT=COUNTJV2((PRRS(:,:,JK) > ZRTMIN(3)) .OR. &
+ (ZQP(:,:) > ZRTMIN(3)),I1(:),I2(:))
+ DO JL=1, JCOUNT
+ JI=I1(JL)
+ JJ=I2(JL)
+ !calculation of w
+ IF ( PRRS(JI,JJ,JK) > ZRTMIN(3) ) THEN
+ ZWSEDW1 (JI,JJ,JK)= XFSEDR *PRRS(JI,JJ,JK)**(XEXSEDR-1)* &
+ PRHODREF(JI,JJ,JK)**(XEXSEDR-XCEXVT-1)
+ ENDIF
+ IF ( ZQP(JI,JJ) > ZRTMIN(3) ) THEN
+ ZWSEDW2 (JI,JJ,JK)= XFSEDR *(ZQP(JI,JJ))**(XEXSEDR-1)* &
+ PRHODREF(JI,JJ,JK)**(XEXSEDR-XCEXVT-1)
+ ENDIF
+ ENDDO
+ DO JJ = KJB, KJE
+ DO JI = KIB, KIE
+ ZH=PDZZ(JI,JJ,JK)
+ ZP1 = MIN(1., ZWSEDW1(JI,JJ,JK) * PTSTEP / ZH )
+ IF (ZWSEDW2(JI,JJ,JK) /= 0.) THEN
+ ZP2 = MAX(0.,1 - ZH &
+ & / (PTSTEP*ZWSEDW2(JI,JJ,JK)) )
+ ELSE
+ ZP2 = 0.
+ ENDIF
+ ZWSED (JI,JJ,JK)=ZP1*PRHODREF(JI,JJ,JK)*&
+ &ZH*PRRS(JI,JJ,JK)&
+ &* ZINVTSTEP+ ZP2 * ZWSED (JI,JJ,JK+KKL)
+ ENDDO
+ ENDDO
+ ENDDO
+
+ DO JK = KKTB , KKTE
+ PRRS(:,:,JK) = PRRS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
+ ENDDO
+ IF (PRESENT(PFPR)) THEN
+ DO JK = KKTB , KKTE
+ PFPR(:,:,JK,3)=ZWSED(:,:,JK)
+ ENDDO
+ ENDIF
+ PINPRR(:,:) = ZWSED(:,:,KKB)/XRHOLW ! in m/s
+ PINPRR3D(:,:,:) = ZWSED(:,:,1:KKT)/XRHOLW ! in m/s
+ PRRS(:,:,:) = PRRS(:,:,:) * ZINVTSTEP
+
+!
+!* 2.3 for pristine ice
+!
+
+ PRIS(:,:,:) = PRIS(:,:,:) * PTSTEP
+ ZWSED(:,:,:) = 0.
+ ZWSEDW1(:,:,:) = 0.
+ ZWSEDW2(:,:,:) = 0.
+! calculation of ZP1, ZP2 and sedimentation flux
+ DO JK = KKE , KKB, -1*KKL
+ !estimation of q' taking into account incomming ZWSED
+ ZQP(:,:)=ZWSED(:,:,JK+KKL)*ZW(:,:,JK)
+
+ JCOUNT=COUNTJV2((PRIS(:,:,JK) > MAX(ZRTMIN(4),1.0E-7 )) .OR. &
+ (ZQP(:,:) > MAX(ZRTMIN(4),1.0E-7 )),I1(:),I2(:))
+ DO JL=1, JCOUNT
+ JI=I1(JL)
+ JJ=I2(JL)
+ !calculation of w
+ IF ( PRIS(JI,JJ,JK) > MAX(ZRTMIN(4),1.0E-7 ) ) THEN
+ ZWSEDW1 (JI,JJ,JK)= XFSEDI * &
+ & PRHODREF(JI,JJ,JK)**(XCEXVT) * & ! McF&H
+ & MAX( 0.05E6,-0.15319E6-0.021454E6* &
+ & ALOG(PRHODREF(JI,JJ,JK)*PRIS(JI,JJ,JK)) )**XEXCSEDI
+ ENDIF
+ IF ( ZQP(JI,JJ) > MAX(ZRTMIN(4),1.0E-7 ) ) THEN
+ ZWSEDW2 (JI,JJ,JK)= XFSEDI * &
+ & PRHODREF(JI,JJ,JK)**(XCEXVT) * & ! McF&H
+ & MAX( 0.05E6,-0.15319E6-0.021454E6* &
+ & ALOG(PRHODREF(JI,JJ,JK)*ZQP(JI,JJ)) )**XEXCSEDI
+ ENDIF
+ ENDDO
+ DO JJ = KJB, KJE
+ DO JI = KIB, KIE
+ ZH=PDZZ(JI,JJ,JK)
+ ZP1 = MIN(1., ZWSEDW1(JI,JJ,JK) * PTSTEP / ZH )
+ IF (ZWSEDW2(JI,JJ,JK) /= 0.) THEN
+ ZP2 = MAX(0.,1 - ZH &
+ & / (PTSTEP*ZWSEDW2(JI,JJ,JK)) )
+ ELSE
+ ZP2 = 0.
+ ENDIF
+ ZWSED (JI,JJ,JK)=ZP1*PRHODREF(JI,JJ,JK)*&
+ &ZH*PRIS(JI,JJ,JK)&
+ &* ZINVTSTEP+ ZP2 * ZWSED (JI,JJ,JK+KKL)
+ ENDDO
+ ENDDO
+ ENDDO
+
+ DO JK = KKTB , KKTE
+ PRIS(:,:,JK) = PRIS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
+ ENDDO
+ IF (PRESENT(PFPR)) THEN
+ DO JK = KKTB , KKTE
+ PFPR(:,:,JK,4)=ZWSED(:,:,JK)
+ ENDDO
+ ENDIF
+
+ PRIS(:,:,:) = PRIS(:,:,:) * ZINVTSTEP
+
+
+!
+!* 2.4 for aggregates/snow
+!
+
+ PRSS(:,:,:) = PRSS(:,:,:) * PTSTEP
+ ZWSED(:,:,:) = 0.
+ ZWSEDW1(:,:,:) = 0.
+ ZWSEDW2(:,:,:) = 0.
+
+! calculation of ZP1, ZP2 and sedimentation flux
+ DO JK = KKE , KKB, -1*KKL
+ !estimation of q' taking into account incomming ZWSED
+ ZQP(:,:)=ZWSED(:,:,JK+KKL)*ZW(:,:,JK)
+
+ JCOUNT=COUNTJV2((PRSS(:,:,JK) > ZRTMIN(5)) .OR. &
+ (ZQP(:,:) > ZRTMIN(5)),I1(:),I2(:))
+ DO JL=1, JCOUNT
+ JI=I1(JL)
+ JJ=I2(JL)
+ !calculation of w
+ IF (PRSS(JI,JJ,JK) > ZRTMIN(5) ) THEN
+ ZWSEDW1(JI,JJ,JK)=XFSEDS*(PRSS(JI,JJ,JK))**(XEXSEDS-1)*&
+ PRHODREF(JI,JJ,JK)**(XEXSEDS-XCEXVT-1)
+ ENDIF
+ IF ( ZQP(JI,JJ) > ZRTMIN(5) ) THEN
+ ZWSEDW2(JI,JJ,JK)=XFSEDS*(ZQP(JI,JJ))**(XEXSEDS-1)*&
+ PRHODREF(JI,JJ,JK)**(XEXSEDS-XCEXVT-1)
+ ENDIF
+ ENDDO
+ DO JJ = KJB, KJE
+ DO JI = KIB, KIE
+ ZH=PDZZ(JI,JJ,JK)
+ ZP1 = MIN(1., ZWSEDW1(JI,JJ,JK) * PTSTEP / ZH )
+ IF (ZWSEDW2(JI,JJ,JK) /= 0.) THEN
+ ZP2 = MAX(0.,1 - ZH&
+ / (PTSTEP*ZWSEDW2(JI,JJ,JK)) )
+ ELSE
+ ZP2 = 0.
+ ENDIF
+ ZWSED (JI,JJ,JK)=ZP1*PRHODREF(JI,JJ,JK)*&
+ &ZH*PRSS(JI,JJ,JK)&
+ &* ZINVTSTEP+ ZP2 * ZWSED (JI,JJ,JK+KKL)
+ ENDDO
+ ENDDO
+ ENDDO
+
+ DO JK = KKTB , KKTE
+ PRSS(:,:,JK) = PRSS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
+ ENDDO
+ IF (PRESENT(PFPR)) THEN
+ DO JK = KKTB , KKTE
+ PFPR(:,:,JK,5)=ZWSED(:,:,JK)
+ ENDDO
+ ENDIF
+
+ PINPRS(:,:) = ZWSED(:,:,KKB)/XRHOLW ! in m/s
+
+ PRSS(:,:,:) = PRSS(:,:,:) * ZINVTSTEP
+
+
+!
+!* 2.5 for graupeln
+!
+
+ PRGS(:,:,:) = PRGS(:,:,:) * PTSTEP
+ ZWSED(:,:,:) = 0.
+ ZWSEDW1(:,:,:) = 0.
+ ZWSEDW2(:,:,:) = 0.
+
+! calculation of ZP1, ZP2 and sedimentation flux
+ DO JK = KKE, KKB, -1*KKL
+ !estimation of q' taking into account incomming ZWSED
+ ZQP(:,:)=ZWSED(:,:,JK+KKL)*ZW(:,:,JK)
+
+ JCOUNT=COUNTJV2((PRGS(:,:,JK) > ZRTMIN(6)) .OR. &
+ (ZQP(:,:) > ZRTMIN(6)),I1(:),I2(:))
+ DO JL=1, JCOUNT
+ JI=I1(JL)
+ JJ=I2(JL)
+ !calculation of w
+ IF ( PRGS(JI,JJ,JK) > ZRTMIN(6) ) THEN
+ ZWSEDW1 (JI,JJ,JK)= XFSEDG*(PRGS(JI,JJ,JK))**(XEXSEDG-1) * &
+ PRHODREF(JI,JJ,JK)**(XEXSEDG-XCEXVT-1)
+ ENDIF
+ IF ( ZQP(JI,JJ) > ZRTMIN(6) ) THEN
+ ZWSEDW2 (JI,JJ,JK)= XFSEDG*(ZQP(JI,JJ))**(XEXSEDG-1) * &
+ PRHODREF(JI,JJ,JK)**(XEXSEDG-XCEXVT-1)
+ ENDIF
+ ENDDO
+ DO JJ = KJB, KJE
+ DO JI = KIB, KIE
+ ZH=PDZZ(JI,JJ,JK)
+ ZP1 = MIN(1., ZWSEDW1(JI,JJ,JK) * PTSTEP / ZH )
+ IF (ZWSEDW2(JI,JJ,JK) /= 0.) THEN
+ ZP2 = MAX(0.,1 - ZH &
+ & / (PTSTEP*ZWSEDW2(JI,JJ,JK)) )
+ ELSE
+ ZP2 = 0.
+ ENDIF
+ ZWSED (JI,JJ,JK)=ZP1*PRHODREF(JI,JJ,JK)*&
+ &ZH*PRGS(JI,JJ,JK)&
+ &* ZINVTSTEP+ ZP2 * ZWSED (JI,JJ,JK+KKL)
+ ENDDO
+ ENDDO
+ ENDDO
+
+ DO JK = KKTB , KKTE
+ PRGS(:,:,JK) = PRGS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
+ ENDDO
+ IF (PRESENT(PFPR)) THEN
+ DO JK = KKTB , KKTE
+ PFPR(:,:,JK,6)=ZWSED(:,:,JK)
+ ENDDO
+ ENDIF
+
+ PINPRG(:,:) = ZWSED(:,:,KKB)/XRHOLW ! in m/s
+
+ PRGS(:,:,:) = PRGS(:,:,:) * ZINVTSTEP
+
+!
+!* 2.6 for hail
+!
+ IF ( KRR == 7 ) THEN
+ PRHS(:,:,:) = PRHS(:,:,:) * PTSTEP
+ ZWSED(:,:,:) = 0.
+ ZWSEDW1(:,:,:) = 0.
+ ZWSEDW2(:,:,:) = 0.
+! calculation of ZP1, ZP2 and sedimentation flux
+ DO JK = KKE , KKB, -1*KKL
+ !estimation of q' taking into account incomming ZWSED
+ ZQP(:,:)=ZWSED(:,:,JK+KKL)*ZW(:,:,JK)
+
+ JCOUNT=COUNTJV2((PRHS(:,:,JK)+ZQP(JI,JJ) > ZRTMIN(7)) .OR. &
+ (ZQP(:,:) > ZRTMIN(7)),I1(:),I2(:))
+ DO JL=1, JCOUNT
+ JI=I1(JL)
+ JJ=I2(JL)
+ !calculation of w
+ IF ((PRHS(JI,JJ,JK)+ZQP(JI,JJ)) > ZRTMIN(7) ) THEN
+ ZWSEDW1 (JI,JJ,JK)= XFSEDH * (PRHS(JI,JJ,JK))**(XEXSEDH-1) * &
+ PRHODREF(JI,JJ,JK)**(XEXSEDH-XCEXVT-1)
+ ENDIF
+ IF ( ZQP(JI,JJ) > ZRTMIN(7) ) THEN
+ ZWSEDW2 (JI,JJ,JK)= XFSEDH * ZQP(JI,JJ)**(XEXSEDH-1) * &
+ PRHODREF(JI,JJ,JK)**(XEXSEDH-XCEXVT-1)
+ ENDIF
+ ENDDO
+ DO JJ = KJB, KJE
+ DO JI = KIB, KIE
+ ZH=PDZZ(JI,JJ,JK)
+ ZP1 = MIN(1., ZWSEDW1(JI,JJ,JK) * PTSTEP / ZH)
+ IF (ZWSEDW2(JI,JJ,JK) /= 0.) THEN
+ ZP2 = MAX(0.,1 - ZH &
+ & / (PTSTEP*ZWSEDW2(JI,JJ,JK)) )
+ ELSE
+ ZP2 = 0.
+ ENDIF
+ ZWSED (JI,JJ,JK)=ZP1*PRHODREF(JI,JJ,JK)*&
+ &ZH*PRHS(JI,JJ,JK)&
+ &* ZINVTSTEP+ ZP2 * ZWSED (JI,JJ,JK+KKL)
+ ENDDO
+ ENDDO
+ ENDDO
+
+ DO JK = KKTB , KKTE
+ PRHS(:,:,JK) = PRHS(:,:,JK) + ZW(:,:,JK)*(ZWSED(:,:,JK+KKL)-ZWSED(:,:,JK))
+ ENDDO
+ IF (PRESENT(PFPR)) THEN
+ DO JK = KKTB , KKTE
+ PFPR(:,:,JK,7)=ZWSED(:,:,JK)
+ ENDDO
+ ENDIF
+
+ PINPRH(:,:) = ZWSED(:,:,KKB)/XRHOLW ! in m/s
+
+ PRHS(:,:,:) = PRHS(:,:,:) * ZINVTSTEP
+
+ ENDIF
+!
+
+!
+!* 2.3 budget storage
+!
+IF (LBUDGET_RC .AND. OSEDIC) &
+ CALL BUDGET (PRCS(:,:,:)*PRHODJ(:,:,:),7 ,'SEDI_BU_RRC')
+IF (LBUDGET_RR) CALL BUDGET (PRRS(:,:,:)*PRHODJ(:,:,:),8 ,'SEDI_BU_RRR')
+IF (LBUDGET_RI) CALL BUDGET (PRIS(:,:,:)*PRHODJ(:,:,:),9 ,'SEDI_BU_RRI')
+IF (LBUDGET_RS) CALL BUDGET (PRSS(:,:,:)*PRHODJ(:,:,:),10,'SEDI_BU_RRS')
+IF (LBUDGET_RG) CALL BUDGET (PRGS(:,:,:)*PRHODJ(:,:,:),11,'SEDI_BU_RRG')
+IF ( KRR == 7 .AND. LBUDGET_RH) &
+ CALL BUDGET (PRHS(:,:,:)*PRHODJ(:,:,:),12,'SEDI_BU_RRH')
+!
+!
+!* 2.4 DROPLET DEPOSITION AT THE 1ST LEVEL ABOVE GROUND
+!
+IF (LDEPOSC) THEN
+ GDEP(:,:) = .FALSE.
+ GDEP(KIB:KIE,KJB:KJE) = PRCS(KIB:KIE,KJB:KJE,KKB) >0
+ WHERE (GDEP)
+ PRCS(:,:,KKB) = PRCS(:,:,KKB) - XVDEPOSC * PRCT(:,:,KKB) / PDZZ(:,:,KKB)
+ PINPRC(:,:) = PINPRC(:,:) + XVDEPOSC * PRCT(:,:,KKB) * PRHODREF(:,:,KKB) /XRHOLW
+ PINDEP(:,:) = XVDEPOSC * PRCT(:,:,KKB) * PRHODREF(:,:,KKB) /XRHOLW
+ END WHERE
+END IF
+!
+!* 2.5 budget storage
+!
+IF ( LBUDGET_RC .AND. LDEPOSC ) &
+ CALL BUDGET (PRCS(:,:,:)*PRHODJ(:,:,:),7 ,'DEPO_BU_RRC')
+!
+END SUBROUTINE RAIN_ICE_SEDIMENTATION_STAT
+
+
+FUNCTION COUNTJV2(LTAB,I1,I2) RESULT(IC)
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.2 declaration of local variables
+!
+!
+LOGICAL, DIMENSION(:,:) :: LTAB ! Mask
+INTEGER, DIMENSION(:) :: I1,I2 ! Used to replace the COUNT and PACK
+INTEGER :: JI,JJ,IC
+!
+!-------------------------------------------------------------------------------
+!
+IC = 0
+DO JJ = 1,SIZE(LTAB,2)
+ DO JI = 1,SIZE(LTAB,1)
+ IF( LTAB(JI,JJ) ) THEN
+ IC = IC +1
+ I1(IC) = JI
+ I2(IC) = JJ
+ END IF
+ END DO
+END DO
+!
+END FUNCTION COUNTJV2
+
+END MODULE MODE_RAIN_ICE_SEDIMENTATION_STAT
diff --git a/src/MNH/rain_ice_slow.f90 b/src/MNH/rain_ice_slow.f90
new file mode 100644
index 0000000000000000000000000000000000000000..eb46ad5318796fa2e160df3f11f9714c914484c5
--- /dev/null
+++ b/src/MNH/rain_ice_slow.f90
@@ -0,0 +1,237 @@
+!MNH_LIC Copyright 1995-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! Modifications:
+! P. Wautelet 25/02/2019: split rain_ice (cleaner and easier to maintain/debug)
+!-----------------------------------------------------------------
+MODULE MODE_RAIN_ICE_SLOW
+
+ IMPLICIT NONE
+
+ PRIVATE
+
+ PUBLIC :: RAIN_ICE_SLOW
+
+CONTAINS
+
+SUBROUTINE RAIN_ICE_SLOW(OMICRO, PINVTSTEP, PRHODREF, &
+ PRCT, PRRT, PRIT, PRST, PRGT, PRHODJ, PZT, PPRES, &
+ PLSFACT, PLVFACT, &
+ PSSI, PRHODJ3D, PTHS3D, PRVS3D, &
+ PRVS, PRCS, PRRS, PRIS, PRSS, PRGS, PTHS, &
+ PAI, PCJ, PKA, PDV, PLBDAS, PLBDAG)
+!
+!* 0. DECLARATIONS
+! ------------
+!
+use MODD_BUDGET, only: LBUDGET_RC, LBUDGET_RG, LBUDGET_RI, LBUDGET_RR, LBUDGET_RS, LBUDGET_RV, LBUDGET_TH
+use MODD_CST, only: XALPI, XBETAI, XCI, XCPV, XGAMI, XLSTT, XMNH_HUGE_12_LOG, XP00, XRV, XTT
+use MODD_RAIN_ICE_DESCR, only: XCEXVT, XLBDAS_MAX, XLBEXG, XLBEXS, XLBG, XLBS, XRTMIN
+use MODD_RAIN_ICE_PARAM, only: X0DEPG, X0DEPS, X1DEPG, X1DEPS, XACRIAUTI, XALPHA3, XBCRIAUTI, XBETA3, XCOLEXIS, XCRIAUTI, &
+ XEX0DEPG, XEX0DEPS, XEX1DEPG, XEX1DEPS, XEXIAGGS, XFIAGGS, XHON, XSCFAC, XTEXAUTI, XTIMAUTI
+!
+use MODI_BUDGET
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+LOGICAL, DIMENSION(:,:,:), intent(in) :: OMICRO ! Test where to compute all processes
+REAL, intent(in) :: PINVTSTEP
+REAL, DIMENSION(:), intent(in) :: PRHODREF ! RHO Dry REFerence
+REAL, DIMENSION(:), intent(in) :: PRCT ! Cloud water m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRRT ! Rain water m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRIT ! Pristine ice m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRST ! Snow/aggregate m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRGT ! Graupel m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRHODJ ! RHO times Jacobian
+REAL, DIMENSION(:), intent(in) :: PZT ! Temperature
+REAL, DIMENSION(:), intent(in) :: PPRES ! Pressure
+REAL, DIMENSION(:), intent(in) :: PLSFACT ! L_s/(Pi_ref*C_ph)
+REAL, DIMENSION(:), intent(in) :: PLVFACT ! L_v/(Pi_ref*C_ph)
+REAL, DIMENSION(:), intent(in) :: PSSI ! Supersaturation over ice
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ3D ! Dry density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHS3D ! Theta source
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVS3D ! Water vapor m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRSS ! Snow/aggregate m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRGS ! Graupel m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PTHS ! Theta source
+REAL, DIMENSION(:), intent(OUT) :: PAI ! Thermodynamical function
+REAL, DIMENSION(:), intent(OUT) :: PCJ ! Function to compute the ventilation coefficient
+REAL, DIMENSION(:), intent(OUT) :: PKA ! Thermal conductivity of the air
+REAL, DIMENSION(:), intent(OUT) :: PDV ! Diffusivity of water vapor in the air
+REAL, DIMENSION(:), intent(OUT) :: PLBDAS ! Slope parameter of the aggregate distribution
+REAL, DIMENSION(:), intent(OUT) :: PLBDAG ! Slope parameter of the graupel distribution
+!
+!* 0.2 declaration of local variables
+!
+REAL, DIMENSION(size(PRHODREF)) :: ZZW ! Work array
+REAL, DIMENSION(size(PRHODREF)) :: ZCRIAUTI ! Snow-to-ice autoconversion thres.
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 3.2 compute the homogeneous nucleation source: RCHONI
+!
+ ZZW(:) = 0.0
+ WHERE( (PZT(:)<XTT-35.0) .AND. (PRCT(:)>XRTMIN(2)) .AND. (PRCS(:)>0.) )
+ ZZW(:) = MIN( PRCS(:),XHON*PRHODREF(:)*PRCT(:) &
+ *EXP( MIN(XMNH_HUGE_12_LOG,XALPHA3*(PZT(:)-XTT)-XBETA3) ) )
+ ! *EXP( XALPHA3*(PZT(:)-XTT)-XBETA3 ) )
+ PRIS(:) = PRIS(:) + ZZW(:)
+ PRCS(:) = PRCS(:) - ZZW(:)
+ PTHS(:) = PTHS(:) + ZZW(:)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*(RCHONI))
+ ENDWHERE
+!
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:), &
+ 4,'HON_BU_RTH')
+ IF (LBUDGET_RC) CALL BUDGET ( &
+ UNPACK(PRCS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 7,'HON_BU_RRC')
+ IF (LBUDGET_RI) CALL BUDGET ( &
+ UNPACK(PRIS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 9,'HON_BU_RRI')
+!
+!* 3.3 compute the spontaneous freezing source: RRHONG
+!
+ ZZW(:) = 0.0
+ WHERE( (PZT(:)<XTT-35.0) .AND. (PRRT(:)>XRTMIN(3)) .AND. (PRRS(:)>0.) )
+ ZZW(:) = MIN( PRRS(:),PRRT(:)* PINVTSTEP )
+ PRGS(:) = PRGS(:) + ZZW(:)
+ PRRS(:) = PRRS(:) - ZZW(:)
+ PTHS(:) = PTHS(:) + ZZW(:)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*(RRHONG))
+ ENDWHERE
+!
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:), &
+ 4,'SFR_BU_RTH')
+ IF (LBUDGET_RR) CALL BUDGET ( &
+ UNPACK(PRRS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 8,'SFR_BU_RRR')
+ IF (LBUDGET_RG) CALL BUDGET ( &
+ UNPACK(PRGS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 11,'SFR_BU_RRG')
+!
+!* 3.4 compute the deposition, aggregation and autoconversion sources
+!
+ PKA(:) = 2.38E-2 + 0.0071E-2 * ( PZT(:) - XTT ) ! k_a
+ PDV(:) = 0.211E-4 * (PZT(:)/XTT)**1.94 * (XP00/PPRES(:)) ! D_v
+!
+!* 3.4.1 compute the thermodynamical function A_i(T,P)
+!* and the c^prime_j (in the ventilation factor)
+!
+
+ PAI(:) = EXP( XALPI - XBETAI/PZT(:) - XGAMI*ALOG(PZT(:) ) ) ! es_i
+ PAI(:) = ( XLSTT + (XCPV-XCI)*(PZT(:)-XTT) )**2 / (PKA(:)*XRV*PZT(:)**2) &
+ + ( XRV*PZT(:) ) / (PDV(:)*PAI(:))
+ PCJ(:) = XSCFAC * PRHODREF(:)**0.3 / SQRT( 1.718E-5+0.0049E-5*(PZT(:)-XTT) )
+!
+!* 3.4.2 compute the riming-conversion of r_c for r_i production: RCAUTI
+!
+! ZZW(:) = 0.0
+! ZTIMAUTIC = SQRT( XTIMAUTI*XTIMAUTC )
+! WHERE ( (PRCT(:)>0.0) .AND. (PRIT(:)>0.0) .AND. (PRCS(:)>0.0) )
+! ZZW(:) = MIN( PRCS(:),ZTIMAUTIC * MAX( SQRT( PRIT(:)*PRCT(:) ),0.0 ) )
+! PRIS(:) = PRIS(:) + ZZW(:)
+! PRCS(:) = PRCS(:) - ZZW(:)
+! PTHS(:) = PTHS(:) + ZZW(:)*(PLSFACT(:)-PLVFACT(:)) ! f(L_f*(RCAUTI))
+! END WHERE
+!
+!* 3.4.3 compute the deposition on r_s: RVDEPS
+!
+ WHERE ( PRST(:)>0.0 )
+ PLBDAS(:) = MIN( XLBDAS_MAX, &
+ XLBS*( PRHODREF(:)*MAX( PRST(:),XRTMIN(5) ) )**XLBEXS )
+ END WHERE
+ ZZW(:) = 0.0
+ WHERE ( (PRST(:)>XRTMIN(5)) .AND. (PRSS(:)>0.0) )
+ ZZW(:) = ( PSSI(:)/(PRHODREF(:)*PAI(:)) ) * &
+ ( X0DEPS*PLBDAS(:)**XEX0DEPS + X1DEPS*PCJ(:)*PLBDAS(:)**XEX1DEPS )
+ ZZW(:) = MIN( PRVS(:),ZZW(:) )*(0.5+SIGN(0.5,ZZW(:))) &
+ - MIN( PRSS(:),ABS(ZZW(:)) )*(0.5-SIGN(0.5,ZZW(:)))
+ PRSS(:) = PRSS(:) + ZZW(:)
+ PRVS(:) = PRVS(:) - ZZW(:)
+ PTHS(:) = PTHS(:) + ZZW(:)*PLSFACT(:)
+ END WHERE
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:), &
+ 4,'DEPS_BU_RTH')
+ IF (LBUDGET_RV) CALL BUDGET ( &
+ UNPACK(PRVS(:),MASK=OMICRO(:,:,:),FIELD=PRVS3D)*PRHODJ3D(:,:,:), &
+ 6,'DEPS_BU_RRV')
+ IF (LBUDGET_RS) CALL BUDGET ( &
+ UNPACK(PRSS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 10,'DEPS_BU_RRS')
+!
+!* 3.4.4 compute the aggregation on r_s: RIAGGS
+!
+ ZZW(:) = 0.0
+ WHERE ( (PRIT(:)>XRTMIN(4)) .AND. (PRST(:)>XRTMIN(5)) .AND. (PRIS(:)>0.0) )
+ ZZW(:) = MIN( PRIS(:),XFIAGGS * EXP( XCOLEXIS*(PZT(:)-XTT) ) &
+ * PRIT(:) &
+ * PLBDAS(:)**XEXIAGGS &
+ * PRHODREF(:)**(-XCEXVT) )
+ PRSS(:) = PRSS(:) + ZZW(:)
+ PRIS(:) = PRIS(:) - ZZW(:)
+ END WHERE
+ IF (LBUDGET_RI) CALL BUDGET ( &
+ UNPACK(PRIS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 9,'AGGS_BU_RRI')
+ IF (LBUDGET_RS) CALL BUDGET ( &
+ UNPACK(PRSS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 10,'AGGS_BU_RRS')
+!
+!* 3.4.5 compute the autoconversion of r_i for r_s production: RIAUTS
+!
+! ZCRIAUTI(:)=MIN(XCRIAUTI,10**(0.06*(PZT(:)-XTT)-3.5))
+ ZCRIAUTI(:)=MIN(XCRIAUTI,10**(XACRIAUTI*(PZT(:)-XTT)+XBCRIAUTI))
+ ZZW(:) = 0.0
+ WHERE ( (PRIT(:)>XRTMIN(4)) .AND. (PRIS(:)>0.0) )
+ ZZW(:) = MIN( PRIS(:),XTIMAUTI * EXP( XTEXAUTI*(PZT(:)-XTT) ) &
+ * MAX( PRIT(:)-ZCRIAUTI(:),0.0 ) )
+ PRSS(:) = PRSS(:) + ZZW(:)
+ PRIS(:) = PRIS(:) - ZZW(:)
+ END WHERE
+ IF (LBUDGET_RI) CALL BUDGET ( &
+ UNPACK(PRIS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 9,'AUTS_BU_RRI')
+ IF (LBUDGET_RS) CALL BUDGET ( &
+ UNPACK(PRSS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 10,'AUTS_BU_RRS')
+!
+!* 3.4.6 compute the deposition on r_g: RVDEPG
+!
+!
+ WHERE ( PRGT(:)>0.0 )
+ PLBDAG(:) = XLBG*( PRHODREF(:)*MAX( PRGT(:),XRTMIN(6) ) )**XLBEXG
+ END WHERE
+ ZZW(:) = 0.0
+ WHERE ( (PRGT(:)>XRTMIN(6)) .AND. (PRGS(:)>0.0) )
+ ZZW(:) = ( PSSI(:)/(PRHODREF(:)*PAI(:)) ) * &
+ ( X0DEPG*PLBDAG(:)**XEX0DEPG + X1DEPG*PCJ(:)*PLBDAG(:)**XEX1DEPG )
+ ZZW(:) = MIN( PRVS(:),ZZW(:) )*(0.5+SIGN(0.5,ZZW(:))) &
+ - MIN( PRGS(:),ABS(ZZW(:)) )*(0.5-SIGN(0.5,ZZW(:)))
+ PRGS(:) = PRGS(:) + ZZW(:)
+ PRVS(:) = PRVS(:) - ZZW(:)
+ PTHS(:) = PTHS(:) + ZZW(:)*PLSFACT(:)
+ END WHERE
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:), &
+ 4,'DEPG_BU_RTH')
+ IF (LBUDGET_RV) CALL BUDGET ( &
+ UNPACK(PRVS(:),MASK=OMICRO(:,:,:),FIELD=PRVS3D)*PRHODJ3D(:,:,:), &
+ 6,'DEPG_BU_RRV')
+ IF (LBUDGET_RG) CALL BUDGET ( &
+ UNPACK(PRGS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 11,'DEPG_BU_RRG')
+!
+END SUBROUTINE RAIN_ICE_SLOW
+
+END MODULE MODE_RAIN_ICE_SLOW
diff --git a/src/MNH/rain_ice_warm.f90 b/src/MNH/rain_ice_warm.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d83fad363c1beddefca094af98daad3a0d2e1d1f
--- /dev/null
+++ b/src/MNH/rain_ice_warm.f90
@@ -0,0 +1,237 @@
+!MNH_LIC Copyright 1995-2019 CNRS, Meteo-France and Universite Paul Sabatier
+!MNH_LIC This is part of the Meso-NH software governed by the CeCILL-C licence
+!MNH_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
+!MNH_LIC for details. version 1.
+!-----------------------------------------------------------------
+! Modifications:
+! P. Wautelet 25/02/2019: split rain_ice (cleaner and easier to maintain/debug)
+!-----------------------------------------------------------------
+MODULE MODE_RAIN_ICE_WARM
+
+ IMPLICIT NONE
+
+ PRIVATE
+
+ PUBLIC :: RAIN_ICE_WARM
+
+CONTAINS
+
+SUBROUTINE RAIN_ICE_WARM(OMICRO, PRHODREF, PRVT, PRCT, PRRT, PHLC_HCF, PHLC_LCF, PHLC_HRC, PHLC_LRC, &
+ PRHODJ, PPRES, PZT, PLBDAR, PLBDAR_RF, PLVFACT, PCJ, PKA, PDV, PRF, PCF, PTHT, PTHLT, &
+ PRHODJ3D, PTHS3D, PRVS3D, PRVS, PRCS, PRRS, PTHS, PUSW, PEVAP3D)
+!
+!* 0. DECLARATIONS
+! ------------
+!
+use MODD_BUDGET, only: LBUDGET_RC, LBUDGET_RR, LBUDGET_RV, LBUDGET_TH
+use MODD_CST, only: XALPW, XBETAW, XCL, XCPV, XGAMW, XLVTT, XMD, XMV, XRV, XTT
+use MODD_PARAM_ICE, only: CSUBG_RC_RR_ACCR, CSUBG_RR_EVAP
+use MODD_RAIN_ICE_DESCR, only: XCEXVT, XRTMIN
+use MODD_RAIN_ICE_PARAM, only: X0EVAR, X1EVAR, XCRIAUTC, XEX0EVAR, XEX1EVAR, XEXCACCR, XFCACCR, XTIMAUTC
+!
+use MODE_MSG
+!
+use MODI_BUDGET
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+LOGICAL, DIMENSION(:,:,:), intent(in) :: OMICRO ! Test where to compute all processes
+REAL, DIMENSION(:), intent(in) :: PRHODREF ! RHO Dry REFerence
+REAL, DIMENSION(:), intent(in) :: PRVT ! Water vapor m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRCT ! Cloud water m.r. at t
+REAL, DIMENSION(:), intent(in) :: PRRT ! Rain water m.r. at t
+REAL, DIMENSION(:), intent(in) :: PHLC_HCF ! HLCLOUDS : fraction of High Cloud Fraction in grid
+REAL, DIMENSION(:), intent(in) :: PHLC_LCF ! HLCLOUDS : fraction of Low Cloud Fraction in grid
+REAL, DIMENSION(:), intent(in) :: PHLC_HRC ! HLCLOUDS : LWC that is High LWC in grid
+REAL, DIMENSION(:), intent(in) :: PHLC_LRC ! HLCLOUDS : LWC that is Low LWC in grid
+REAL, DIMENSION(:), intent(in) :: PRHODJ ! RHO times Jacobian
+REAL, DIMENSION(:), intent(in) :: PPRES ! Pressure
+REAL, DIMENSION(:), intent(in) :: PZT ! Temperature
+REAL, DIMENSION(:), intent(in) :: PLBDAR ! Slope parameter of the raindrop distribution
+REAL, DIMENSION(:), intent(in) :: PLBDAR_RF! Slope parameter of the raindrop distribution
+ ! for the Rain Fraction part
+REAL, DIMENSION(:), intent(in) :: PLVFACT ! L_v/(Pi_ref*C_ph)
+REAL, DIMENSION(:), intent(in) :: PCJ ! Function to compute the ventilation coefficient
+REAL, DIMENSION(:), intent(in) :: PKA ! Thermal conductivity of the air
+REAL, DIMENSION(:), intent(in) :: PDV ! Diffusivity of water vapor in the air
+REAL, DIMENSION(:), intent(in) :: PRF ! Rain fraction
+REAL, DIMENSION(:), intent(in) :: PCF ! Cloud fraction
+REAL, DIMENSION(:), intent(in) :: PTHT ! Potential temperature
+REAL, DIMENSION(:), intent(in) :: PTHLT ! Liquid potential temperature
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ3D ! Dry density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHS3D ! Theta source
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVS3D ! Water vapor m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
+REAL, DIMENSION(:), INTENT(INOUT) :: PTHS ! Theta source
+!PW: PUSW could be a purely local variable?
+REAL, DIMENSION(:), INTENT(INOUT) :: PUSW ! Undersaturation over water
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PEVAP3D ! Rain evap profile
+!
+!* 0.2 declaration of local variables
+!
+REAL, DIMENSION(size(PRHODREF)) :: ZZW ! Work array
+REAL, DIMENSION(size(PRHODREF)) :: ZZW2 ! Work array
+REAL, DIMENSION(size(PRHODREF)) :: ZZW3 ! Work array
+REAL, DIMENSION(size(PRHODREF)) :: ZZW4 ! Work array
+!
+!-------------------------------------------------------------------------------
+!
+!* 4.2 compute the autoconversion of r_c for r_r production: RCAUTR
+!
+
+ WHERE( PRCS(:)>0.0 .AND. PHLC_HCF(:).GT.0.0 )
+ ZZW(:) = XTIMAUTC*MAX( PHLC_HRC(:)/PHLC_HCF(:) - XCRIAUTC/PRHODREF(:),0.0)
+ ZZW(:) = MIN( PRCS(:),PHLC_HCF(:)*ZZW(:))
+ PRCS(:) = PRCS(:) - ZZW(:)
+ PRRS(:) = PRRS(:) + ZZW(:)
+ END WHERE
+!
+ IF (LBUDGET_RC) CALL BUDGET ( &
+ UNPACK(PRCS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 7,'AUTO_BU_RRC')
+ IF (LBUDGET_RR) CALL BUDGET ( &
+ UNPACK(PRRS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 8,'AUTO_BU_RRR')
+!
+!* 4.3 compute the accretion of r_c for r_r production: RCACCR
+!
+ IF (CSUBG_RC_RR_ACCR=='NONE') THEN
+ !CLoud water and rain are diluted over the grid box
+ WHERE( PRCT(:)>XRTMIN(2) .AND. PRRT(:)>XRTMIN(3) .AND. PRCS(:)>0.0 )
+ ZZW(:) = MIN( PRCS(:), XFCACCR * PRCT(:) &
+ * PLBDAR(:)**XEXCACCR &
+ * PRHODREF(:)**(-XCEXVT) )
+ PRCS(:) = PRCS(:) - ZZW(:)
+ PRRS(:) = PRRS(:) + ZZW(:)
+ END WHERE
+
+ ELSEIF (CSUBG_RC_RR_ACCR=='PRFR') THEN
+ !Cloud water is concentrated over its fraction with possibly to parts with high and low content as set for autoconversion
+ !Rain is concnetrated over its fraction
+ !Rain in high content area fraction: PHLC_HCF
+ !Rain in low content area fraction:
+ ! if PRF<PCF (rain is entirely falling in cloud): PRF-PHLC_HCF
+ ! if PRF>PCF (rain is falling in cloud and in clear sky): PCF-PHLC_HCF
+ ! => min(PCF, PRF)-PHLC_HCF
+ ZZW(:) = 0.
+ WHERE( PHLC_HRC(:)>XRTMIN(2) .AND. PRRT(:)>XRTMIN(3) .AND. PRCS(:)>0.0 &
+ .AND. PHLC_HCF(:)>0 )
+ !Accretion due to rain falling in high cloud content
+ ZZW(:) = XFCACCR * ( PHLC_HRC(:)/PHLC_HCF(:) ) &
+ * PLBDAR_RF(:)**XEXCACCR &
+ * PRHODREF(:)**(-XCEXVT) &
+ * PHLC_HCF
+ END WHERE
+ WHERE( PHLC_LRC(:)>XRTMIN(2) .AND. PRRT(:)>XRTMIN(3) .AND. PRCS(:)>0.0 &
+ .AND. PHLC_LCF(:)>0 )
+ !We add acrretion due to rain falling in low cloud content
+ ZZW(:) = ZZW(:) + XFCACCR * ( PHLC_LRC(:)/PHLC_LCF(:) ) &
+ * PLBDAR_RF(:)**XEXCACCR &
+ * PRHODREF(:)**(-XCEXVT) &
+ * (MIN(PCF(:), PRF(:))-PHLC_HCF(:))
+ END WHERE
+ ZZW(:)=MIN(PRCS(:), ZZW(:))
+ PRCS(:) = PRCS(:) - ZZW(:)
+ PRRS(:) = PRRS(:) + ZZW(:)
+
+ ELSE
+ !wrong CSUBG_RC_RR_ACCR case
+ WRITE(*,*) 'wrong CSUBG_RC_RR_ACCR case'
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','RAIN_ICE_WARM','')
+ ENDIF
+
+ IF (LBUDGET_RC) CALL BUDGET ( &
+ UNPACK(PRCS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 7,'ACCR_BU_RRC')
+ IF (LBUDGET_RR) CALL BUDGET ( &
+ UNPACK(PRRS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 8,'ACCR_BU_RRR')
+!
+!* 4.4 compute the evaporation of r_r: RREVAV
+!
+ ZZW(:) = 0.0
+
+ IF (CSUBG_RR_EVAP=='NONE') THEN
+ !Evaporation only when there's no cloud (RC must be 0)
+ WHERE( (PRRT(:)>XRTMIN(3)) .AND. (PRCT(:)<=XRTMIN(2)) )
+ ZZW(:) = EXP( XALPW - XBETAW/PZT(:) - XGAMW*ALOG(PZT(:) ) ) ! es_w
+ PUSW(:) = 1.0 - PRVT(:)*( PPRES(:)-ZZW(:) ) / ( (XMV/XMD) * ZZW(:) )
+ ! Undersaturation over water
+ ZZW(:) = ( XLVTT+(XCPV-XCL)*(PZT(:)-XTT) )**2 / ( PKA(:)*XRV*PZT(:)**2 ) &
+ + ( XRV*PZT(:) ) / ( PDV(:)*ZZW(:) )
+ ZZW(:) = MIN( PRRS(:),( MAX( 0.0,PUSW(:) )/(PRHODREF(:)*ZZW(:)) ) * &
+ ( X0EVAR*PLBDAR(:)**XEX0EVAR+X1EVAR*PCJ(:)*PLBDAR(:)**XEX1EVAR ) )
+ PRRS(:) = PRRS(:) - ZZW(:)
+ PRVS(:) = PRVS(:) + ZZW(:)
+ PTHS(:) = PTHS(:) - ZZW(:)*PLVFACT(:)
+ END WHERE
+
+ ELSEIF (CSUBG_RR_EVAP=='CLFR' .OR. CSUBG_RR_EVAP=='PRFR') THEN
+ !Evaporation in clear sky part
+ !With CLFR, rain is diluted over the grid box
+ !With PRFR, rain is concentrated in its fraction
+ !Use temperature and humidity in clear sky part like Bechtold et al. (1993)
+ IF (CSUBG_RR_EVAP=='CLFR') THEN
+ ZZW4(:)=1. !Precipitation fraction
+ ZZW3(:)=PLBDAR(:)
+ ELSE
+ ZZW4(:)=PRF(:) !Precipitation fraction
+ ZZW3(:)=PLBDAR_RF(:)
+ ENDIF
+
+ !ATTENTION
+ !Il faudrait recalculer les variables PKA, PDV, PCJ en tenant compte de la température T^u
+ !Ces variables devraient être sorties de rain_ice_slow et on mettrait le calcul de T^u, T^s
+ !et plusieurs versions (comme actuellement, en ciel clair, en ciel nuageux) de PKA, PDV, PCJ dans rain_ice
+ !On utiliserait la bonne version suivant l'option NONE, CLFR... dans l'évaporation et ailleurs
+
+ WHERE( (PRRT(:)>XRTMIN(3)) .AND. ( ZZW4(:) > PCF(:) ) )
+ ! outside the cloud (environment) the use of T^u (unsaturated) instead of T
+ ! Bechtold et al. 1993
+ !
+ ! T^u = T_l = theta_l * (T/theta)
+ ZZW2(:) = PTHLT(:) * PZT(:) / PTHT(:)
+ !
+ ! es_w with new T^u
+ ZZW(:) = EXP( XALPW - XBETAW/ZZW2(:) - XGAMW*ALOG(ZZW2(:) ) )
+ !
+ ! S, Undersaturation over water (with new theta^u)
+ PUSW(:) = 1.0 - PRVT(:)*( PPRES(:)-ZZW(:) ) / ( (XMV/XMD) * ZZW(:) )
+ !
+ ZZW(:) = ( XLVTT+(XCPV-XCL)*(ZZW2(:)-XTT) )**2 / ( PKA(:)*XRV*ZZW2(:)**2 ) &
+ + ( XRV*ZZW2(:) ) / ( PDV(:)*ZZW(:) )
+ !
+ ZZW(:) = MAX( 0.0,PUSW(:) )/(PRHODREF(:)*ZZW(:)) * &
+ ( X0EVAR*ZZW3(:)**XEX0EVAR+X1EVAR*PCJ(:)*ZZW3(:)**XEX1EVAR )
+ !
+ ZZW(:) = MIN( PRRS(:), ZZW(:) *( ZZW4(:) - PCF(:) ) )
+ !
+ PRRS(:) = PRRS(:) - ZZW(:)
+ PRVS(:) = PRVS(:) + ZZW(:)
+ PTHS(:) = PTHS(:) - ZZW(:)*PLVFACT(:)
+ END WHERE
+
+ ELSE
+ !wrong CSUBG_RR_EVAP case
+ WRITE(*,*) 'wrong CSUBG_RR_EVAP case'
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','RAIN_ICE_WARM','')
+ END IF
+
+ IF (LBUDGET_TH) CALL BUDGET ( &
+ UNPACK(PTHS(:),MASK=OMICRO(:,:,:),FIELD=PTHS3D)*PRHODJ3D(:,:,:), &
+ 4,'REVA_BU_RTH')
+ IF (LBUDGET_RV) CALL BUDGET ( &
+ UNPACK(PRVS(:),MASK=OMICRO(:,:,:),FIELD=PRVS3D)*PRHODJ3D(:,:,:), &
+ 6,'REVA_BU_RRV')
+ IF (LBUDGET_RR) CALL BUDGET ( &
+ UNPACK(PRRS(:)*PRHODJ(:),MASK=OMICRO(:,:,:),FIELD=0.0), &
+ 8,'REVA_BU_RRR')
+ PEVAP3D(:,:,:)=UNPACK(ZZW(:),MASK=OMICRO(:,:,:),FIELD=PEVAP3D(:,:,:))
+!
+ END SUBROUTINE RAIN_ICE_WARM
+
+END MODULE MODE_RAIN_ICE_WARM