diff --git a/src/MNH/boundaries.f90 b/src/MNH/boundaries.f90
index 3ab2cf047ca338a8a6a0c4360328154d2f6da13f..e4d8a22e5153977c54e115cf8ae7c35b1eebc802 100644
--- a/src/MNH/boundaries.f90
+++ b/src/MNH/boundaries.f90
@@ -990,7 +990,7 @@ IF (CCLOUD == 'LIMA' .AND. IMI == 1 .AND. CPROGRAM=='MESONH') THEN
ENDIF
CALL INIT_AEROSOL_CONCENTRATION(PRHODREF,ZSVT,XZZ)
DO JSV=NSV_LIMA_CCN_FREE,NSV_LIMA_CCN_FREE+NMOD_CCN-1 ! LBC for CCN
- IF (GLIMABOUNDARY(JSV-NSV_LIMA_CCN_FREE+1)) THEN
+ IF (GLIMABOUNDARY(JSV-NSV_LIMA_BEG+1)) THEN
PSVT(IIB-1,:,:,JSV)=ZSVT(IIB-1,:,:,JSV)
PSVT(IIE+1,:,:,JSV)=ZSVT(IIE+1,:,:,JSV)
PSVT(:,IJB-1,:,JSV)=ZSVT(:,IJB-1,:,JSV)
@@ -998,7 +998,7 @@ IF (CCLOUD == 'LIMA' .AND. IMI == 1 .AND. CPROGRAM=='MESONH') THEN
ENDIF
END DO
DO JSV=NSV_LIMA_IFN_FREE,NSV_LIMA_IFN_FREE+NMOD_IFN-1 ! LBC for IFN
- IF (GLIMABOUNDARY(JSV-NSV_LIMA_IFN_FREE+1)) THEN
+ IF (GLIMABOUNDARY(JSV-NSV_LIMA_BEG+1)) THEN
PSVT(IIB-1,:,:,JSV)=ZSVT(IIB-1,:,:,JSV)
PSVT(IIE+1,:,:,JSV)=ZSVT(IIE+1,:,:,JSV)
PSVT(:,IJB-1,:,JSV)=ZSVT(:,IJB-1,:,JSV)
@@ -1008,7 +1008,7 @@ IF (CCLOUD == 'LIMA' .AND. IMI == 1 .AND. CPROGRAM=='MESONH') THEN
CALL SET_CONC_LIMA( IMI, 'NONE', PRHODREF, ZRT(:, :, :, :), ZSVT(:, :, :, NSV_LIMA_BEG:NSV_LIMA_END) )
IF (NSV_LIMA_NC.GE.1) THEN
- IF (GLIMABOUNDARY(NSV_LIMA_NC)) THEN
+ IF (GLIMABOUNDARY(NSV_LIMA_NC-NSV_LIMA_BEG+1)) THEN
PSVT(IIB-1,:,:,NSV_LIMA_NC)=ZSVT(IIB-1,:,:,NSV_LIMA_NC) ! cloud
PSVT(IIE+1,:,:,NSV_LIMA_NC)=ZSVT(IIE+1,:,:,NSV_LIMA_NC)
PSVT(:,IJB-1,:,NSV_LIMA_NC)=ZSVT(:,IJB-1,:,NSV_LIMA_NC)
@@ -1016,7 +1016,7 @@ IF (CCLOUD == 'LIMA' .AND. IMI == 1 .AND. CPROGRAM=='MESONH') THEN
ENDIF
ENDIF
IF (NSV_LIMA_NR.GE.1) THEN
- IF (GLIMABOUNDARY(NSV_LIMA_NR)) THEN
+ IF (GLIMABOUNDARY(NSV_LIMA_NR-NSV_LIMA_BEG+1)) THEN
PSVT(IIB-1,:,:,NSV_LIMA_NR)=ZSVT(IIB-1,:,:,NSV_LIMA_NR) ! rain
PSVT(IIE+1,:,:,NSV_LIMA_NR)=ZSVT(IIE+1,:,:,NSV_LIMA_NR)
PSVT(:,IJB-1,:,NSV_LIMA_NR)=ZSVT(:,IJB-1,:,NSV_LIMA_NR)
@@ -1024,14 +1024,13 @@ IF (CCLOUD == 'LIMA' .AND. IMI == 1 .AND. CPROGRAM=='MESONH') THEN
ENDIF
ENDIF
IF (NSV_LIMA_NI.GE.1) THEN
- IF (GLIMABOUNDARY(NSV_LIMA_NI)) THEN
+ IF (GLIMABOUNDARY(NSV_LIMA_NI-NSV_LIMA_BEG+1)) THEN
PSVT(IIB-1,:,:,NSV_LIMA_NI)=ZSVT(IIB-1,:,:,NSV_LIMA_NI) ! ice
PSVT(IIE+1,:,:,NSV_LIMA_NI)=ZSVT(IIE+1,:,:,NSV_LIMA_NI)
PSVT(:,IJB-1,:,NSV_LIMA_NI)=ZSVT(:,IJB-1,:,NSV_LIMA_NI)
PSVT(:,IJE+1,:,NSV_LIMA_NI)=ZSVT(:,IJE+1,:,NSV_LIMA_NI)
ENDIF
END IF
-
END IF
!
!
diff --git a/src/MNH/change_gribex_var.f90 b/src/MNH/change_gribex_var.f90
index a24b85dc832b2beaec76afa82d636023fbc7dabe..984ef465e974f64a6c2694d6dbb66d4c4b3e6bd8 100644
--- a/src/MNH/change_gribex_var.f90
+++ b/src/MNH/change_gribex_var.f90
@@ -304,6 +304,7 @@ END IF
!
DO JRR=2,SIZE(PR_LS,4)
PR_LS(:,:,:,JRR) = 1. / (1./MAX(PQ_LS(:,:,:,JRR),1.E-12) - 1.)
+ WHERE(PR_LS(:,:,:,JRR).LE.2.E-12) PR_LS(:,:,:,JRR)=0.
END DO
!
PR_LS(:,:,:,1)=SM_PMR_HU(PPMASS_LS(:,:,:), &
diff --git a/src/MNH/condensation.f90 b/src/MNH/condensation.f90
index a21ed2793ec5d611b9768d2e05bf391ebbb0eae7..64ddf75f5247d3ac4cc7454405e35590b22ea005 100644
--- a/src/MNH/condensation.f90
+++ b/src/MNH/condensation.f90
@@ -23,21 +23,14 @@ INTEGER, INTENT(IN) :: KJE ! value of the last point
INTEGER, INTENT(IN) :: KKB ! value of the first point in z
INTEGER, INTENT(IN) :: KKE ! value of the last point in z
INTEGER, INTENT(IN) :: KKL ! +1 if grid goes from ground to atmosphere top, -1 otherwise
-CHARACTER(len=1), INTENT(IN) :: HFRAC_ICE
-CHARACTER(len=4), INTENT(IN) :: HCONDENS
-CHARACTER(len=*), INTENT(IN) :: HLAMBDA3 ! formulation for lambda3 coeff
+CHARACTER(len=1), INTENT(IN) :: HFRAC_ICE
+CHARACTER(len=4), INTENT(IN) :: HCONDENS
+CHARACTER(len=*), INTENT(IN) :: HLAMBDA3 ! formulation for lambda3 coeff
REAL, DIMENSION(KIU,KJU,KKU), INTENT(IN) :: PPABS ! pressure (Pa)
REAL, DIMENSION(KIU,KJU,KKU), INTENT(IN) :: PZZ ! height of model levels (m)
REAL, DIMENSION(KIU,KJU,KKU), INTENT(IN) :: PRHODREF
REAL, DIMENSION(KIU,KJU,KKU), INTENT(INOUT) :: PT ! grid scale T (K)
REAL, DIMENSION(KIU,KJU,KKU), INTENT(INOUT) :: PRV ! grid scale water vapor mixing ratio (kg/kg)
-LOGICAL, INTENT(IN) :: OUSERI ! logical switch to compute both
- ! liquid and solid condensate (OUSERI=.TRUE.)
- ! or only solid condensate (OUSERI=.FALSE.)
-LOGICAL, INTENT(IN) :: OSIGMAS! use present global Sigma_s values
- ! or that from turbulence scheme
-REAL, INTENT(IN) :: PSIGQSAT ! use an extra "qsat" variance contribution (OSIGMAS case)
- ! multiplied by PSIGQSAT
REAL, DIMENSION(KIU,KJU,KKU), INTENT(INOUT) :: PRC ! grid scale r_c mixing ratio (kg/kg)
REAL, DIMENSION(KIU,KJU,KKU), INTENT(INOUT) :: PRI ! grid scale r_i (kg/kg)
REAL, DIMENSION(KIU,KJU,KKU), INTENT(IN) :: PRS ! grid scale mixing ration of snow (kg/kg)
@@ -46,6 +39,12 @@ REAL, DIMENSION(KIU,KJU,KKU), INTENT(IN) :: PSIGS ! Sigma_s from turbulence
REAL, DIMENSION(:,:,:), INTENT(IN) :: PMFCONV! convective mass flux (kg /s m^2)
REAL, DIMENSION(KIU,KJU,KKU), INTENT(OUT) :: PCLDFR ! cloud fraction
REAL, DIMENSION(KIU,KJU,KKU), INTENT(OUT) :: PSIGRC ! s r_c / sig_s^2
+LOGICAL, INTENT(IN) :: OUSERI ! logical switch to compute both
+ ! liquid and solid condensate (OUSERI=.TRUE.)
+ ! or only solid condensate (OUSERI=.FALSE.)
+LOGICAL, INTENT(IN) :: OSIGMAS! use present global Sigma_s values
+ ! or that from turbulence scheme
+REAL, INTENT(IN) :: PSIGQSAT ! use an extra "qsat" variance contribution (OSIGMAS case)
REAL, DIMENSION(KIU,KJU,KKU), OPTIONAL, INTENT(IN) :: PLV
REAL, DIMENSION(KIU,KJU,KKU), OPTIONAL, INTENT(IN) :: PLS
REAL, DIMENSION(KIU,KJU,KKU), OPTIONAL, INTENT(IN) :: PCPH
@@ -137,6 +136,8 @@ USE MODD_PARAMETERS
USE MODD_RAIN_ICE_PARAM, ONLY : XCRIAUTC, XCRIAUTI, XACRIAUTI, XBCRIAUTI
USE MODI_COMPUTE_FRAC_ICE
!
+use mode_msg
+!
IMPLICIT NONE
!
!* 0.1 Declarations of dummy arguments :
@@ -152,21 +153,14 @@ INTEGER, INTENT(IN) :: KJE ! value of the last point
INTEGER, INTENT(IN) :: KKB ! value of the first point in z
INTEGER, INTENT(IN) :: KKE ! value of the last point in z
INTEGER, INTENT(IN) :: KKL ! +1 if grid goes from ground to atmosphere top, -1 otherwise
-CHARACTER(len=1), INTENT(IN) :: HFRAC_ICE
-CHARACTER(len=4), INTENT(IN) :: HCONDENS
-CHARACTER(len=*), INTENT(IN) :: HLAMBDA3 ! formulation for lambda3 coeff
+CHARACTER(len=1), INTENT(IN) :: HFRAC_ICE
+CHARACTER(len=4), INTENT(IN) :: HCONDENS
+CHARACTER(len=*), INTENT(IN) :: HLAMBDA3 ! formulation for lambda3 coeff
REAL, DIMENSION(KIU,KJU,KKU), INTENT(IN) :: PPABS ! pressure (Pa)
REAL, DIMENSION(KIU,KJU,KKU), INTENT(IN) :: PZZ ! height of model levels (m)
REAL, DIMENSION(KIU,KJU,KKU), INTENT(IN) :: PRHODREF
REAL, DIMENSION(KIU,KJU,KKU), INTENT(INOUT) :: PT ! grid scale T (K)
REAL, DIMENSION(KIU,KJU,KKU), INTENT(INOUT) :: PRV ! grid scale water vapor mixing ratio (kg/kg)
-LOGICAL, INTENT(IN) :: OUSERI ! logical switch to compute both
- ! liquid and solid condensate (OUSERI=.TRUE.)
- ! or only solid condensate (OUSERI=.FALSE.)
-LOGICAL, INTENT(IN) :: OSIGMAS! use present global Sigma_s values
- ! or that from turbulence scheme
-REAL, INTENT(IN) :: PSIGQSAT ! use an extra "qsat" variance contribution (OSIGMAS case)
- ! multiplied by PSIGQSAT
REAL, DIMENSION(KIU,KJU,KKU), INTENT(INOUT) :: PRC ! grid scale r_c mixing ratio (kg/kg)
REAL, DIMENSION(KIU,KJU,KKU), INTENT(INOUT) :: PRI ! grid scale r_i (kg/kg)
REAL, DIMENSION(KIU,KJU,KKU), INTENT(IN) :: PRS ! grid scale mixing ration of snow (kg/kg)
@@ -175,6 +169,7 @@ REAL, DIMENSION(KIU,KJU,KKU), INTENT(IN) :: PSIGS ! Sigma_s from turbulence
REAL, DIMENSION(:,:,:), INTENT(IN) :: PMFCONV! convective mass flux (kg /s m^2)
REAL, DIMENSION(KIU,KJU,KKU), INTENT(OUT) :: PCLDFR ! cloud fraction
REAL, DIMENSION(KIU,KJU,KKU), INTENT(OUT) :: PSIGRC ! s r_c / sig_s^2
+
REAL, DIMENSION(KIU,KJU,KKU), OPTIONAL, INTENT(IN) :: PLV ! Latent heat L_v
REAL, DIMENSION(KIU,KJU,KKU), OPTIONAL, INTENT(IN) :: PLS ! Latent heat L_s
REAL, DIMENSION(KIU,KJU,KKU), OPTIONAL, INTENT(IN) :: PCPH ! Specific heat C_ph
@@ -182,6 +177,13 @@ REAL, DIMENSION(KIU,KJU,KKU), OPTIONAL, INTENT(OUT) :: PHLC_HRC
REAL, DIMENSION(KIU,KJU,KKU), OPTIONAL, INTENT(OUT) :: PHLC_HCF ! cloud fraction
REAL, DIMENSION(KIU,KJU,KKU), OPTIONAL, INTENT(OUT) :: PHLI_HRI
REAL, DIMENSION(KIU,KJU,KKU), OPTIONAL, INTENT(OUT) :: PHLI_HCF
+LOGICAL, INTENT(IN) :: OUSERI ! logical switch to compute both
+ ! liquid and solid condensate (OUSERI=.TRUE.)
+ ! or only solid condensate (OUSERI=.FALSE.)
+LOGICAL, INTENT(IN) :: OSIGMAS! use present global Sigma_s values
+ ! or that from turbulence scheme
+REAL, INTENT(IN) :: PSIGQSAT ! use an extra "qsat" variance contribution (OSIGMAS case)
+
!
!
!* 0.2 Declarations of local variables :
@@ -498,10 +500,7 @@ DO JK=IKTB,IKTE
PSIGRC(JI,JJ,JK) = PSIGRC(JI,JJ,JK)* MIN( 3. , MAX(1.,1.-ZQ1) )
ELSEIF(HLAMBDA3=='NONE') THEN
ELSE
- WRITE(*,*) ' STOP'
- WRITE(*,*) ' INVALID VALUE FOR HLAMBDA3:', HLAMBDA3
- CALL ABORT
- STOP
+ call Print_msg( NVERB_FATAL, 'GEN', 'CONDENSATION', 'INVALID VALUE FOR HLAMBDA3' )
ENDIF
END DO
diff --git a/src/MNH/default_desfmn.f90 b/src/MNH/default_desfmn.f90
index 2e9dd5730e72de76434299627dfbeabe0f4390c2..d8c57ac95b408c0854e2dd6efde060457426a637 100644
--- a/src/MNH/default_desfmn.f90
+++ b/src/MNH/default_desfmn.f90
@@ -214,6 +214,7 @@ END MODULE MODI_DEFAULT_DESFM_n
! S. Riette 21/05/2021: add options to PDF subgrid scheme
! 05/2021 D. Ricard add the contribution of Leonard terms in the turbulence scheme
!! JL Redelsperger 06/2021 add parameters allowing to active idealized oceanic convection
+!! B. Vie 06/2021 Add prognostic supersaturation for LIMA
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
@@ -271,8 +272,9 @@ USE MODD_PARAM_LIMA, ONLY : LCOLD, LNUCL, LSEDI, LHHONI, LSNOW, LHAIL, LMEYERS,&
CPRISTINE_ICE_LIMA, CHEVRIMED_ICE_LIMA, &
XFACTNUC_DEP, XFACTNUC_CON, &
OWARM=>LWARM, LACTI, ORAIN=>LRAIN, OSEDC=>LSEDC, &
- OACTIT=>LACTIT, LBOUND, NMOD_CCN, XCCN_CONC, &
- LCCN_HOM, CCCN_MODES, &
+ OACTIT=>LACTIT, LBOUND, LSPRO, LADJ, &
+ NMOD_CCN, XCCN_CONC, &
+ LCCN_HOM, CCCN_MODES, &
YALPHAR=>XALPHAR, YNUR=>XNUR, &
YALPHAC=>XALPHAC, YNUC=>XNUC, CINI_CCN=>HINI_CCN, &
CTYPE_CCN=>HTYPE_CCN, YFSOLUB_CCN=>XFSOLUB_CCN, &
@@ -960,6 +962,8 @@ IF (KMI == 1) THEN
ORAIN = .TRUE.
OSEDC = .FALSE.
OACTIT = .FALSE.
+ LADJ = .TRUE.
+ LSPRO = .FALSE.
ODEPOC = .FALSE.
LBOUND = .FALSE.
OACTTKE = .TRUE.
diff --git a/src/MNH/hypgeo.f90 b/src/MNH/hypgeo.f90
index fa64d778da5ee68c7483f3a2ce969f7dda5269fe..9a2872f84dafff2d7410684e5c641044ef1c999a 100644
--- a/src/MNH/hypgeo.f90
+++ b/src/MNH/hypgeo.f90
@@ -97,7 +97,7 @@ REAL :: ZX0,ZX1,ZZA,ZZB,ZZC,ZZD,Y(2)
!------------------------------------------------------------------------------
!
!
-ZEPS = 2.E-2
+ZEPS = 4.E-2
ZXH = PF * PX**2.0
IF (ZXH.LT.(1-ZEPS)) THEN
CALL HYPSER(PA,PB,PC,-ZXH,PHYPGEO)
diff --git a/src/MNH/ini_budget.f90 b/src/MNH/ini_budget.f90
index f5d18a90b6e7153f96825f34716bb2ce6716f22a..c2bf6df6c3e2b6dc5a030bcbb21167a1a4c4bfaf 100644
--- a/src/MNH/ini_budget.f90
+++ b/src/MNH/ini_budget.f90
@@ -1238,7 +1238,8 @@ if ( lbu_rth ) then
tzsource%cmnhname = 'CDEPI'
tzsource%clongname = 'deposition on ice'
- tzsource%lavailable = hcloud(1:3) == 'ICE' .and. ( .not. lred .or. ( lred .and. ladj_after ) .or. celec /= 'NONE' )
+ tzsource%lavailable = hcloud(1:3) == 'ICE' .and. ( .not. lred .or. ( lred .and. ladj_after ) .or. celec /= 'NONE')&
+ .or. (hcloud == 'LIMA' .and. lptsplit)
call Budget_source_add( tbudgets(NBUDGET_TH), tzsource )
tzsource%cmnhname = 'COND'
@@ -1549,7 +1550,8 @@ if ( tbudgets(NBUDGET_RV)%lenabled ) then
tzsource%cmnhname = 'CDEPI'
tzsource%clongname = 'deposition on ice'
- tzsource%lavailable = hcloud(1:3) == 'ICE' .and. ( .not. lred .or. ( lred .and. ladj_after ) .or. celec /= 'NONE' )
+ tzsource%lavailable = hcloud(1:3) == 'ICE' .and. ( .not. lred .or. ( lred .and. ladj_after ) .or. celec /= 'NONE')&
+ .or. (hcloud == 'LIMA' .and. lptsplit)
call Budget_source_add( tbudgets(NBUDGET_RV), tzsource )
tzsource%cmnhname = 'CORR2'
@@ -2299,7 +2301,8 @@ if ( tbudgets(NBUDGET_RI)%lenabled ) then
tzsource%cmnhname = 'CDEPI'
tzsource%clongname = 'condensation/deposition on ice'
- tzsource%lavailable = hcloud(1:3) == 'ICE' .and. ( .not. lred .or. ( lred .and. ladj_after ) .or. celec /= 'NONE' )
+ tzsource%lavailable = hcloud(1:3) == 'ICE' .and. ( .not. lred .or. ( lred .and. ladj_after ) .or. celec /= 'NONE')&
+ .or. (hcloud == 'LIMA' .and. lptsplit)
call Budget_source_add( tbudgets(NBUDGET_RI), tzsource )
tzsource%cmnhname = 'CORR2'
@@ -2682,7 +2685,7 @@ if ( tbudgets(NBUDGET_RG)%lenabled ) then
tzsource%clongname = 'wet growth of hail'
tzsource%lavailable = ( hcloud == 'LIMA' .and. .not.lptsplit .and. lhail_lima .and. lcold_lima &
.and. lwarm_lima .and. lsnow_lima ) &
- .or. hcloud == 'ICE4'
+ .or. (hcloud == 'ICE4' .and. .not. lred)
call Budget_source_add( tbudgets(NBUDGET_RG), tzsource )
tzsource%cmnhname = 'COHG'
@@ -3160,7 +3163,7 @@ SV_BUDGETS: do jsv = 1, ksv
tzsource%cmnhname = 'SELF'
tzsource%clongname = 'self-collection of cloud droplets'
- tzsource%lavailable = lwarm_lima .and. lrain_lima
+ tzsource%lavailable = lptsplit .or. (lwarm_lima .and. lrain_lima)
call Budget_source_add( tbudgets(ibudget), tzsource )
tzsource%cmnhname = 'AUTO'
diff --git a/src/MNH/ini_lima.f90 b/src/MNH/ini_lima.f90
index 58257019d57ec24e9097d95dc40c878da1e07e01..f88115734bc0e04eb47a2d17e1094e4c53ee4976 100644
--- a/src/MNH/ini_lima.f90
+++ b/src/MNH/ini_lima.f90
@@ -136,18 +136,16 @@ IF (ALLOCATED(XRTMIN)) RETURN ! In case of nesting microphysics, constants of
!
! Set bounds for mixing ratios and concentrations
ALLOCATE( XRTMIN(7) )
-XRTMIN(1) = 1.0E-20 ! rv
-XRTMIN(2) = 1.0E-20 ! rc
-!XRTMIN(3) = 1.0E-20 ! rr
-XRTMIN(3) = 1.0E-17 ! rr
-XRTMIN(4) = 1.0E-20 ! ri
-XRTMIN(5) = 1.0E-15 ! rs
-XRTMIN(6) = 1.0E-15 ! rg
-XRTMIN(7) = 1.0E-15 ! rh
+XRTMIN(1) = 1.0E-10 ! rv
+XRTMIN(2) = 1.0E-10 ! rc
+XRTMIN(3) = 1.0E-10 ! rr
+XRTMIN(4) = 1.0E-10 ! ri
+XRTMIN(5) = 1.0E-10 ! rs
+XRTMIN(6) = 1.0E-10 ! rg
+XRTMIN(7) = 1.0E-10 ! rh
ALLOCATE( XCTMIN(7) )
XCTMIN(1) = 1.0 ! Not used
XCTMIN(2) = 1.0E-3 ! Nc
-!XCTMIN(3) = 1.0E+1 ! Nr
XCTMIN(3) = 1.0E-3 ! Nr
XCTMIN(4) = 1.0E-3 ! Ni
XCTMIN(5) = 1.0E-3 ! Not used
diff --git a/src/MNH/ini_lima_warm.f90 b/src/MNH/ini_lima_warm.f90
index 0afeea4928ba710840a31261e0f7d62fa44e73c1..d2bb45682a853f6539a5eda935748e3bd437e516 100644
--- a/src/MNH/ini_lima_warm.f90
+++ b/src/MNH/ini_lima_warm.f90
@@ -276,6 +276,8 @@ XAHENINTP2 = 0.5*REAL(NAHEN-1) - XTT
! G
!
ALLOCATE (XAHENG(NAHEN))
+ALLOCATE (XAHENG2(NAHEN))
+ALLOCATE (XAHENG3(NAHEN))
ALLOCATE (XPSI1(NAHEN))
ALLOCATE (XPSI3(NAHEN))
XCSTHEN = 1.0 / ( XRHOLW*2.0*XPI )
@@ -288,6 +290,8 @@ DO J1 = 1,NAHEN
(XDIVA*EXP(XALPW-(XBETAW/ZTT)-(XGAMW*ALOG(ZTT)))) &
+ (ZLV/ZTT)**2/(XTHCO*XRV) ) )
XAHENG(J1) = XCSTHEN/(ZG)**(3./2.)
+ XAHENG2(J1) = 1/(ZG)**(1./2.) * GAMMA_X0D(XNUC+1./XALPHAC)/GAMMA_X0D(XNUC)
+ XAHENG3(J1) = (ZG) * GAMMA_X0D(XNUC+1./XALPHAC)/GAMMA_X0D(XNUC)
END DO
!-------------------------------------------------------------------------------
!
diff --git a/src/MNH/ini_micron.f90 b/src/MNH/ini_micron.f90
index 7f4e0225444fc2c24a8ea7b01af2a5a865b1cadd..6db366f9883b2f51fda66201654b6cc1b16a20e1 100644
--- a/src/MNH/ini_micron.f90
+++ b/src/MNH/ini_micron.f90
@@ -99,13 +99,7 @@ USE MODE_SET_CONC_LIMA
!
USE MODD_NSV, ONLY : NSV,NSV_CHEM,NSV_C2R2BEG,NSV_C2R2END, &
NSV_C1R3BEG,NSV_C1R3END, &
- NSV_LIMA, NSV_LIMA_BEG, NSV_LIMA_END, &
- NSV_LIMA_NC, NSV_LIMA_NR, &
- NSV_LIMA_CCN_FREE, NSV_LIMA_CCN_ACTI, &
- NSV_LIMA_SCAVMASS, &
- NSV_LIMA_NI, &
- NSV_LIMA_IFN_FREE, NSV_LIMA_IFN_NUCL, &
- NSV_LIMA_IMM_NUCL, NSV_LIMA_HOM_HAZE
+ NSV_LIMA_BEG, NSV_LIMA_END
USE MODD_PARAM_LIMA, ONLY : LSCAV, MSEDC=>LSEDC, MACTIT=>LACTIT, MDEPOC=>LDEPOC
USE MODD_LIMA_PRECIP_SCAVENGING_n
!
diff --git a/src/MNH/ini_nsv.f90 b/src/MNH/ini_nsv.f90
index 56b94ec176cacfb3ca48393fbf74517d78c08c09..24d4d1c5ef865313fd87a9ee42f8608d80e59882 100644
--- a/src/MNH/ini_nsv.f90
+++ b/src/MNH/ini_nsv.f90
@@ -69,6 +69,8 @@ END MODULE MODI_INI_NSV
! P. Wautelet 10/03/2021: move scalar variable name initializations to ini_nsv
! P. Wautelet 10/03/2021: add CSVNAMES and CSVNAMES_A to store the name of all the scalar variables
! P. Wautelet 30/03/2021: move NINDICE_CCN_IMM and NIMM initializations from init_aerosol_properties to ini_nsv
+!! B. Vie 06/2021 Add prognostic supersaturation for LIMA
+!!
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
@@ -106,7 +108,7 @@ USE MODD_NSV
USE MODD_PARAM_C2R2, ONLY: LSUPSAT
USE MODD_PARAM_LIMA, ONLY: NINDICE_CCN_IMM, NIMM, NMOD_CCN, LSCAV, LAERO_MASS, &
NMOD_IFN, NMOD_IMM, LHHONI, &
- LWARM, LCOLD, LRAIN
+ LWARM, LCOLD, LRAIN, LSPRO
USE MODD_PARAM_LIMA_COLD, ONLY: CLIMA_COLD_NAMES
USE MODD_PARAM_LIMA_WARM, ONLY: CAERO_MASS, CLIMA_WARM_NAMES
USE MODD_PARAM_n, ONLY: CCLOUD, CELEC
@@ -253,6 +255,11 @@ IF (CCLOUD == 'LIMA' ) THEN
NSV_LIMA_HOM_HAZE_A(KMI) = ISV
ISV = ISV + 1
END IF
+! Supersaturation
+ IF (LSPRO) THEN
+ NSV_LIMA_SPRO_A(KMI) = ISV
+ ISV = ISV + 1
+ END IF
!
! End and total variables
!
diff --git a/src/MNH/init_aerosol_properties.f90 b/src/MNH/init_aerosol_properties.f90
index b52de24a753b5687a88bf2e42f6b6155596cdc4e..bc4f19826023ed52b30f0295418b430b2bb9d9ca 100644
--- a/src/MNH/init_aerosol_properties.f90
+++ b/src/MNH/init_aerosol_properties.f90
@@ -37,6 +37,8 @@ END MODULE MODI_INIT_AEROSOL_PROPERTIES
!! Philippe Wautelet: 22/01/2019: bugs correction: incorrect writes + unauthorized goto
! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg
! P. Wautelet 30/03/2021: move NINDICE_CCN_IMM and NIMM initializations from init_aerosol_properties to ini_nsv
+!! Benoît Vié: 06/2021: kappa-kohler CCN activation parameters
+!!
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
@@ -55,6 +57,7 @@ USE MODD_PARAM_LIMA, ONLY : NMOD_CCN, HINI_CCN, HTYPE_CCN, &
use mode_msg
!
USE MODI_GAMMA
+USE MODI_LIMA_INIT_CCN_ACTIVATION_SPECTRUM
!
IMPLICIT NONE
!
@@ -83,7 +86,14 @@ INTEGER :: I,J,JMOD
!
INTEGER :: ILUOUT0 ! Logical unit number for output-listing
INTEGER :: IRESP ! Return code of FM-routines
-
+!
+REAL :: X1, X2, X3, X4, X5
+REAL, DIMENSION(7) :: diameters=(/ 0.01E-6, 0.05E-6, 0.1E-6, 0.2E-6, 0.5E-6, 1.E-6, 2.E-6 /)
+REAL, DIMENSION(3) :: sigma=(/ 2., 2.5, 3. /)
+CHARACTER(LEN=7), DIMENSION(3) :: types=(/ 'NH42SO4', 'NaCl ', ' ' /)
+!REAL, DIMENSION(1) :: diameters=(/ 0.25E-6 /)
+!CHARACTER(LEN=7), DIMENSION(1) :: types=(/ ' ' /)
+INTEGER :: II, IJ, IK
!
!-------------------------------------------------------------------------------
!
@@ -108,15 +118,25 @@ IF ( NMOD_CCN .GE. 1 ) THEN
RCCN(:) = (/ 0.125E-6 , 0.4E-6 , 1.0E-6 /)
LOGSIGCCN(:) = (/ 0.69 , 0.41 , 0.47 /)
RHOCCN(:) = (/ 1000. , 1000. , 1000. /)
- CASE ('MACC')
+ CASE ('CAMS')
RCCN(:) = (/ 0.4E-6 , 0.25E-6 , 0.1E-6 /)
LOGSIGCCN(:) = (/ 0.64 , 0.47 , 0.47 /)
RHOCCN(:) = (/ 2160. , 2000. , 1750. /)
- CASE ('MACC_JPP')
+ CASE ('CAMS_JPP')
! sea-salt, sulfate, hydrophilic (GADS data)
RCCN(:) = (/ 0.209E-6 , 0.0695E-6 , 0.0212E-6 /)
LOGSIGCCN(:) = (/ 0.708 , 0.708 , 0.806 /)
RHOCCN(:) = (/ 2200. , 1700. , 1800. /)
+ CASE ('CAMS_ACC')
+! sea-salt, sulfate, hydrophilic (GADS data)
+ RCCN(:) = (/ 0.2E-6 , 0.5E-6 , 0.4E-6 /)
+ LOGSIGCCN(:) = (/ 0.693 , 0.476 , 0.788 /)
+ RHOCCN(:) = (/ 2200. , 1700. , 1800. /)
+ CASE ('CAMS_AIT')
+! sea-salt, sulfate, hydrophilic (GADS data)
+ RCCN(:) = (/ 0.2E-6 , 0.05E-6 , 0.02E-6 /)
+ LOGSIGCCN(:) = (/ 0.693 , 0.693 , 0.788 /)
+ RHOCCN(:) = (/ 2200. , 1700. , 1800. /)
CASE ('SIRTA')
RCCN(:) = (/ 0.153E-6 , 0.058E-6 , 0.763E-6 /)
LOGSIGCCN(:) = (/ 0.846 , 0.57 , 0.34 /)
@@ -191,48 +211,60 @@ IF ( NMOD_CCN .GE. 1 ) THEN
!
DO JMOD = 1, NMOD_CCN
!
- SELECT CASE (HTYPE_CCN(JMOD))
- CASE ('M') ! CCN marins
- XKHEN0 = 3.251
- XLOGSIG0 = 0.4835
- XALPHA1 = -1.297
- XMUHEN0 = 2.589
- XALPHA2 = -1.511
- XBETAHEN0 = 621.689
- XR_MEAN0 = 0.133E-6
- XALPHA3 = 3.002
- XALPHA4 = 1.081
- XALPHA5 = 1.0
- XACTEMP0 = 290.16
- XALPHA6 = 2.995
- CASE ('C') ! CCN continentaux
- XKHEN0 = 1.403
- XLOGSIG0 = 1.16
- XALPHA1 = -1.172
- XMUHEN0 = 0.834
- XALPHA2 = -1.350
- XBETAHEN0 = 25.499
- XR_MEAN0 = 0.0218E-6
- XALPHA3 = 3.057
- XALPHA4 = 4.092
- XALPHA5 = 1.011
- XACTEMP0 = 290.16
- XALPHA6 = 3.076
- CASE DEFAULT
- call Print_msg(NVERB_FATAL,'GEN','INIT_AEROSOL_PROPERTIES','HTYPE_CNN(JMOD)=C or M must be specified'// &
- ' in EXSEG1.nam for each CCN mode')
- ENDSELECT
-!
- XKHEN_MULTI(JMOD) = XKHEN0*(XLOGSIG_CCN(JMOD)/XLOGSIG0)**XALPHA1
- XMUHEN_MULTI(JMOD) = XMUHEN0*(XLOGSIG_CCN(JMOD)/XLOGSIG0)**XALPHA2
- XBETAHEN_MULTI(JMOD)=XBETAHEN0*(XR_MEAN_CCN(JMOD)/XR_MEAN0)**XALPHA3 &
- * EXP( XALPHA4*((XLOGSIG_CCN(JMOD)/XLOGSIG0)-1.) ) &
- * XFSOLUB_CCN**XALPHA5 &
- * (XACTEMP_CCN/XACTEMP0)**XALPHA6
- XLIMIT_FACTOR(JMOD) = ( GAMMA_X0D(0.5*XKHEN_MULTI(JMOD)+1.) &
- *GAMMA_X0D(XMUHEN_MULTI(JMOD)-0.5*XKHEN_MULTI(JMOD)) ) &
- /( XBETAHEN_MULTI(JMOD)**(0.5*XKHEN_MULTI(JMOD)) &
- *GAMMA_X0D(XMUHEN_MULTI(JMOD)) )
+!!$ SELECT CASE (HTYPE_CCN(JMOD))
+!!$ CASE ('M') ! CCN marins
+!!$ XKHEN0 = 3.251
+!!$ XLOGSIG0 = 0.4835
+!!$ XALPHA1 = -1.297
+!!$ XMUHEN0 = 2.589
+!!$ XALPHA2 = -1.511
+!!$ XBETAHEN0 = 621.689
+!!$ XR_MEAN0 = 0.133E-6
+!!$ XALPHA3 = 3.002
+!!$ XALPHA4 = 1.081
+!!$ XALPHA5 = 1.0
+!!$ XACTEMP0 = 290.16
+!!$ XALPHA6 = 2.995
+!!$ CASE ('C') ! CCN continentaux
+!!$ XKHEN0 = 1.403
+!!$ XLOGSIG0 = 1.16
+!!$ XALPHA1 = -1.172
+!!$ XMUHEN0 = 0.834
+!!$ XALPHA2 = -1.350
+!!$ XBETAHEN0 = 25.499
+!!$ XR_MEAN0 = 0.0218E-6
+!!$ XALPHA3 = 3.057
+!!$ XALPHA4 = 4.092
+!!$ XALPHA5 = 1.011
+!!$ XACTEMP0 = 290.16
+!!$ XALPHA6 = 3.076
+!!$ CASE DEFAULT
+!!$ call Print_msg(NVERB_FATAL,'GEN','INIT_AEROSOL_PROPERTIES','HTYPE_CNN(JMOD)=C or M must be specified'// &
+!!$ ' in EXSEG1.nam for each CCN mode')
+!!$ ENDSELECT
+!!$!
+!!$ XKHEN_MULTI(JMOD) = XKHEN0*(XLOGSIG_CCN(JMOD)/XLOGSIG0)**XALPHA1
+!!$ XMUHEN_MULTI(JMOD) = XMUHEN0*(XLOGSIG_CCN(JMOD)/XLOGSIG0)**XALPHA2
+!!$ XBETAHEN_MULTI(JMOD)=XBETAHEN0*(XR_MEAN_CCN(JMOD)/XR_MEAN0)**XALPHA3 &
+!!$ * EXP( XALPHA4*((XLOGSIG_CCN(JMOD)/XLOGSIG0)-1.) ) &
+!!$ * XFSOLUB_CCN**XALPHA5 &
+!!$ * (XACTEMP_CCN/XACTEMP0)**XALPHA6
+!!$ XLIMIT_FACTOR(JMOD) = ( GAMMA_X0D(0.5*XKHEN_MULTI(JMOD)+1.) &
+!!$ *GAMMA_X0D(XMUHEN_MULTI(JMOD)-0.5*XKHEN_MULTI(JMOD)) ) &
+!!$ /( XBETAHEN_MULTI(JMOD)**(0.5*XKHEN_MULTI(JMOD)) &
+!!$ *GAMMA_X0D(XMUHEN_MULTI(JMOD)) )
+!!$
+!!$
+ CALL LIMA_INIT_CCN_ACTIVATION_SPECTRUM (HTYPE_CCN(JMOD),XR_MEAN_CCN(JMOD)*2.,EXP(XLOGSIG_CCN(JMOD)),X1,X2,X3,X4,X5)
+ !
+ ! LIMA_INIT_CCN_ACTIVATION_SPECTRUM returns X1=C/Nccn (instead of XLIMIT_FACTOR), X2=k, X3=mu, X4=beta, X5=kappa
+ ! So XLIMIT_FACTOR = 1/X1
+ ! Nc = Nccn/XLIMIT_FACTOR * S^k *F() = Nccn * X1 * S^k *F()
+ !
+ XLIMIT_FACTOR(JMOD) = 1./X1
+ XKHEN_MULTI(JMOD) = X2
+ XMUHEN_MULTI(JMOD) = X3
+ XBETAHEN_MULTI(JMOD)= X4
ENDDO
!
! These parameters are correct for a nucleation spectra
@@ -263,7 +295,7 @@ IF ( NMOD_IFN .GE. 1 ) THEN
XMDIAM_IFN = (/ 0.05E-6 , 3.E-6 , 0.016E-6 , 0.016E-6 /)
XSIGMA_IFN = (/ 2.4 , 1.6 , 2.5 , 2.5 /)
XRHO_IFN = (/ 2650. , 2650. , 1000. , 1000. /)
- CASE ('MACC_JPP')
+ CASE ('CAMS_JPP')
! sea-salt, sulfate, hydrophilic (GADS data)
! 2 species, dust-metallic and hydrophobic (as BC)
! (Phillips et al. 2013 and GADS data)
@@ -274,6 +306,28 @@ IF ( NMOD_IFN .GE. 1 ) THEN
XMDIAM_IFN = (/0.8E-6, 3.0E-6, 0.025E-6, 0.2E-6/)
XSIGMA_IFN = (/2.0, 2.15, 2.0, 1.6 /)
XRHO_IFN = (/2600., 2600., 1000., 1500./)
+ CASE ('CAMS_ACC')
+! sea-salt, sulfate, hydrophilic (GADS data)
+! 2 species, dust-metallic and hydrophobic (as BC)
+! (Phillips et al. 2013 and GADS data)
+ NSPECIE = 4 ! DM1, DM2, BC, BIO+(O)
+ IF (.NOT.(ALLOCATED(XMDIAM_IFN))) ALLOCATE(XMDIAM_IFN(NSPECIE))
+ IF (.NOT.(ALLOCATED(XSIGMA_IFN))) ALLOCATE(XSIGMA_IFN(NSPECIE))
+ IF (.NOT.(ALLOCATED(XRHO_IFN))) ALLOCATE(XRHO_IFN(NSPECIE))
+ XMDIAM_IFN = (/0.8E-6, 3.0E-6, 0.04E-6, 0.8E-6 /)
+ XSIGMA_IFN = (/2.0, 2.15, 2.0, 2.2 /)
+ XRHO_IFN = (/2600., 2600., 1000., 2000. /)
+ CASE ('CAMS_AIT')
+! sea-salt, sulfate, hydrophilic (GADS data)
+! 2 species, dust-metallic and hydrophobic (as BC)
+! (Phillips et al. 2013 and GADS data)
+ NSPECIE = 4 ! DM1, DM2, BC, BIO+(O)
+ IF (.NOT.(ALLOCATED(XMDIAM_IFN))) ALLOCATE(XMDIAM_IFN(NSPECIE))
+ IF (.NOT.(ALLOCATED(XSIGMA_IFN))) ALLOCATE(XSIGMA_IFN(NSPECIE))
+ IF (.NOT.(ALLOCATED(XRHO_IFN))) ALLOCATE(XRHO_IFN(NSPECIE))
+ XMDIAM_IFN = (/0.8E-6, 3.0E-6, 0.04E-6, 0.04E-6/)
+ XSIGMA_IFN = (/2.0, 2.15, 2.0, 2.2 /)
+ XRHO_IFN = (/2600., 2600., 1000., 1800./)
CASE DEFAULT
IF (NPHILLIPS == 8) THEN
! 4 species, according to Phillips et al. 2008
@@ -309,7 +363,7 @@ IF ( NMOD_IFN .GE. 1 ) THEN
XFRAC(3,:)=1.
CASE ('O')
XFRAC(4,:)=1.
- CASE ('MACC')
+ CASE ('CAMS')
XFRAC(1,1)=0.99
XFRAC(2,1)=0.01
XFRAC(3,1)=0.
@@ -318,7 +372,7 @@ IF ( NMOD_IFN .GE. 1 ) THEN
XFRAC(2,2)=0.
XFRAC(3,2)=0.5
XFRAC(4,2)=0.5
- CASE ('MACC_JPP')
+ CASE ('CAMS_JPP')
XFRAC(1,1)=1.0
XFRAC(2,1)=0.0
XFRAC(3,1)=0.0
@@ -327,6 +381,24 @@ IF ( NMOD_IFN .GE. 1 ) THEN
XFRAC(2,2)=0.0
XFRAC(3,2)=0.5
XFRAC(4,2)=0.5
+ CASE ('CAMS_ACC')
+ XFRAC(1,1)=1.0
+ XFRAC(2,1)=0.0
+ XFRAC(3,1)=0.0
+ XFRAC(4,1)=0.0
+ XFRAC(1,2)=0.0
+ XFRAC(2,2)=0.0
+ XFRAC(3,2)=0.0
+ XFRAC(4,2)=1.0
+ CASE ('CAMS_AIT')
+ XFRAC(1,1)=1.0
+ XFRAC(2,1)=0.0
+ XFRAC(3,1)=0.0
+ XFRAC(4,1)=0.0
+ XFRAC(1,2)=0.0
+ XFRAC(2,2)=0.0
+ XFRAC(3,2)=0.0
+ XFRAC(4,2)=1.0
CASE ('MOCAGE')
XFRAC(1,1)=1.
XFRAC(2,1)=0.
diff --git a/src/MNH/lima.f90 b/src/MNH/lima.f90
index dc6ccca740d003df2a6ef53fce12aafdbaed926b..cdb5a53912a19831f810997eea157669bb22e220 100644
--- a/src/MNH/lima.f90
+++ b/src/MNH/lima.f90
@@ -17,7 +17,7 @@ INTERFACE
PDTHRAD, PTHT, PRT, PSVT, PW_NU, &
PTHS, PRS, PSVS, &
PINPRC, PINDEP, PINPRR, PINPRI, PINPRS, PINPRG, PINPRH, &
- PEVAP3D )
+ PEVAP3D, PCLDFR, PICEFR, PPRCFR )
!
USE MODD_IO, ONLY: TFILEDATA
USE MODD_NSV, only: NSV_LIMA_BEG
@@ -41,7 +41,7 @@ INTEGER, INTENT(IN) :: NCCN ! for array size declarati
INTEGER, INTENT(IN) :: NIFN ! for array size declarations
INTEGER, INTENT(IN) :: NIMM ! for array size declarations
!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PDTHRAD ! Theta at time t-dt
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDTHRAD ! dT/dt due to radiation
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! Mixing ratios at time t
REAL, DIMENSION(:,:,:,NSV_LIMA_BEG:), INTENT(IN) :: PSVT ! Concentrations at time t
@@ -60,6 +60,10 @@ REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRG ! Graupel instant precip
REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRH ! Rain instant precip
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PEVAP3D ! Rain evap profile
!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCLDFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PICEFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPRCFR ! Cloud fraction
+!
END SUBROUTINE LIMA
END INTERFACE
END MODULE MODI_LIMA
@@ -74,7 +78,7 @@ END MODULE MODI_LIMA
PDTHRAD, PTHT, PRT, PSVT, PW_NU, &
PTHS, PRS, PSVS, &
PINPRC, PINDEP, PINPRR, PINPRI, PINPRS, PINPRG, PINPRH, &
- PEVAP3D )
+ PEVAP3D, PCLDFR, PICEFR, PPRCFR )
! ######################################################################
!
!! PURPOSE
@@ -102,6 +106,7 @@ END MODULE MODI_LIMA
! B. Vie 03/03/2020: use DTHRAD instead of dT/dt in Smax diagnostic computation
! P. Wautelet 28/05/2020: bugfix: correct array start for PSVT and PSVS
! P. Wautelet 03/02/2021: budgets: add new source if LIMA splitting: CORR2
+! B.Vie 06/2021 : add subgrid condensation with LIMA
!-----------------------------------------------------------------
!
!* 0. DECLARATIONS
@@ -125,10 +130,12 @@ USE MODD_PARAM_LIMA, ONLY: LCOLD, LRAIN, LWARM, NMOD_CCN, NMOD_IFN, NMOD_IM
LHAIL, LSNOW
USE MODD_PARAM_LIMA_COLD, ONLY: XAI, XBI
USE MODD_PARAM_LIMA_WARM, ONLY: XLBC, XLBEXC, XAC, XBC, XAR, XBR
+USE MODD_TURB_n, ONLY : LSUBG_COND
use mode_budget, only: Budget_store_add, Budget_store_init, Budget_store_end
use mode_tools, only: Countjv
+USE MODI_LIMA_COMPUTE_CLOUD_FRACTIONS
USE MODI_LIMA_DROPS_TO_DROPLETS_CONV
USE MODI_LIMA_INST_PROCS
USE MODI_LIMA_NUCLEATION_PROCS
@@ -158,7 +165,7 @@ INTEGER, INTENT(IN) :: NCCN ! for array size declarati
INTEGER, INTENT(IN) :: NIFN ! for array size declarations
INTEGER, INTENT(IN) :: NIMM ! for array size declarations
!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PDTHRAD ! Theta at time t-dt
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDTHRAD ! dT/dt due to radiation
REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! Mixing ratios at time t
REAL, DIMENSION(:,:,:,NSV_LIMA_BEG:), INTENT(IN) :: PSVT ! Concentrations at time t
@@ -177,6 +184,10 @@ REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRG ! Graupel instant precip
REAL, DIMENSION(:,:), INTENT(OUT) :: PINPRH ! Rain instant precip
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PEVAP3D ! Rain evap profile
!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCLDFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PICEFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPRCFR ! Cloud fraction
+!
!* 0.2 Declarations of local variables :
!
!
@@ -225,6 +236,7 @@ REAL, DIMENSION(:), ALLOCATABLE :: &
Z_TH_EVAP, Z_RR_EVAP, & ! evaporation of rain drops (EVAP) : rv=-rr-rc, rc, Nc, rr, Nr, th
Z_RI_CNVI, Z_CI_CNVI, & ! conversion snow -> ice (CNVI) : ri, Ni, rs=-ri
Z_TH_DEPS, Z_RS_DEPS, & ! deposition of vapor on snow (DEPS) : rv=-rs, rs, th
+ Z_TH_DEPI, Z_RI_DEPI, & ! deposition of vapor on ice (DEPI) : rv=-ri, ri, th
Z_RI_CNVS, Z_CI_CNVS, & ! conversion ice -> snow (CNVS) : ri, Ni, rs=-ri
Z_RI_AGGS, Z_CI_AGGS, & ! aggregation of ice on snow (AGGS) : ri, Ni, rs=-ri
Z_TH_DEPG, Z_RG_DEPG, & ! deposition of vapor on graupel (DEPG) : rv=-rg, rg, th
@@ -275,6 +287,7 @@ REAL, DIMENSION(:,:,:), ALLOCATABLE :: &
ZTOT_TH_EVAP, ZTOT_RR_EVAP, & ! evaporation of rain drops (EVAP)
ZTOT_RI_CNVI, ZTOT_CI_CNVI, & ! conversion snow -> ice (CNVI)
ZTOT_TH_DEPS, ZTOT_RS_DEPS, & ! deposition of vapor on snow (DEPS)
+ ZTOT_TH_DEPI, ZTOT_RI_DEPI, & ! deposition of vapor on ice (DEPI)
ZTOT_RI_CNVS, ZTOT_CI_CNVS, & ! conversion ice -> snow (CNVS)
ZTOT_RI_AGGS, ZTOT_CI_AGGS, & ! aggregation of ice on snow (AGGS)
ZTOT_TH_DEPG, ZTOT_RG_DEPG, & ! deposition of vapor on graupel (DEPG)
@@ -312,7 +325,9 @@ LOGICAL, DIMENSION(SIZE(PRT,1),SIZE(PRT,2),SIZE(PRT,3)) :: LLCOMPUTE
LOGICAL, DIMENSION(:), ALLOCATABLE :: LLCOMPUTE1D
REAL :: ZTSTEP
INTEGER :: INB_ITER_MAX
-
+!
+!For subgrid clouds
+REAL, DIMENSION(:), ALLOCATABLE :: ZCF1D, ZIF1D, ZPF1D ! 1D packed cloud, ice and precip. frac.
!
! Various parameters
@@ -320,7 +335,7 @@ INTEGER :: INB_ITER_MAX
INTEGER :: KRR
INTEGER :: IIB, IIE, IIT, IJB, IJE, IJT, IKB, IKE, IKT, IKTB, IKTE
! loops and packing
-INTEGER :: II, IPACK, JI
+INTEGER :: II, IPACK, JI, JJ, JK
integer :: idx
INTEGER, DIMENSION(:), ALLOCATABLE :: I1, I2, I3
! Inverse ov PTSTEP
@@ -418,6 +433,8 @@ if ( lbu_enable ) then
allocate( ZTOT_CI_CNVI (size( ptht, 1), size( ptht, 2), size( ptht, 3) ) ); ZTOT_CI_CNVI(:,:,:) = 0.
allocate( ZTOT_TH_DEPS (size( ptht, 1), size( ptht, 2), size( ptht, 3) ) ); ZTOT_TH_DEPS(:,:,:) = 0.
allocate( ZTOT_RS_DEPS (size( ptht, 1), size( ptht, 2), size( ptht, 3) ) ); ZTOT_RS_DEPS(:,:,:) = 0.
+ allocate( ZTOT_TH_DEPI (size( ptht, 1), size( ptht, 2), size( ptht, 3) ) ); ZTOT_TH_DEPI(:,:,:) = 0.
+ allocate( ZTOT_RI_DEPI (size( ptht, 1), size( ptht, 2), size( ptht, 3) ) ); ZTOT_RI_DEPI(:,:,:) = 0.
allocate( ZTOT_RI_CNVS (size( ptht, 1), size( ptht, 2), size( ptht, 3) ) ); ZTOT_RI_CNVS(:,:,:) = 0.
allocate( ZTOT_CI_CNVS (size( ptht, 1), size( ptht, 2), size( ptht, 3) ) ); ZTOT_CI_CNVS(:,:,:) = 0.
allocate( ZTOT_RI_AGGS (size( ptht, 1), size( ptht, 2), size( ptht, 3) ) ); ZTOT_RI_AGGS(:,:,:) = 0.
@@ -540,7 +557,7 @@ IF ( LCOLD .AND. LHHONI ) ZHOMFT(:,:,:) = PSVS(:,:,:,NSV_LIMA_HOM_HAZE) * PTSTE
IF ( LCOLD .AND. LHHONI ) ZHOMFS(:,:,:) = PSVS(:,:,:,NSV_LIMA_HOM_HAZE)
!
ZINV_TSTEP = 1./PTSTEP
-ZEXN(:,:,:) = PEXNREF(:,:,:)
+ZEXN(:,:,:) = (PPABST(:,:,:)/XP00)**(XRD/XCPD)
ZT(:,:,:) = ZTHT(:,:,:) * ZEXN(:,:,:)
!
!-------------------------------------------------------------------------------
@@ -561,42 +578,42 @@ if ( lbu_enable ) then
call Budget_store_init( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_ni), 'CORR', zcis(:, :, :) * prhodj(:, :, :) )
end if
end if
-IF (LWARM .AND. LRAIN) THEN
- WHERE( ZRCT>XRTMIN(2) .AND. ZCCT>XCTMIN(2) .AND. ZRCT>XAC*ZCCT*(100.E-6)**XBC )
- ZRRT=ZRRT+ZRCT
- ZRRS=ZRRS+ZRCS
- ZCRT=ZCRT+ZCCT
- ZCRS=ZCRS+ZCCS
- ZRCT=0.
- ZCCT=0.
- ZRCS=0.
- ZCCS=0.
- END WHERE
-END IF
-!
-IF (LWARM .AND. LRAIN) THEN
- WHERE( ZRRT>XRTMIN(3) .AND. ZCRT>XCTMIN(3) .AND. ZRRT<XAR*ZCRT*(60.E-6)**XBR )
- ZRCT=ZRCT+ZRRT
- ZRCS=ZRCS+ZRRS
- ZCCT=ZCCT+ZCRT
- ZCCS=ZCCS+ZCRS
- ZRRT=0.
- ZCRT=0.
- ZRRS=0.
- ZCRS=0.
- END WHERE
-END IF
-!
-IF (LCOLD .AND. LSNOW) THEN
- WHERE( ZRIT>XRTMIN(4) .AND. ZCIT>XCTMIN(4) .AND. ZRIT>XAI*ZCIT*(250.E-6)**XBI )
- ZRST=ZRST+ZRIT
- ZRSS=ZRSS+ZRIS
- ZRIT=0.
- ZCIT=0.
- ZRIS=0.
- ZCIS=0.
- END WHERE
-END IF
+!!$IF (LWARM .AND. LRAIN) THEN
+!!$ WHERE( ZRCT>XRTMIN(2) .AND. ZCCT>XCTMIN(2) .AND. ZRCT>XAC*ZCCT*(100.E-6)**XBC )
+!!$ ZRRT=ZRRT+ZRCT
+!!$ ZRRS=ZRRS+ZRCS
+!!$ ZCRT=ZCRT+ZCCT
+!!$ ZCRS=ZCRS+ZCCS
+!!$ ZRCT=0.
+!!$ ZCCT=0.
+!!$ ZRCS=0.
+!!$ ZCCS=0.
+!!$ END WHERE
+!!$END IF
+!!$!
+!!$IF (LWARM .AND. LRAIN) THEN
+!!$ WHERE( ZRRT>XRTMIN(3) .AND. ZCRT>XCTMIN(3) .AND. ZRRT<XAR*ZCRT*(60.E-6)**XBR )
+!!$ ZRCT=ZRCT+ZRRT
+!!$ ZRCS=ZRCS+ZRRS
+!!$ ZCCT=ZCCT+ZCRT
+!!$ ZCCS=ZCCS+ZCRS
+!!$ ZRRT=0.
+!!$ ZCRT=0.
+!!$ ZRRS=0.
+!!$ ZCRS=0.
+!!$ END WHERE
+!!$END IF
+!!$!
+!!$IF (LCOLD .AND. LSNOW) THEN
+!!$ WHERE( ZRIT>XRTMIN(4) .AND. ZCIT>XCTMIN(4) .AND. ZRIT>XAI*ZCIT*(250.E-6)**XBI )
+!!$ ZRST=ZRST+ZRIT
+!!$ ZRSS=ZRSS+ZRIS
+!!$ ZRIT=0.
+!!$ ZCIT=0.
+!!$ ZRIS=0.
+!!$ ZCIS=0.
+!!$ END WHERE
+!!$END IF
!
if ( lbu_enable ) then
if ( lbudget_rc .and. lwarm .and. lrain ) call Budget_store_end( tbudgets(NBUDGET_RC), 'CORR', zrcs(:, :, :) * prhodj(:, :, :) )
@@ -748,14 +765,33 @@ IF ( LCOLD ) ZCIT(:,:,:) = ZCIS(:,:,:) * PTSTEP
!
!-------------------------------------------------------------------------------
!
+!* 2. Compute cloud, ice and precipitation fractions
+! ----------------------------------------------
+!
+IF (LSUBG_COND) THEN
+ CALL LIMA_COMPUTE_CLOUD_FRACTIONS (IIB, IIE, IJB, IJE, IKB, IKE, KKL, &
+ ZCCT, ZRCT, &
+ ZCRT, ZRRT, &
+ ZCIT, ZRIT, &
+ ZRST, ZRGT, ZRHT, &
+ PCLDFR, PICEFR, PPRCFR )
+ELSE
+ PCLDFR(:,:,:)=1.
+ PICEFR(:,:,:)=1.
+ PPRCFR(:,:,:)=1.
+END IF
+!
+!-------------------------------------------------------------------------------
+!
!* 2. Nucleation processes
! --------------------
!
-CALL LIMA_NUCLEATION_PROCS (PTSTEP, TPFILE, PRHODJ, &
- PRHODREF, ZEXN, PPABST, ZT, PDTHRAD, PW_NU, &
- ZTHT, ZRVT, ZRCT, ZRRT, ZRIT, ZRST, ZRGT, &
- ZCCT, ZCRT, ZCIT, &
- ZCCNFT, ZCCNAT, ZIFNFT, ZIFNNT, ZIMMNT, ZHOMFT )
+CALL LIMA_NUCLEATION_PROCS (PTSTEP, TPFILE, PRHODJ, &
+ PRHODREF, ZEXN, PPABST, ZT, PDTHRAD, PW_NU, &
+ ZTHT, ZRVT, ZRCT, ZRRT, ZRIT, ZRST, ZRGT, &
+ ZCCT, ZCRT, ZCIT, &
+ ZCCNFT, ZCCNAT, ZIFNFT, ZIFNNT, ZIMMNT, ZHOMFT, &
+ PCLDFR, PICEFR, PPRCFR )
!
! Saving sources before microphysics time-splitting loop
!
@@ -803,7 +839,7 @@ ZTIME(:,:,:)=0. ! Current integration time (all points may have a different inte
ZRT_SUM(:,:,:) = ZRCT(:,:,:) + ZRRT(:,:,:) + ZRIT(:,:,:) + ZRST(:,:,:) + ZRGT(:,:,:) + ZRHT(:,:,:)
WHERE (ZRT_SUM(:,:,:)<XRTMIN(2)) ZTIME(:,:,:)=PTSTEP ! no need to treat hydrometeor-free point
!
-DO WHILE(ANY(ZTIME(IIB:IIE,IJB:IJE,IKB:IKE)<PTSTEP))
+DO WHILE(ANY(ZTIME(IIB:IIE,IJB:IJE,IKTB:IKTE)<PTSTEP))
!
IF(XMRSTEP/=0.) THEN
! In this case we need to remember the mixing ratios used to compute the tendencies
@@ -824,7 +860,7 @@ DO WHILE(ANY(ZTIME(IIB:IIE,IJB:IJE,IKB:IKE)<PTSTEP))
ENDIF
!
LLCOMPUTE(:,:,:)=.FALSE.
- LLCOMPUTE(IIB:IIE,IJB:IJE,IKB:IKE) = ZTIME(IIB:IIE,IJB:IJE,IKB:IKE)<PTSTEP ! Compuation only for points for which integration time has not reached the timestep
+ LLCOMPUTE(IIB:IIE,IJB:IJE,IKTB:IKTE) = ZTIME(IIB:IIE,IJB:IJE,IKTB:IKTE)<PTSTEP ! Compuation only for points for which integration time has not reached the timestep
WHERE(LLCOMPUTE(:,:,:))
IITER(:,:,:)=IITER(:,:,:)+1
END WHERE
@@ -866,6 +902,9 @@ DO WHILE(ANY(ZTIME(IIB:IIE,IJB:IJE,IKB:IKE)<PTSTEP))
ALLOCATE(Z0RST1D(IPACK))
ALLOCATE(Z0RGT1D(IPACK))
ALLOCATE(Z0RHT1D(IPACK))
+ ALLOCATE(ZCF1D(IPACK))
+ ALLOCATE(ZIF1D(IPACK))
+ ALLOCATE(ZPF1D(IPACK))
IPACK = COUNTJV(LLCOMPUTE,I1,I2,I3)
DO II=1,IPACK
ZRHODREF1D(II) = PRHODREF(I1(II),I2(II),I3(II))
@@ -896,8 +935,16 @@ DO WHILE(ANY(ZTIME(IIB:IIE,IJB:IJE,IKB:IKE)<PTSTEP))
Z0RST1D(II) = Z0RST(I1(II),I2(II),I3(II))
Z0RGT1D(II) = Z0RGT(I1(II),I2(II),I3(II))
Z0RHT1D(II) = Z0RHT(I1(II),I2(II),I3(II))
+ ZCF1D(II) = PCLDFR(I1(II),I2(II),I3(II))
+ ZIF1D(II) = PICEFR(I1(II),I2(II),I3(II))
+ ZPF1D(II) = PPRCFR(I1(II),I2(II),I3(II))
END DO
!
+ WHERE(ZCF1D(:)<1.E-10 .AND. ZRCT1D(:)>XRTMIN(2) .AND. ZCCT1D(:)>XCTMIN(2)) ZCF1D(:)=1.
+ WHERE(ZIF1D(:)<1.E-10 .AND. ZRIT1D(:)>XRTMIN(4) .AND. ZCIT1D(:)>XCTMIN(4)) ZIF1D(:)=1.
+ WHERE(ZPF1D(:)<1.E-10 .AND. (ZRRT1D(:)>XRTMIN(3) .OR. ZRST1D(:)>XRTMIN(5) &
+ .OR. ZRGT1D(:)>XRTMIN(6) .OR. ZRHT1D(:)>XRTMIN(7) ) ) ZPF1D(:)=1.
+ !
! Allocating 1D variables
!
ALLOCATE(ZMAXTIME(IPACK)) ; ZMAXTIME(:) = 0.
@@ -951,6 +998,8 @@ DO WHILE(ANY(ZTIME(IIB:IIE,IJB:IJE,IKB:IKE)<PTSTEP))
ALLOCATE(Z_CI_CNVI(IPACK)) ; Z_CI_CNVI(:) = 0.
ALLOCATE(Z_TH_DEPS(IPACK)) ; Z_TH_DEPS(:) = 0.
ALLOCATE(Z_RS_DEPS(IPACK)) ; Z_RS_DEPS(:) = 0.
+ ALLOCATE(Z_TH_DEPI(IPACK)) ; Z_TH_DEPI(:) = 0.
+ ALLOCATE(Z_RI_DEPI(IPACK)) ; Z_RI_DEPI(:) = 0.
ALLOCATE(Z_RI_CNVS(IPACK)) ; Z_RI_CNVS(:) = 0.
ALLOCATE(Z_CI_CNVS(IPACK)) ; Z_CI_CNVS(:) = 0.
ALLOCATE(Z_RI_AGGS(IPACK)) ; Z_RI_AGGS(:) = 0.
@@ -1025,7 +1074,8 @@ DO WHILE(ANY(ZTIME(IIB:IIE,IJB:IJE,IKB:IKE)<PTSTEP))
Z_TH_IMLT, Z_RC_IMLT, Z_CC_IMLT, & ! ice melting (IMLT) : rc, Nc, ri=-rc, Ni=-Nc, th, IFNF, IFNA
ZB_TH, ZB_RV, ZB_RC, ZB_RR, ZB_RI, ZB_RG, &
ZB_CC, ZB_CR, ZB_CI, &
- ZB_IFNN )
+ ZB_IFNN, &
+ ZCF1D, ZIF1D, ZPF1D )
CALL LIMA_TENDENCIES (PTSTEP, LLCOMPUTE1D, &
ZEXNREF1D, ZRHODREF1D, ZP1D, ZTHT1D, &
@@ -1039,6 +1089,7 @@ DO WHILE(ANY(ZTIME(IIB:IIE,IJB:IJE,IKB:IKE)<PTSTEP))
Z_TH_EVAP, Z_RR_EVAP, &
Z_RI_CNVI, Z_CI_CNVI, &
Z_TH_DEPS, Z_RS_DEPS, &
+ Z_TH_DEPI, Z_RI_DEPI, &
Z_RI_CNVS, Z_CI_CNVS, &
Z_RI_AGGS, Z_CI_AGGS, &
Z_TH_DEPG, Z_RG_DEPG, &
@@ -1060,7 +1111,8 @@ DO WHILE(ANY(ZTIME(IIB:IIE,IJB:IJE,IKB:IKE)<PTSTEP))
!!! Z_RR_HMLT, Z_CR_HMLT ! hail melting (HMLT) : rr, Nr, rh=-rr, th
ZA_TH, ZA_RV, ZA_RC, ZA_CC, ZA_RR, ZA_CR, &
ZA_RI, ZA_CI, ZA_RS, ZA_RG, ZA_RH, &
- ZEVAP1D )
+ ZEVAP1D, &
+ ZCF1D, ZIF1D, ZPF1D )
!
!*** 4.2 Integration time
@@ -1323,6 +1375,8 @@ DO WHILE(ANY(ZTIME(IIB:IIE,IJB:IJE,IKB:IKE)<PTSTEP))
ZTOT_CI_CNVI(I1(II),I2(II),I3(II)) = ZTOT_CI_CNVI(I1(II),I2(II),I3(II)) + Z_CI_CNVI(II) * ZMAXTIME(II)
ZTOT_TH_DEPS(I1(II),I2(II),I3(II)) = ZTOT_TH_DEPS(I1(II),I2(II),I3(II)) + Z_TH_DEPS(II) * ZMAXTIME(II)
ZTOT_RS_DEPS(I1(II),I2(II),I3(II)) = ZTOT_RS_DEPS(I1(II),I2(II),I3(II)) + Z_RS_DEPS(II) * ZMAXTIME(II)
+ ZTOT_TH_DEPI(I1(II),I2(II),I3(II)) = ZTOT_TH_DEPI(I1(II),I2(II),I3(II)) + Z_TH_DEPI(II) * ZMAXTIME(II)
+ ZTOT_RI_DEPI(I1(II),I2(II),I3(II)) = ZTOT_RI_DEPI(I1(II),I2(II),I3(II)) + Z_RI_DEPI(II) * ZMAXTIME(II)
ZTOT_RI_CNVS(I1(II),I2(II),I3(II)) = ZTOT_RI_CNVS(I1(II),I2(II),I3(II)) + Z_RI_CNVS(II) * ZMAXTIME(II)
ZTOT_CI_CNVS(I1(II),I2(II),I3(II)) = ZTOT_CI_CNVS(I1(II),I2(II),I3(II)) + Z_CI_CNVS(II) * ZMAXTIME(II)
ZTOT_RI_AGGS(I1(II),I2(II),I3(II)) = ZTOT_RI_AGGS(I1(II),I2(II),I3(II)) + Z_RI_AGGS(II) * ZMAXTIME(II)
@@ -1432,6 +1486,9 @@ DO WHILE(ANY(ZTIME(IIB:IIE,IJB:IJE,IKB:IKE)<PTSTEP))
DEALLOCATE(Z0RST1D)
DEALLOCATE(Z0RGT1D)
DEALLOCATE(Z0RHT1D)
+ DEALLOCATE(ZCF1D)
+ DEALLOCATE(ZIF1D)
+ DEALLOCATE(ZPF1D)
!
DEALLOCATE(ZMAXTIME)
DEALLOCATE(ZTIME_THRESHOLD)
@@ -1484,6 +1541,8 @@ DO WHILE(ANY(ZTIME(IIB:IIE,IJB:IJE,IKB:IKE)<PTSTEP))
DEALLOCATE(Z_CI_CNVI)
DEALLOCATE(Z_TH_DEPS)
DEALLOCATE(Z_RS_DEPS)
+ DEALLOCATE(Z_TH_DEPI)
+ DEALLOCATE(Z_RI_DEPI)
DEALLOCATE(Z_RI_CNVS)
DEALLOCATE(Z_CI_CNVS)
DEALLOCATE(Z_RI_AGGS)
@@ -1589,6 +1648,7 @@ if ( lbu_enable ) then
call Budget_store_add( tbudgets(NBUDGET_TH), 'HONC', ztot_th_honc (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(NBUDGET_TH), 'HONR', ztot_th_honr (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(NBUDGET_TH), 'DEPS', ztot_th_deps (:, :, :) * zrhodjontstep(:, :, :) )
+ call Budget_store_add( tbudgets(NBUDGET_TH), 'DEPI', ztot_th_depi (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(NBUDGET_TH), 'DEPG', ztot_th_depg (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(NBUDGET_TH), 'IMLT', ztot_th_imlt (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(NBUDGET_TH), 'BERFI', ztot_th_berfi(:, :, :) * zrhodjontstep(:, :, :) )
@@ -1603,6 +1663,7 @@ if ( lbu_enable ) then
if ( lbudget_rv ) then
call Budget_store_add( tbudgets(NBUDGET_RV), 'REVA', -ztot_rr_evap (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(NBUDGET_RV), 'DEPS', -ztot_rs_deps (:, :, :) * zrhodjontstep(:, :, :) )
+ call Budget_store_add( tbudgets(NBUDGET_RV), 'DEPI', -ztot_ri_depi (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(NBUDGET_RV), 'DEPG', -ztot_rg_depg (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(NBUDGET_RV), 'CORR2', ztot_rv_corr2(:, :, :) * zrhodjontstep(:, :, :) )
end if
@@ -1644,6 +1705,7 @@ if ( lbu_enable ) then
call Budget_store_add( tbudgets(NBUDGET_RI), 'BERFI', -ztot_rc_berfi(:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(NBUDGET_RI), 'HMS', ztot_ri_hms (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(NBUDGET_RI), 'CFRZ', ztot_ri_cfrz (:, :, :) * zrhodjontstep(:, :, :) )
+ call Budget_store_add( tbudgets(NBUDGET_RI), 'DEPI', ztot_ri_depi (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(NBUDGET_RI), 'WETG', ztot_ri_wetg (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(NBUDGET_RI), 'DRYG', ztot_ri_dryg (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(NBUDGET_RI), 'HMG', ztot_ri_hmg (:, :, :) * zrhodjontstep(:, :, :) )
@@ -1689,7 +1751,7 @@ if ( lbu_enable ) then
call Budget_store_add( tbudgets(idx), 'SELF', ztot_cc_self (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(idx), 'AUTO', ztot_cc_auto (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(idx), 'ACCR', ztot_cc_accr (:, :, :) * zrhodjontstep(:, :, :) )
- !call Budget_store_add( tbudgets(idx), 'REVA', 0. )c
+ !call Budget_store_add( tbudgets(idx), 'REVA', 0. )
call Budget_store_add( tbudgets(idx), 'HONC', ztot_cc_honc (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(idx), 'IMLT', ztot_cc_imlt (:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(idx), 'RIM', ztot_cc_rim (:, :, :) * zrhodjontstep(:, :, :) )
@@ -1703,7 +1765,7 @@ if ( lbu_enable ) then
idx = NBUDGET_SV1 - 1 + nsv_lima_nr
call Budget_store_add( tbudgets(idx), 'AUTO', ztot_cr_auto(:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(idx), 'SCBU', ztot_cr_scbu(:, :, :) * zrhodjontstep(:, :, :) )
- !all Budget_store_add( tbudgets(idx), 'REVA', 0. )
+ !call Budget_store_add( tbudgets(idx), 'REVA', 0. )
call Budget_store_add( tbudgets(idx), 'BRKU', ztot_cr_brku(:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(idx), 'HONR', ztot_cr_honr(:, :, :) * zrhodjontstep(:, :, :) )
call Budget_store_add( tbudgets(idx), 'ACC', ztot_cr_acc (:, :, :) * zrhodjontstep(:, :, :) )
diff --git a/src/MNH/lima_adjust.f90 b/src/MNH/lima_adjust.f90
index a629f3920e97f571a2047de02e078e706f766769..acc16f6bc036ed6c605746082ed61e42cba443c0 100644
--- a/src/MNH/lima_adjust.f90
+++ b/src/MNH/lima_adjust.f90
@@ -10,10 +10,11 @@
INTERFACE
!
SUBROUTINE LIMA_ADJUST(KRR, KMI, TPFILE, HRAD, &
- HTURBDIM, OSUBG_COND, PTSTEP, &
- PRHODREF, PRHODJ, PEXNREF, PPABSM, PSIGS, PPABST, &
+ HTURBDIM, OSUBG_COND, OSIGMAS, PTSTEP, PSIGQSAT, &
+ PRHODREF, PRHODJ, PEXNREF, PPABSM, PSIGS, PMFCONV,&
+ PPABST, PZZ, PDTHRAD, PW_NU, &
PRT, PRS, PSVT, PSVS, &
- PTHS, PSRCS, PCLDFR )
+ PTHS, PSRCS, PCLDFR, PICEFR, PPRCFR, PRC_MF, PCF_MF)
!
USE MODD_IO, ONLY: TFILEDATA
USE MODD_NSV, only: NSV_LIMA_BEG
@@ -26,7 +27,11 @@ CHARACTER(len=4), INTENT(IN) :: HTURBDIM ! Dimensionality of the
CHARACTER(len=4), INTENT(IN) :: HRAD ! Radiation scheme name
LOGICAL, INTENT(IN) :: OSUBG_COND ! Switch for Subgrid
! Condensation
+LOGICAL :: OSIGMAS ! Switch for Sigma_s:
+ ! use values computed in CONDENSATION
+ ! or that from turbulence scheme
REAL, INTENT(IN) :: PTSTEP ! Time step
+REAL, INTENT(IN) :: PSIGQSAT ! coeff applied to qsat variance contribution
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Dry density of the
! reference state
@@ -34,7 +39,11 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSM ! Absolute Pressure at t-dt
REAL, DIMENSION(:,:,:), INTENT(IN) :: PSIGS ! Sigma_s at time t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PMFCONV !
REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! Absolute Pressure at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ !
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDTHRAD ! Radiative temperature tendency
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PW_NU ! updraft velocity used for
!
REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! m.r. at t
!
@@ -49,7 +58,11 @@ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PSRCS ! Second-order flux
! s'rc'/2Sigma_s2 at time t+1
! multiplied by Lambda_3
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PCLDFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCLDFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PICEFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPRCFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRC_MF! Convective Mass Flux liquid mixing ratio
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PCF_MF! Convective Mass Flux Cloud fraction
!
END SUBROUTINE LIMA_ADJUST
!
@@ -59,10 +72,11 @@ END MODULE MODI_LIMA_ADJUST
!
! ##########################################################################
SUBROUTINE LIMA_ADJUST(KRR, KMI, TPFILE, HRAD, &
- HTURBDIM, OSUBG_COND, PTSTEP, &
- PRHODREF, PRHODJ, PEXNREF, PPABSM, PSIGS, PPABST, &
+ HTURBDIM, OSUBG_COND, OSIGMAS, PTSTEP, PSIGQSAT, &
+ PRHODREF, PRHODJ, PEXNREF, PPABSM, PSIGS, PMFCONV,&
+ PPABST, PZZ, PDTHRAD, PW_NU, &
PRT, PRS, PSVT, PSVS, &
- PTHS, PSRCS, PCLDFR )
+ PTHS, PSRCS, PCLDFR, PICEFR, PPRCFR, PRC_MF, PCF_MF)
! ##########################################################################
!
!!**** *MIMA_ADJUST* - compute the fast microphysical sources
@@ -138,6 +152,7 @@ END MODULE MODI_LIMA_ADJUST
! P. Wautelet 28/05/2019: move COUNTJV function to tools.f90
! P. Wautelet 28/05/2020: bugfix: correct array start for PSVT and PSVS
! P. Wautelet 01/02/2021: bugfix: add missing CEDS source terms for SV budgets
+!! B. Vie June 2020 fix PSRCS
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
@@ -165,7 +180,9 @@ use mode_msg
use mode_tools, only: Countjv
!
USE MODI_CONDENS
+USE MODI_CONDENSATION
USE MODI_LIMA_FUNCTIONS
+USE MODI_LIMA_CCN_ACTIVATION
!
IMPLICIT NONE
!
@@ -180,7 +197,11 @@ CHARACTER(len=4), INTENT(IN) :: HTURBDIM ! Dimensionality of the
CHARACTER(len=4), INTENT(IN) :: HRAD ! Radiation scheme name
LOGICAL, INTENT(IN) :: OSUBG_COND ! Switch for Subgrid
! Condensation
+LOGICAL :: OSIGMAS ! Switch for Sigma_s:
+ ! use values computed in CONDENSATION
+ ! or that from turbulence scheme
REAL, INTENT(IN) :: PTSTEP ! Time step
+REAL, INTENT(IN) :: PSIGQSAT ! coeff applied to qsat variance contribution
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Dry density of the
! reference state
@@ -188,7 +209,11 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSM ! Absolute Pressure at t-dt
REAL, DIMENSION(:,:,:), INTENT(IN) :: PSIGS ! Sigma_s at time t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PMFCONV !
REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! Absolute Pressure at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ !
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDTHRAD ! Radiative temperature tendency
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PW_NU ! updraft velocity used for
!
REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! m.r. at t
!
@@ -203,14 +228,19 @@ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
REAL, DIMENSION(:,:,:), INTENT(OUT) :: PSRCS ! Second-order flux
! s'rc'/2Sigma_s2 at time t+1
! multiplied by Lambda_3
-REAL, DIMENSION(:,:,:), INTENT(OUT) :: PCLDFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCLDFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PICEFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPRCFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRC_MF! Convective Mass Flux liquid mixing ratio
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PCF_MF! Convective Mass Flux Cloud fraction
!
!
!* 0.2 Declarations of local variables :
!
! 3D Microphysical variables
REAL, DIMENSION(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3)) &
- :: PRVT, & ! Water vapor m.r. at t
+ :: PTHT, &
+ PRVT, & ! Water vapor m.r. at t
PRCT, & ! Cloud water m.r. at t
PRRT, & ! Rain water m.r. at t
PRIT, & ! Cloud ice m.r. at t
@@ -234,6 +264,8 @@ REAL, DIMENSION(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3)) &
REAL, DIMENSION(:,:,:,:), ALLOCATABLE &
:: PNFS, & ! Free CCN C. source
PNAS, & ! Activated CCN C. source
+ PNFT, & ! Free CCN C.
+ PNAT, & ! Activated CCN C.
PIFS, & ! Free IFN C. source
PINS, & ! Nucleated IFN C. source
PNIS ! Acti. IMM. nuclei C. source
@@ -251,7 +283,12 @@ REAL, DIMENSION(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3)) &
ZW2, &
ZLV, & ! guess of the Lv at t+1
ZLS, & ! guess of the Ls at t+1
- ZMASK
+ ZMASK,&
+ ZRV, &
+ ZRC, &
+ ZRI, &
+ ZSIGS, &
+ ZW_MF
LOGICAL, DIMENSION(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3)) &
:: GMICRO, GMICRO_RI, GMICRO_RC ! Test where to compute cond/dep proc.
INTEGER :: IMICRO
@@ -263,9 +300,12 @@ REAL, DIMENSION(:), ALLOCATABLE &
ZRVSATW, ZRVSATI, ZRVSATW_PRIME, ZRVSATI_PRIME, &
ZAW, ZAI, ZCJ, ZKA, ZDV, ZITW, ZITI, ZAWW, ZAIW, &
ZAWI, ZAII, ZFACT, ZDELTW, &
- ZDELTI, ZDELT1, ZDELT2, ZCND, ZDEP
+ ZDELTI, ZDELT1, ZDELT2, ZCND, ZDEP, ZS, ZVEC1, ZZW2
+!
+INTEGER, DIMENSION(:), ALLOCATABLE :: IVEC1
!
INTEGER :: IRESP ! Return code of FM routines
+INTEGER :: IIU,IJU,IKU! dimensions of dummy arrays
INTEGER :: IKB ! K index value of the first inner mass point
INTEGER :: IKE ! K index value of the last inner mass point
INTEGER :: IIB,IJB ! Horz index values of the first inner mass points
@@ -292,6 +332,9 @@ TYPE(TFIELDDATA) :: TZFIELD
!
ILUOUT = TLUOUT%NLU
!
+IIU = SIZE(PEXNREF,1)
+IJU = SIZE(PEXNREF,2)
+IKU = SIZE(PEXNREF,3)
IIB = 1 + JPHEXT
IIE = SIZE(PRHODJ,1) - JPHEXT
IJB = 1 + JPHEXT
@@ -317,6 +360,9 @@ ALLOCATE(ZCTMIN(ISIZE))
ZCTMIN(:) = XCTMIN(:) / ZDT
!
! Prepare 3D water mixing ratios
+!
+PTHT = PTHS*PTSTEP
+!
PRVT(:,:,:) = PRT(:,:,:,1)
PRVS(:,:,:) = PRS(:,:,:,1)
!
@@ -359,8 +405,12 @@ IF ( LSCAV .AND. LAERO_MASS ) PMAS(:,:,:) = PSVS(:,:,:,NSV_LIMA_SCAVMASS)
IF ( LWARM .AND. NMOD_CCN.GE.1 ) THEN
ALLOCATE( PNFS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),NMOD_CCN) )
ALLOCATE( PNAS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),NMOD_CCN) )
+ ALLOCATE( PNFT(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),NMOD_CCN) )
+ ALLOCATE( PNAT(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),NMOD_CCN) )
PNFS(:,:,:,:) = PSVS(:,:,:,NSV_LIMA_CCN_FREE:NSV_LIMA_CCN_FREE+NMOD_CCN-1)
PNAS(:,:,:,:) = PSVS(:,:,:,NSV_LIMA_CCN_ACTI:NSV_LIMA_CCN_ACTI+NMOD_CCN-1)
+ PNFT(:,:,:,:) = PSVT(:,:,:,NSV_LIMA_CCN_FREE:NSV_LIMA_CCN_FREE+NMOD_CCN-1)
+ PNAT(:,:,:,:) = PSVT(:,:,:,NSV_LIMA_CCN_ACTI:NSV_LIMA_CCN_ACTI+NMOD_CCN-1)
END IF
!
IF ( LCOLD .AND. NMOD_IFN .GE. 1 ) THEN
@@ -382,7 +432,7 @@ if ( nbumod == kmi .and. lbu_enable ) then
if ( lbudget_ri ) call Budget_store_init( tbudgets(NBUDGET_RI), 'CEDS', pris(:, :, :) * prhodj(:, :, :) )
if ( lbudget_sv ) then
call Budget_store_init( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_nc), 'CEDS', pccs(:, :, :) * prhodj(:, :, :) )
- call Budget_store_init( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_ni), 'CEDS', pcis(:, :, :) * prhodj(:, :, :) )
+ if (lcold) call Budget_store_init( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_ni), 'CEDS', pcis(:, :, :) * prhodj(:, :, :) )
if ( lscav .and. laero_mass ) &
call Budget_store_init( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_scavmass), 'CEDS', pmas(:, :, :) * prhodj(:, :, :) )
if ( lwarm ) then
@@ -623,12 +673,10 @@ END IF ! IMICRO
!* select cases where r_c>0 and r_i=0
!
!
-GMICRO(IIB:IIE,IJB:IJE,IKB:IKE) = &
- .NOT. GMICRO_RI(IIB:IIE,IJB:IJE,IKB:IKE) &
- .AND. ( PRCS(IIB:IIE,IJB:IJE,IKB:IKE)>ZRTMIN(2) .AND. &
- PCCS(IIB:IIE,IJB:IJE,IKB:IKE)>ZCTMIN(2) ) &
- .AND. .NOT. ( PRIS(IIB:IIE,IJB:IJE,IKB:IKE)>ZRTMIN(4) .AND. &
- PCIS(IIB:IIE,IJB:IJE,IKB:IKE)>ZCTMIN(4) )
+GMICRO(:,:,:) = .FALSE.
+GMICRO(IIB:IIE,IJB:IJE,IKB:IKE) =( PRCS(IIB:IIE,IJB:IJE,IKB:IKE)>0. .AND. &
+ PCCS(IIB:IIE,IJB:IJE,IKB:IKE)>0. ) .AND. &
+ .NOT.GMICRO_RI(IIB:IIE,IJB:IJE,IKB:IKE)
GMICRO_RC(:,:,:) = GMICRO(:,:,:)
IMICRO = COUNTJV( GMICRO(:,:,:),I1(:),I2(:),I3(:))
IF( IMICRO >= 1 ) THEN
@@ -637,6 +685,7 @@ IF( IMICRO >= 1 ) THEN
!
ALLOCATE(ZRVS(IMICRO))
ALLOCATE(ZRCS(IMICRO))
+ ALLOCATE(ZCCS(IMICRO))
ALLOCATE(ZTHS(IMICRO))
!
ALLOCATE(ZRHODREF(IMICRO))
@@ -650,6 +699,7 @@ IF( IMICRO >= 1 ) THEN
!
ZRVS(JL) = PRVS(I1(JL),I2(JL),I3(JL))
ZRCS(JL) = PRCS(I1(JL),I2(JL),I3(JL))
+ ZCCS(JL) = PCCS(I1(JL),I2(JL),I3(JL))
ZTHS(JL) = PTHS(I1(JL),I2(JL),I3(JL))
!
ZRHODREF(JL) = PRHODREF(I1(JL),I2(JL),I3(JL))
@@ -660,25 +710,47 @@ IF( IMICRO >= 1 ) THEN
ENDDO
ALLOCATE(ZZW(IMICRO))
ALLOCATE(ZLVFACT(IMICRO))
- ZLVFACT(:) = (XLVTT+(XCPV-XCL)*(ZZT(:)-XTT))/ZZCPH(:) ! L_v/C_ph
+ ALLOCATE(ZCND(IMICRO))
ALLOCATE(ZRVSATW(IMICRO))
- ALLOCATE(ZRVSATW_PRIME(IMICRO))
-!
+ ZLVFACT(:) = (XLVTT+(XCPV-XCL)*(ZZT(:)-XTT))/ZZCPH(:) ! L_v/C_ph
ZZW(:) = EXP( XALPW - XBETAW/ZZT(:) - XGAMW*ALOG(ZZT(:) ) ) ! es_w
ZRVSATW(:) = ZEPS*ZZW(:) / ( ZPRES(:)-ZZW(:) ) ! r_sw
- ZRVSATW_PRIME(:) = (( XBETAW/ZZT(:) - XGAMW ) / ZZT(:)) & ! r'_sw
- * ZRVSATW(:) * ( 1. + ZRVSATW(:)/ZEPS )
- ALLOCATE(ZAWW(IMICRO))
- ALLOCATE(ZDELT1(IMICRO))
- ALLOCATE(ZDELT2(IMICRO))
- ALLOCATE(ZCND(IMICRO))
-!
- ZAWW(:) = 1.0 + ZRVSATW_PRIME(:)*ZLVFACT(:)
- ZDELT2(:) = (ZRVSATW_PRIME(:)*ZLVFACT(:)/ZAWW(:)) * &
- ( ((-2.*XBETAW+XGAMW*ZZT(:))/(XBETAW-XGAMW*ZZT(:)) &
- + (XBETAW/ZZT(:)-XGAMW)*(1.0+2.0*ZRVSATW(:)/ZEPS))/ZZT(:) )
- ZDELT1(:) = (ZLVFACT(:)/ZAWW(:)) * ( ZRVSATW(:) - ZRVS(:)*ZDT )
- ZCND(:) = - ZDELT1(:)*( 1.0 + 0.5*ZDELT1(:)*ZDELT2(:) ) / (ZLVFACT(:)*ZDT)
+
+ IF (LADJ) THEN
+ ALLOCATE(ZRVSATW_PRIME(IMICRO))
+ ALLOCATE(ZAWW(IMICRO))
+ ALLOCATE(ZDELT1(IMICRO))
+ ALLOCATE(ZDELT2(IMICRO))
+ ZRVSATW_PRIME(:) = (( XBETAW/ZZT(:) - XGAMW ) / ZZT(:)) & ! r'_sw
+ * ZRVSATW(:) * ( 1. + ZRVSATW(:)/ZEPS )
+ ZAWW(:) = 1.0 + ZRVSATW_PRIME(:)*ZLVFACT(:)
+ ZDELT2(:) = (ZRVSATW_PRIME(:)*ZLVFACT(:)/ZAWW(:)) * &
+ ( ((-2.*XBETAW+XGAMW*ZZT(:))/(XBETAW-XGAMW*ZZT(:)) &
+ + (XBETAW/ZZT(:)-XGAMW)*(1.0+2.0*ZRVSATW(:)/ZEPS))/ZZT(:) )
+ ZDELT1(:) = (ZLVFACT(:)/ZAWW(:)) * ( ZRVSATW(:) - ZRVS(:)*ZDT )
+ ZCND(:) = - ZDELT1(:)*( 1.0 + 0.5*ZDELT1(:)*ZDELT2(:) ) / (ZLVFACT(:)*ZDT)
+ DEALLOCATE(ZRVSATW_PRIME)
+ DEALLOCATE(ZAWW)
+ DEALLOCATE(ZDELT1)
+ DEALLOCATE(ZDELT2)
+ ELSE
+ ALLOCATE(ZS(IMICRO))
+ ALLOCATE(ZZW2(IMICRO))
+ ALLOCATE(ZVEC1(IMICRO))
+ ALLOCATE(IVEC1(IMICRO))
+ ZVEC1(:) = MAX( 1.0001, MIN( FLOAT(NAHEN)-0.0001, XAHENINTP1 * ZZT(:) + XAHENINTP2 ) )
+ IVEC1(:) = INT( ZVEC1(:) )
+ ZVEC1(:) = ZVEC1(:) - FLOAT( IVEC1(:) )
+ ZS(:) = ZRVS(:)*PTSTEP / ZRVSATW(:) - 1.
+ ZZW(:) = ZCCS(:)*PTSTEP/(XLBC*ZCCS(:)/ZRCS(:))**XLBEXC
+ ZZW2(:) = XAHENG3(IVEC1(:)+1)*ZVEC1(:)-XAHENG3(IVEC1(:))*(ZVEC1(:)-1.)
+ ZCND(:) = 2.*3.14*1000.*ZZW2(:)*ZS(:)*ZZW(:)
+ DEALLOCATE(ZS)
+ DEALLOCATE(ZZW2)
+ DEALLOCATE(ZVEC1)
+ DEALLOCATE(IVEC1)
+ END IF
+
!
! Integration
!
@@ -702,6 +774,7 @@ IF( IMICRO >= 1 ) THEN
DEALLOCATE(ZRCT)
DEALLOCATE(ZRVS)
DEALLOCATE(ZRCS)
+ DEALLOCATE(ZCCS)
DEALLOCATE(ZTHS)
DEALLOCATE(ZRHODREF)
DEALLOCATE(ZZT)
@@ -711,10 +784,6 @@ IF( IMICRO >= 1 ) THEN
DEALLOCATE(ZZW)
DEALLOCATE(ZLVFACT)
DEALLOCATE(ZRVSATW)
- DEALLOCATE(ZRVSATW_PRIME)
- DEALLOCATE(ZAWW)
- DEALLOCATE(ZDELT1)
- DEALLOCATE(ZDELT2)
DEALLOCATE(ZCND)
END IF ! IMICRO
!
@@ -1054,6 +1123,8 @@ END IF ! OSUBG_COND
!
! full sublimation of the cloud ice crystals if there are few
!
+IF ( .NOT. OSUBG_COND ) THEN
+
ZMASK(:,:,:) = 0.0
ZW(:,:,:) = 0.
WHERE (PRIS(:,:,:) <= ZRTMIN(4) .OR. PCIS(:,:,:) <= ZCTMIN(4))
@@ -1135,26 +1206,28 @@ IF (LSCAV .AND. LAERO_MASS) PMAS(:,:,:) = PMAS(:,:,:) * (1-ZMASK(:,:,:))
!
! end of the iterative loop
!
+END IF ! .NOT.OSUBG_COND
+
END DO
!
-DEALLOCATE(ZRTMIN)
-DEALLOCATE(ZCTMIN)
!
!* 5.2 compute the cloud fraction PCLDFR (binary !!!!!!!)
!
IF ( .NOT. OSUBG_COND ) THEN
WHERE (PRCS(:,:,:) + PRIS(:,:,:) + PRSS(:,:,:) > 1.E-12 / ZDT)
-! WHERE (PRCS(:,:,:) + PRIS(:,:,:) > 1.E-12 / ZDT)
- ZW(:,:,:) = 1.
+ PCLDFR(:,:,:) = 1.
ELSEWHERE
- ZW(:,:,:) = 0.
+ PCLDFR(:,:,:) = 0.
ENDWHERE
- IF ( SIZE(PSRCS,3) /= 0 ) THEN
- PSRCS(:,:,:) = ZW(:,:,:)
- END IF
END IF
!
-PCLDFR(:,:,:) = ZW(:,:,:)
+IF ( SIZE(PSRCS,3) /= 0 ) THEN
+ WHERE (PRCS(:,:,:) + PRIS(:,:,:) > 1.E-12 / ZDT)
+ PSRCS(:,:,:) = 1.
+ ELSEWHERE
+ PSRCS(:,:,:) = 0.
+ ENDWHERE
+END IF
!
IF ( tpfile%lopened ) THEN
TZFIELD%CMNHNAME = 'NEB'
@@ -1236,7 +1309,7 @@ if ( nbumod == kmi .and. lbu_enable ) then
if ( lbudget_ri ) call Budget_store_end( tbudgets(NBUDGET_RI), 'CEDS', pris(:, :, :) * prhodj(:, :, :) )
if ( lbudget_sv ) then
call Budget_store_end( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_nc), 'CEDS', pccs(:, :, :) * prhodj(:, :, :) )
- call Budget_store_end( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_ni), 'CEDS', pcis(:, :, :) * prhodj(:, :, :) )
+ if (lcold) call Budget_store_end( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_ni), 'CEDS', pcis(:, :, :) * prhodj(:, :, :) )
if ( lscav .and. laero_mass ) &
call Budget_store_end( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_scavmass), 'CEDS', pmas(:, :, :) * prhodj(:, :, :) )
if ( lwarm ) then
@@ -1256,14 +1329,18 @@ if ( nbumod == kmi .and. lbu_enable ) then
end do
do jl = 1, nmod_imm
idx = NBUDGET_SV1 - 1 + nsv_lima_imm_nucl - 1 + jl
- call Budget_store_init( tbudgets(idx), 'CEDS', pnis(:, :, :, jl) * prhodj(:, :, :) )
+ call Budget_store_end( tbudgets(idx), 'CEDS', pnis(:, :, :, jl) * prhodj(:, :, :) )
end do
end if
end if
end if
!++cb++
+DEALLOCATE(ZRTMIN)
+DEALLOCATE(ZCTMIN)
IF (ALLOCATED(PNFS)) DEALLOCATE(PNFS)
IF (ALLOCATED(PNAS)) DEALLOCATE(PNAS)
+IF (ALLOCATED(PNFT)) DEALLOCATE(PNFT)
+IF (ALLOCATED(PNAT)) DEALLOCATE(PNAT)
IF (ALLOCATED(PIFS)) DEALLOCATE(PIFS)
IF (ALLOCATED(PINS)) DEALLOCATE(PINS)
IF (ALLOCATED(PNIS)) DEALLOCATE(PNIS)
diff --git a/src/MNH/lima_adjust_split.f90 b/src/MNH/lima_adjust_split.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7651684ba48a9eb6f83f1f954cad64ff8c32d887
--- /dev/null
+++ b/src/MNH/lima_adjust_split.f90
@@ -0,0 +1,830 @@
+!MNH_LIC Copyright 2013-2020 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.
+!-----------------------------------------------------------------
+! #############################
+ MODULE MODI_LIMA_ADJUST_SPLIT
+! #############################
+!
+INTERFACE
+!
+ SUBROUTINE LIMA_ADJUST_SPLIT(KRR, KMI, TPFILE, HRAD, HCONDENS, HLAMBDA3, &
+ HTURBDIM, OSUBG_COND, OSIGMAS, PTSTEP, PSIGQSAT, &
+ PRHODREF, PRHODJ, PEXNREF, PPABSM, PSIGS, PMFCONV, PPABST, PZZ, PDTHRAD, PW_NU, &
+ PRT, PRS, PSVT, PSVS, &
+ PTHS, PSRCS, PCLDFR, PICEFR, PPRCFR, PRC_MF, PCF_MF )
+!
+USE MODD_IO, ONLY: TFILEDATA
+USE MODD_NSV, only: NSV_LIMA_BEG
+!
+INTEGER, INTENT(IN) :: KRR ! Number of moist variables
+INTEGER, INTENT(IN) :: KMI ! Model index
+TYPE(TFILEDATA), INTENT(IN) :: TPFILE ! Output file
+CHARACTER(len=4), INTENT(IN) :: HTURBDIM ! Dimensionality of the
+ ! turbulence scheme
+CHARACTER(len=4), INTENT(IN) :: HRAD ! Radiation scheme name
+LOGICAL, INTENT(IN) :: OSUBG_COND ! Switch for Subgrid
+ ! Condensation
+LOGICAL :: OSIGMAS ! Switch for Sigma_s:
+ ! use values computed in CONDENSATION
+ ! or that from turbulence scheme
+CHARACTER(len=80), INTENT(IN) :: HCONDENS
+CHARACTER(len=4), INTENT(IN) :: HLAMBDA3 ! formulation for lambda3 coeff
+REAL, INTENT(IN) :: PTSTEP ! Time step
+REAL, INTENT(IN) :: PSIGQSAT ! coeff applied to qsat variance contribution
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Dry density of the
+ ! reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSM ! Absolute Pressure at t-dt
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PSIGS ! Sigma_s at time t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PMFCONV !
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! Absolute Pressure at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ !
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDTHRAD ! Radiative temperature tendency
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PW_NU ! updraft velocity used for
+!
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! m.r. at t
+!
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRS ! m.r. source
+!
+REAL, DIMENSION(:,:,:,NSV_LIMA_BEG:), INTENT(IN) :: PSVT ! Concentrations at time t
+!
+REAL, DIMENSION(:,:,:,NSV_LIMA_BEG:), INTENT(INOUT) :: PSVS ! Concentration sources
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PSRCS ! Second-order flux
+ ! s'rc'/2Sigma_s2 at time t+1
+ ! multiplied by Lambda_3
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCLDFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PICEFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPRCFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRC_MF! Convective Mass Flux liquid mixing ratio
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PCF_MF! Convective Mass Flux Cloud fraction
+!
+END SUBROUTINE LIMA_ADJUST_SPLIT
+!
+END INTERFACE
+!
+END MODULE MODI_LIMA_ADJUST_SPLIT
+!
+! ##########################################################################
+ SUBROUTINE LIMA_ADJUST_SPLIT(KRR, KMI, TPFILE, HRAD, HCONDENS, HLAMBDA3, &
+ HTURBDIM, OSUBG_COND, OSIGMAS, PTSTEP, PSIGQSAT, &
+ PRHODREF, PRHODJ, PEXNREF, PPABSM, PSIGS, PMFCONV, PPABST, PZZ, PDTHRAD, PW_NU, &
+ PRT, PRS, PSVT, PSVS, &
+ PTHS, PSRCS, PCLDFR, PICEFR, PPRCFR, PRC_MF, PCF_MF )
+! ##########################################################################
+!
+!!**** *MIMA_ADJUST* - compute the fast microphysical sources
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to compute the fast microphysical sources
+!! through an explict scheme and a saturation ajustement procedure.
+!!
+!!
+!!** METHOD
+!! ------
+!! Reisin et al., 1996 for the explicit scheme when ice is present
+!! Langlois, Tellus, 1973 for the implict adjustment for the cloud water
+!! (refer also to book 1 of the documentation).
+!!
+!! Computations are done separately for three cases :
+!! - ri>0 and rc=0
+!! - rc>0 and ri=0
+!! - ri>0 and rc>0
+!!
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST
+!! XP00 ! Reference pressure
+!! XMD,XMV ! Molar mass of dry air and molar mass of vapor
+!! XRD,XRV ! Gaz constant for dry air, gaz constant for vapor
+!! XCPD,XCPV ! Cpd (dry air), Cpv (vapor)
+!! XCL ! Cl (liquid)
+!! XTT ! Triple point temperature
+!! XLVTT ! Vaporization heat constant
+!! XALPW,XBETAW,XGAMW ! Constants for saturation vapor
+!! ! pressure function
+!! Module MODD_CONF
+!! CCONF
+!! Module MODD_BUDGET:
+!! NBUMOD
+!! CBUTYPE
+!! LBU_RTH
+!! LBU_RRV
+!! LBU_RRC
+!! Module MODD_LES : NCTR_LES,LTURB_LES,NMODNBR_LES
+!! XNA declaration (cloud fraction as global var)
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book 1 and Book2 of documentation ( routine FAST_TERMS )
+!! Langlois, Tellus, 1973
+!!
+!! AUTHOR
+!! ------
+!! E. Richard * Laboratoire d'Aerologie*
+!! J.-M. Cohard * Laboratoire d'Aerologie*
+!! J.-P. Pinty * Laboratoire d'Aerologie*
+!! S. Berthet * Laboratoire d'Aerologie*
+!! B. Vié * Laboratoire d'Aerologie*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/2021 forked from lima_adjust.f90
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+use modd_budget, only: lbu_enable, nbumod, &
+ lbudget_th, lbudget_rv, lbudget_rc, lbudget_ri, lbudget_sv, &
+ NBUDGET_TH, NBUDGET_RV, NBUDGET_RC, NBUDGET_RI, NBUDGET_SV1, &
+ tbudgets
+USE MODD_CONF
+USE MODD_CST
+USE MODD_FIELD, ONLY: TFIELDDATA, TYPEREAL
+USE MODD_IO, ONLY: TFILEDATA
+USE MODD_LUNIT_n, ONLY: TLUOUT
+USE MODD_NSV
+USE MODD_PARAMETERS
+USE MODD_PARAM_LIMA
+USE MODD_PARAM_LIMA_COLD
+USE MODD_PARAM_LIMA_MIXED
+USE MODD_PARAM_LIMA_WARM
+!
+use mode_budget, only: Budget_store_init, Budget_store_end
+USE MODE_IO_FIELD_WRITE, only: IO_Field_write
+use mode_msg
+use mode_tools, only: Countjv
+!
+USE MODI_CONDENS
+USE MODI_CONDENSATION
+USE MODI_LIMA_FUNCTIONS
+USE MODI_LIMA_CCN_ACTIVATION
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+!
+INTEGER, INTENT(IN) :: KRR ! Number of moist variables
+INTEGER, INTENT(IN) :: KMI ! Model index
+TYPE(TFILEDATA), INTENT(IN) :: TPFILE ! Output file
+CHARACTER(len=4), INTENT(IN) :: HTURBDIM ! Dimensionality of the
+ ! turbulence scheme
+CHARACTER(len=4), INTENT(IN) :: HRAD ! Radiation scheme name
+LOGICAL, INTENT(IN) :: OSUBG_COND ! Switch for Subgrid
+ ! Condensation
+LOGICAL :: OSIGMAS ! Switch for Sigma_s:
+ ! use values computed in CONDENSATION
+ ! or that from turbulence scheme
+CHARACTER(len=80), INTENT(IN) :: HCONDENS
+CHARACTER(len=4), INTENT(IN) :: HLAMBDA3 ! formulation for lambda3 coeff
+REAL, INTENT(IN) :: PTSTEP ! Time step
+REAL, INTENT(IN) :: PSIGQSAT ! coeff applied to qsat variance contribution
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Dry density of the
+ ! reference state
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSM ! Absolute Pressure at t-dt
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PSIGS ! Sigma_s at time t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PMFCONV !
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! Absolute Pressure at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ !
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PDTHRAD ! Radiative temperature tendency
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PW_NU ! updraft velocity used for
+!
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! m.r. at t
+!
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRS ! m.r. source
+!
+REAL, DIMENSION(:,:,:,NSV_LIMA_BEG:), INTENT(IN) :: PSVT ! Concentrations at time t
+!
+REAL, DIMENSION(:,:,:,NSV_LIMA_BEG:), INTENT(INOUT) :: PSVS ! Concentration sources
+!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PSRCS ! Second-order flux
+ ! s'rc'/2Sigma_s2 at time t+1
+ ! multiplied by Lambda_3
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCLDFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PICEFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPRCFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRC_MF! Convective Mass Flux liquid mixing ratio
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PCF_MF! Convective Mass Flux Cloud fraction
+!
+!
+!* 0.2 Declarations of local variables :
+!
+! 3D Microphysical variables
+REAL, DIMENSION(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3)) &
+ :: PTHT, &
+ PRVT, & ! Water vapor m.r. at t
+ PRCT, & ! Cloud water m.r. at t
+ PRRT, & ! Rain water m.r. at t
+ PRIT, & ! Cloud ice m.r. at t
+ PRST, & ! Aggregate m.r. at t
+ PRGT, & ! Graupel m.r. at t
+!
+ PRVS, & ! Water vapor m.r. source
+ PRCS, & ! Cloud water m.r. source
+ PRRS, & ! Rain water m.r. source
+ PRIS, & ! Cloud ice m.r. source
+ PRSS, & ! Aggregate m.r. source
+ PRGS, & ! Graupel m.r. source
+!
+ PCCT, & ! Cloud water conc. at t
+ PCIT, & ! Cloud ice conc. at t
+!
+ PCCS, & ! Cloud water C. source
+ PMAS, & ! Mass of scavenged AP
+ PCIS ! Ice crystal C. source
+!
+REAL, DIMENSION(:,:,:,:), ALLOCATABLE &
+ :: PNFS, & ! Free CCN C. source
+ PNAS, & ! Activated CCN C. source
+ PNFT, & ! Free CCN C.
+ PNAT, & ! Activated CCN C.
+ PIFS, & ! Free IFN C. source
+ PINS, & ! Nucleated IFN C. source
+ PNIS ! Acti. IMM. nuclei C. source
+!
+!
+!
+REAL :: ZEPS ! Mv/Md
+REAL :: ZDT ! Time increment (2*Delta t or Delta t if cold start)
+REAL, DIMENSION(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3)) &
+ :: ZEXNS,& ! guess of the Exner function at t+1
+ ZT, & ! guess of the temperature at t+1
+ ZCPH, & ! guess of the CPh for the mixing
+ ZW, &
+ ZW1, &
+ ZW2, &
+ ZLV, & ! guess of the Lv at t+1
+ ZLS, & ! guess of the Ls at t+1
+ ZMASK,&
+ ZRV, &
+ ZRC, &
+ ZRI, &
+ ZSIGS, &
+ ZW_MF
+LOGICAL, DIMENSION(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3)) &
+ :: GMICRO ! Test where to compute cond/dep proc.
+INTEGER :: IMICRO
+REAL, DIMENSION(:), ALLOCATABLE &
+ :: ZRVT, ZRCT, ZRIT, ZRVS, ZRCS, ZRIS, ZTHS, &
+ ZCCT, ZCIT, ZCCS, ZCIS, &
+ ZRHODREF, ZZT, ZPRES, ZEXNREF, ZZCPH, &
+ ZZW, ZLVFACT, ZLSFACT, &
+ ZRVSATW, ZRVSATI, ZRVSATW_PRIME, ZRVSATI_PRIME, &
+ ZAW, ZAI, ZCJ, ZKA, ZDV, ZITW, ZITI, ZAWW, ZAIW, &
+ ZAWI, ZAII, ZFACT, ZDELTW, &
+ ZDELTI, ZDELT1, ZDELT2, ZCND, ZDEP, ZS, ZVEC1, ZZW2
+!
+INTEGER, DIMENSION(:), ALLOCATABLE :: IVEC1
+!
+INTEGER :: IRESP ! Return code of FM routines
+INTEGER :: IIU,IJU,IKU! dimensions of dummy arrays
+INTEGER :: IKB ! K index value of the first inner mass point
+INTEGER :: IKE ! K index value of the last inner mass point
+INTEGER :: IIB,IJB ! Horz index values of the first inner mass points
+INTEGER :: IIE,IJE ! Horz index values of the last inner mass points
+INTEGER :: JITER,ITERMAX ! iterative loop for first order adjustment
+INTEGER :: ILUOUT ! Logical unit of output listing
+!
+INTEGER :: ISIZE
+REAL, DIMENSION(:), ALLOCATABLE :: ZRTMIN
+REAL, DIMENSION(:), ALLOCATABLE :: ZCTMIN
+!
+integer :: idx
+INTEGER , DIMENSION(SIZE(GMICRO)) :: I1,I2,I3 ! Used to replace the COUNT
+INTEGER :: JL ! and PACK intrinsics
+INTEGER :: JMOD, JMOD_IFN, JMOD_IMM
+!
+INTEGER , DIMENSION(3) :: BV
+TYPE(TFIELDDATA) :: TZFIELD
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. PRELIMINARIES
+! -------------
+!
+ILUOUT = TLUOUT%NLU
+!
+IIU = SIZE(PEXNREF,1)
+IJU = SIZE(PEXNREF,2)
+IKU = SIZE(PEXNREF,3)
+IIB = 1 + JPHEXT
+IIE = SIZE(PRHODJ,1) - JPHEXT
+IJB = 1 + JPHEXT
+IJE = SIZE(PRHODJ,2) - JPHEXT
+IKB = 1 + JPVEXT
+IKE = SIZE(PRHODJ,3) - JPVEXT
+!
+ZEPS= XMV / XMD
+!
+IF (OSUBG_COND) THEN
+ ITERMAX=2
+ELSE
+ ITERMAX=1
+END IF
+!
+ZDT = PTSTEP
+!
+ISIZE = SIZE(XRTMIN)
+ALLOCATE(ZRTMIN(ISIZE))
+ZRTMIN(:) = XRTMIN(:) / ZDT
+ISIZE = SIZE(XCTMIN)
+ALLOCATE(ZCTMIN(ISIZE))
+ZCTMIN(:) = XCTMIN(:) / ZDT
+!
+! Prepare 3D water mixing ratios
+!
+PTHT = PTHS*PTSTEP
+!
+PRVT(:,:,:) = PRT(:,:,:,1)
+PRVS(:,:,:) = PRS(:,:,:,1)
+!
+PRCT(:,:,:) = 0.
+PRCS(:,:,:) = 0.
+PRRT(:,:,:) = 0.
+PRRS(:,:,:) = 0.
+PRIT(:,:,:) = 0.
+PRIS(:,:,:) = 0.
+PRST(:,:,:) = 0.
+PRSS(:,:,:) = 0.
+PRGT(:,:,:) = 0.
+PRGS(:,:,:) = 0.
+!
+IF ( KRR .GE. 2 ) PRCT(:,:,:) = PRT(:,:,:,2)
+IF ( KRR .GE. 2 ) PRCS(:,:,:) = PRS(:,:,:,2)
+IF ( KRR .GE. 3 ) PRRT(:,:,:) = PRT(:,:,:,3)
+IF ( KRR .GE. 3 ) PRRS(:,:,:) = PRS(:,:,:,3)
+IF ( KRR .GE. 4 ) PRIT(:,:,:) = PRT(:,:,:,4)
+IF ( KRR .GE. 4 ) PRIS(:,:,:) = PRS(:,:,:,4)
+IF ( KRR .GE. 5 ) PRST(:,:,:) = PRT(:,:,:,5)
+IF ( KRR .GE. 5 ) PRSS(:,:,:) = PRS(:,:,:,5)
+IF ( KRR .GE. 6 ) PRGT(:,:,:) = PRT(:,:,:,6)
+IF ( KRR .GE. 6 ) PRGS(:,:,:) = PRS(:,:,:,6)
+!
+! Prepare 3D number concentrations
+PCCT(:,:,:) = 0.
+PCIT(:,:,:) = 0.
+PCCS(:,:,:) = 0.
+PCIS(:,:,:) = 0.
+!
+IF ( LWARM ) PCCT(:,:,:) = PSVT(:,:,:,NSV_LIMA_NC)
+IF ( LCOLD ) PCIT(:,:,:) = PSVT(:,:,:,NSV_LIMA_NI)
+!
+IF ( LWARM ) PCCS(:,:,:) = PSVS(:,:,:,NSV_LIMA_NC)
+IF ( LCOLD ) PCIS(:,:,:) = PSVS(:,:,:,NSV_LIMA_NI)
+!
+IF ( LSCAV .AND. LAERO_MASS ) PMAS(:,:,:) = PSVS(:,:,:,NSV_LIMA_SCAVMASS)
+!
+IF ( LWARM .AND. NMOD_CCN.GE.1 ) THEN
+ ALLOCATE( PNFS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),NMOD_CCN) )
+ ALLOCATE( PNAS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),NMOD_CCN) )
+ ALLOCATE( PNFT(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),NMOD_CCN) )
+ ALLOCATE( PNAT(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),NMOD_CCN) )
+ PNFS(:,:,:,:) = PSVS(:,:,:,NSV_LIMA_CCN_FREE:NSV_LIMA_CCN_FREE+NMOD_CCN-1)
+ PNAS(:,:,:,:) = PSVS(:,:,:,NSV_LIMA_CCN_ACTI:NSV_LIMA_CCN_ACTI+NMOD_CCN-1)
+ PNFT(:,:,:,:) = PSVT(:,:,:,NSV_LIMA_CCN_FREE:NSV_LIMA_CCN_FREE+NMOD_CCN-1)
+ PNAT(:,:,:,:) = PSVT(:,:,:,NSV_LIMA_CCN_ACTI:NSV_LIMA_CCN_ACTI+NMOD_CCN-1)
+END IF
+!
+IF ( LCOLD .AND. NMOD_IFN .GE. 1 ) THEN
+ ALLOCATE( PIFS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),NMOD_IFN) )
+ ALLOCATE( PINS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),NMOD_IFN) )
+ PIFS(:,:,:,:) = PSVS(:,:,:,NSV_LIMA_IFN_FREE:NSV_LIMA_IFN_FREE+NMOD_IFN-1)
+ PINS(:,:,:,:) = PSVS(:,:,:,NSV_LIMA_IFN_NUCL:NSV_LIMA_IFN_NUCL+NMOD_IFN-1)
+END IF
+!
+IF ( NMOD_IMM .GE. 1 ) THEN
+ ALLOCATE( PNIS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),NMOD_IMM) )
+ PNIS(:,:,:,:) = PSVS(:,:,:,NSV_LIMA_IMM_NUCL:NSV_LIMA_IMM_NUCL+NMOD_IMM-1)
+END IF
+!
+!
+if ( nbumod == kmi .and. lbu_enable ) then
+ if ( lbudget_th ) call Budget_store_init( tbudgets(NBUDGET_TH), 'CEDS', pths(:, :, :) * prhodj(:, :, :) )
+ if ( lbudget_rv ) call Budget_store_init( tbudgets(NBUDGET_RV), 'CEDS', prvs(:, :, :) * prhodj(:, :, :) )
+ if ( lbudget_rc ) call Budget_store_init( tbudgets(NBUDGET_RC), 'CEDS', prcs(:, :, :) * prhodj(:, :, :) )
+ if ( lbudget_ri ) call Budget_store_init( tbudgets(NBUDGET_RI), 'CEDS', pris(:, :, :) * prhodj(:, :, :) )
+ if ( lbudget_sv ) then
+ call Budget_store_init( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_nc), 'CEDS', pccs(:, :, :) * prhodj(:, :, :) )
+ do jl = nsv_lima_ccn_free,nsv_lima_ccn_free + nmod_ccn - 1
+ idx = NBUDGET_SV1 - 1 + jl
+ call Budget_store_init( tbudgets(idx), 'CEDS', pnfs(:, :, :, jl) * prhodj(:, :, :) )
+ end do
+ if ( lcold ) then
+ call Budget_store_init( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_ni), 'CEDS', pcis(:, :, :) * prhodj(:, :, :) )
+ do jl = 1, nsv_lima_ifn_free, nsv_lima_ifn_free + nmod_ifn - 1
+ idx = NBUDGET_SV1 - 1 + jl
+ call Budget_store_init( tbudgets(idx), 'CEDS', pifs(:, :, :, jl) * prhodj(:, :, :) )
+ end do
+ end if
+ end if
+end if
+!
+!-------------------------------------------------------------------------------
+!
+!
+!* 2. COMPUTE QUANTITIES WITH THE GUESS OF THE FUTURE INSTANT
+! -------------------------------------------------------
+!
+!* 2.1 remove negative non-precipitating negative water
+! ------------------------------------------------
+!
+IF (ANY(PRVS(:,:,:)+PRCS(:,:,:)+PRIS(:,:,:) < 0.) .AND. NVERB>5) THEN
+ WRITE(ILUOUT,*) 'LIMA_ADJUST: negative values of total water (reset to zero)'
+ WRITE(ILUOUT,*) ' location of minimum PRVS+PRCS+PRIS:',MINLOC(PRVS+PRCS+PRIS)
+ WRITE(ILUOUT,*) ' value of minimum PRVS+PRCS+PRIS:',MINVAL(PRVS+PRCS+PRIS)
+END IF
+!
+WHERE ( PRVS(:,:,:)+PRCS(:,:,:)+PRIS(:,:,:) < 0.)
+ PRVS(:,:,:) = - PRCS(:,:,:) - PRIS(:,:,:)
+END WHERE
+!
+!* 2.2 estimate the Exner function at t+1
+!
+ZEXNS(:,:,:) = ( (2. * PPABST(:,:,:) - PPABSM(:,:,:)) / XP00 ) ** (XRD/XCPD)
+!
+! beginning of the iterative loop
+!
+DO JITER =1,ITERMAX
+!
+!* 2.3 compute the intermediate temperature at t+1, T*
+!
+ ZT(:,:,:) = ( PTHS(:,:,:) * ZDT ) * ZEXNS(:,:,:)
+!
+!* 2.4 compute the specific heat for moist air (Cph) at t+1
+!
+ ZCPH(:,:,:) = XCPD + XCPV *ZDT* PRVS(:,:,:) &
+ + XCL *ZDT* ( PRCS(:,:,:) + PRRS(:,:,:) ) &
+ + XCI *ZDT* ( PRIS(:,:,:) + PRSS(:,:,:) + PRGS(:,:,:) )
+!
+!* 2.5 compute the latent heat of vaporization Lv(T*) at t+1
+! and of sublimation Ls(T*) at t+1
+!
+ ZLV(:,:,:) = XLVTT + ( XCPV - XCL ) * ( ZT(:,:,:) -XTT )
+ ZLS(:,:,:) = XLSTT + ( XCPV - XCI ) * ( ZT(:,:,:) -XTT )
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. FIRST ORDER SUBGRID CONDENSATION SCHEME
+! ---------------------------------------
+!
+ IF ( OSUBG_COND ) THEN
+ !
+ ZRV=PRVS*PTSTEP
+ ZRC=PRCS*PTSTEP
+ ZRI=0.
+ ZSIGS=PSIGS
+ CALL CONDENSATION(IIU, IJU, IKU, IIB, IIE, IJB, IJE, IKB, IKE, 1, 'S', &
+ HCONDENS, HLAMBDA3, &
+ PPABST, PZZ, PRHODREF, ZT, ZRV, ZRC, ZRI, PRSS*PTSTEP, PRGS*PTSTEP, &
+ ZSIGS, PMFCONV, PCLDFR, PSRCS, .FALSE., OSIGMAS, &
+ PSIGQSAT, PLV=ZLV, PLS=ZLS, PCPH=ZCPH )
+ PCLDFR(:,:,:) = MIN(PCLDFR(:,:,:) + PCF_MF(:,:,:) , 1.)
+ ZRV(:,:,:) = ZRV(:,:,:) - MAX(MIN(PRC_MF(:,:,:), ZRV(:,:,:)),0.)
+ ZRC(:,:,:) = ZRC(:,:,:) + MAX(MIN(PRC_MF(:,:,:), ZRV(:,:,:)),0.)
+ ZW_MF=0.
+ CALL LIMA_CCN_ACTIVATION (PTSTEP, TPFILE, &
+ PRHODREF, PEXNREF, PPABST, ZT, PDTHRAD, PW_NU+ZW_MF, &
+ PTHT, ZRV, ZRC, PCCT, PRRT, PNFT, PNAT, &
+ PCLDFR )
+!
+ ELSE
+!
+!-------------------------------------------------------------------------------
+!
+!
+!
+!* FULLY IMPLICIT CONDENSATION SCHEME
+! ---------------------------------
+!
+!* select cases where r_c>0
+!
+!
+ GMICRO(:,:,:) = .FALSE.
+ GMICRO(IIB:IIE,IJB:IJE,IKB:IKE) =( PRCS(IIB:IIE,IJB:IJE,IKB:IKE)>0. .AND. &
+ PCCS(IIB:IIE,IJB:IJE,IKB:IKE)>0. )
+ IMICRO = COUNTJV( GMICRO(:,:,:),I1(:),I2(:),I3(:))
+ IF( IMICRO >= 1 ) THEN
+ ALLOCATE(ZRVT(IMICRO))
+ ALLOCATE(ZRCT(IMICRO))
+!
+ ALLOCATE(ZRVS(IMICRO))
+ ALLOCATE(ZRCS(IMICRO))
+ ALLOCATE(ZCCS(IMICRO))
+ ALLOCATE(ZTHS(IMICRO))
+!
+ ALLOCATE(ZRHODREF(IMICRO))
+ ALLOCATE(ZZT(IMICRO))
+ ALLOCATE(ZPRES(IMICRO))
+ ALLOCATE(ZEXNREF(IMICRO))
+ ALLOCATE(ZZCPH(IMICRO))
+ DO JL=1,IMICRO
+ ZRVT(JL) = PRVT(I1(JL),I2(JL),I3(JL))
+ ZRCT(JL) = PRCT(I1(JL),I2(JL),I3(JL))
+ !
+ ZRVS(JL) = PRVS(I1(JL),I2(JL),I3(JL))
+ ZRCS(JL) = PRCS(I1(JL),I2(JL),I3(JL))
+ ZCCS(JL) = PCCS(I1(JL),I2(JL),I3(JL))
+ ZTHS(JL) = PTHS(I1(JL),I2(JL),I3(JL))
+ !
+ ZRHODREF(JL) = PRHODREF(I1(JL),I2(JL),I3(JL))
+ ZZT(JL) = ZT(I1(JL),I2(JL),I3(JL))
+ ZPRES(JL) = 2.0*PPABST(I1(JL),I2(JL),I3(JL))-PPABSM(I1(JL),I2(JL),I3(JL))
+ ZEXNREF(JL) = PEXNREF(I1(JL),I2(JL),I3(JL))
+ ZZCPH(JL) = ZCPH(I1(JL),I2(JL),I3(JL))
+ ENDDO
+ ALLOCATE(ZZW(IMICRO))
+ ALLOCATE(ZLVFACT(IMICRO))
+ ALLOCATE(ZRVSATW(IMICRO))
+ ALLOCATE(ZCND(IMICRO))
+ ZLVFACT(:) = (XLVTT+(XCPV-XCL)*(ZZT(:)-XTT))/ZZCPH(:) ! L_v/C_ph
+ ZZW(:) = EXP( XALPW - XBETAW/ZZT(:) - XGAMW*ALOG(ZZT(:) ) ) ! es_w
+ ZRVSATW(:) = ZEPS*ZZW(:) / ( ZPRES(:)-ZZW(:) ) ! r_sw
+
+ IF (LADJ) THEN
+ ALLOCATE(ZRVSATW_PRIME(IMICRO))
+ ALLOCATE(ZAWW(IMICRO))
+ ALLOCATE(ZDELT1(IMICRO))
+ ALLOCATE(ZDELT2(IMICRO))
+ ZRVSATW_PRIME(:) = (( XBETAW/ZZT(:) - XGAMW ) / ZZT(:)) & ! r'_sw
+ * ZRVSATW(:) * ( 1. + ZRVSATW(:)/ZEPS )
+ ZAWW(:) = 1.0 + ZRVSATW_PRIME(:)*ZLVFACT(:)
+ ZDELT2(:) = (ZRVSATW_PRIME(:)*ZLVFACT(:)/ZAWW(:)) * &
+ ( ((-2.*XBETAW+XGAMW*ZZT(:))/(XBETAW-XGAMW*ZZT(:)) &
+ + (XBETAW/ZZT(:)-XGAMW)*(1.0+2.0*ZRVSATW(:)/ZEPS))/ZZT(:) )
+ ZDELT1(:) = (ZLVFACT(:)/ZAWW(:)) * ( ZRVSATW(:) - ZRVS(:)*ZDT )
+ ZCND(:) = - ZDELT1(:)*( 1.0 + 0.5*ZDELT1(:)*ZDELT2(:) ) / (ZLVFACT(:)*ZDT)
+ DEALLOCATE(ZRVSATW_PRIME)
+ DEALLOCATE(ZAWW)
+ DEALLOCATE(ZDELT1)
+ DEALLOCATE(ZDELT2)
+ ELSE
+ ALLOCATE(ZS(IMICRO))
+ ALLOCATE(ZZW2(IMICRO))
+ ALLOCATE(ZVEC1(IMICRO))
+ ALLOCATE(IVEC1(IMICRO))
+ ZVEC1(:) = MAX( 1.0001, MIN( FLOAT(NAHEN)-0.0001, XAHENINTP1 * ZZT(:) + XAHENINTP2 ) )
+ IVEC1(:) = INT( ZVEC1(:) )
+ ZVEC1(:) = ZVEC1(:) - FLOAT( IVEC1(:) )
+ ZS(:) = ZRVS(:)*PTSTEP / ZRVSATW(:) - 1.
+ ZZW(:) = ZCCS(:)*PTSTEP/(XLBC*ZCCS(:)/ZRCS(:))**XLBEXC
+ ZZW2(:) = XAHENG3(IVEC1(:)+1)*ZVEC1(:)-XAHENG3(IVEC1(:))*(ZVEC1(:)-1.)
+ ZCND(:) = 2.*3.14*1000.*ZZW2(:)*ZS(:)*ZZW(:)
+ DEALLOCATE(ZS)
+ DEALLOCATE(ZZW2)
+ DEALLOCATE(ZVEC1)
+ DEALLOCATE(IVEC1)
+ END IF
+!
+!
+! Integration
+!
+ WHERE( ZCND(:) < 0.0 )
+ ZCND(:) = MAX ( ZCND(:), -ZRCS(:) )
+ ELSEWHERE
+ ZCND(:) = MIN ( ZCND(:), ZRVS(:) )
+ END WHERE
+ ZRVS(:) = ZRVS(:) - ZCND(:)
+ ZRCS(:) = ZRCS(:) + ZCND(:)
+ ZTHS(:) = ZTHS(:) + ZCND(:) * ZLVFACT(:) / ZEXNREF(:)
+!
+ ZW(:,:,:) = PRVS(:,:,:)
+ PRVS(:,:,:) = UNPACK( ZRVS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
+ ZW(:,:,:) = PRCS(:,:,:)
+ PRCS(:,:,:) = UNPACK( ZRCS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
+ ZW(:,:,:) = PTHS(:,:,:)
+ PTHS(:,:,:) = UNPACK( ZTHS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
+!
+ DEALLOCATE(ZRVT)
+ DEALLOCATE(ZRCT)
+ DEALLOCATE(ZRVS)
+ DEALLOCATE(ZRCS)
+ DEALLOCATE(ZTHS)
+ DEALLOCATE(ZRHODREF)
+ DEALLOCATE(ZZT)
+ DEALLOCATE(ZPRES)
+ DEALLOCATE(ZEXNREF)
+ DEALLOCATE(ZZCPH)
+ DEALLOCATE(ZZW)
+ DEALLOCATE(ZLVFACT)
+ DEALLOCATE(ZRVSATW)
+ DEALLOCATE(ZCND)
+ END IF ! IMICRO
+!
+ END IF ! end of adjustment procedure (test on OSUBG_COND)
+!
+! Remove cloud droplets if there are few
+
+ ZMASK(:,:,:) = 0.0
+ ZW(:,:,:) = 0.
+ WHERE (PRCS(:,:,:) <= ZRTMIN(2) .OR. PCCS(:,:,:) <= ZCTMIN(2))
+ PRVS(:,:,:) = PRVS(:,:,:) + PRCS(:,:,:)
+ PTHS(:,:,:) = PTHS(:,:,:) - PRCS(:,:,:)*ZLV(:,:,:)/(ZCPH(:,:,:)*ZEXNS(:,:,:))
+ PRCS(:,:,:) = 0.0
+ ZW(:,:,:) = MAX(PCCS(:,:,:),0.)
+ PCCS(:,:,:) = 0.0
+ END WHERE
+!
+ ZW1(:,:,:) = 0.
+ IF (LWARM .AND. NMOD_CCN.GE.1) ZW1(:,:,:) = SUM(PNAS,DIM=4)
+ ZW (:,:,:) = MIN( ZW(:,:,:), ZW1(:,:,:) )
+ ZW2(:,:,:) = 0.
+ WHERE ( ZW(:,:,:) > 0. )
+ ZMASK(:,:,:) = 1.0
+ ZW2(:,:,:) = ZW(:,:,:) / ZW1(:,:,:)
+ ENDWHERE
+!
+ IF (LWARM .AND. NMOD_CCN.GE.1) THEN
+ DO JMOD = 1, NMOD_CCN
+ PNFS(:,:,:,JMOD) = PNFS(:,:,:,JMOD) + &
+ ZMASK(:,:,:) * PNAS(:,:,:,JMOD) * ZW2(:,:,:)
+ PNAS(:,:,:,JMOD) = PNAS(:,:,:,JMOD) - &
+ ZMASK(:,:,:) * PNAS(:,:,:,JMOD) * ZW2(:,:,:)
+ PNAS(:,:,:,JMOD) = MAX( 0.0 , PNAS(:,:,:,JMOD) )
+ ENDDO
+ END IF
+!
+ IF (LSCAV .AND. LAERO_MASS) PMAS(:,:,:) = PMAS(:,:,:) * (1-ZMASK(:,:,:))
+!
+!
+END DO ! end of the iterative loop
+!
+!
+!* 5.2 compute the cloud fraction PCLDFR (binary !!!!!!!)
+!
+IF ( .NOT. OSUBG_COND ) THEN
+ WHERE (PRCS(:,:,:) + PRIS(:,:,:) + PRSS(:,:,:) > 1.E-12 / ZDT)
+ PCLDFR(:,:,:) = 1.
+ ELSEWHERE
+ PCLDFR(:,:,:) = 0.
+ ENDWHERE
+END IF
+!
+IF ( SIZE(PSRCS,3) /= 0 ) THEN
+ WHERE (PRCS(:,:,:) + PRIS(:,:,:) > 1.E-12 / ZDT)
+ PSRCS(:,:,:) = 1.
+ ELSEWHERE
+ PSRCS(:,:,:) = 0.
+ ENDWHERE
+END IF
+!
+IF ( OSUBG_COND ) THEN
+ !
+ ! Mixing ratio change (cloud liquid water)
+ !
+ ZW1(:,:,:) = (ZRC(:,:,:) - PRCS(:,:,:)*PTSTEP) / PTSTEP
+ WHERE( ZW1(:,:,:) < 0.0 )
+ ZW1(:,:,:) = MAX ( ZW1(:,:,:), -PRCS(:,:,:) )
+ ELSEWHERE
+ ZW1(:,:,:) = MIN ( ZW1(:,:,:), PRVS(:,:,:) )
+ END WHERE
+
+ WHERE (PCCT(:,:,:) < PCLDFR(:,:,:)*XCTMIN(2) .OR. ZRC(:,:,:)<PCLDFR(:,:,:)*XRTMIN(2))
+ ZW1=-PRCS
+ PCCS=0.
+ PCLDFR=0.
+ END WHERE
+
+ PRVS(:,:,:) = PRVS(:,:,:) - ZW1(:,:,:)
+ PRCS(:,:,:) = PRCS(:,:,:) + ZW1(:,:,:)
+ PCCS(:,:,:) = PCCT(:,:,:) / PTSTEP
+ PNFS(:,:,:,:) = PNFT(:,:,:,:) / PTSTEP
+ PNAS(:,:,:,:) = PNAT(:,:,:,:) / PTSTEP
+ PTHS(:,:,:) = PTHS(:,:,:) + &
+ ZW1(:,:,:) * ZLV(:,:,:) / (ZCPH(:,:,:) * PEXNREF(:,:,:))
+ !
+ ! Cloud fraction
+ !
+ ! PCLDFR(:,:,:) = MAX(PCLDFR(:,:,:),PICEFR(:,:,:))
+ !
+END IF ! fin test OSUBG_COND
+
+IF ( tpfile%lopened ) THEN
+ TZFIELD%CMNHNAME = 'NEB'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'NEB'
+ TZFIELD%CUNITS = '1'
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_NEB'
+ TZFIELD%NGRID = 1
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,PCLDFR)
+END IF
+!
+!
+!* 6. SAVE CHANGES IN PRS AND PSVS
+! ----------------------------
+!
+!
+! Prepare 3D water mixing ratios
+PRS(:,:,:,1) = PRVS(:,:,:)
+IF ( KRR .GE. 2 ) PRS(:,:,:,2) = PRCS(:,:,:)
+IF ( KRR .GE. 3 ) PRS(:,:,:,3) = PRRS(:,:,:)
+IF ( KRR .GE. 4 ) PRS(:,:,:,4) = PRIS(:,:,:)
+IF ( KRR .GE. 5 ) PRS(:,:,:,5) = PRSS(:,:,:)
+IF ( KRR .GE. 6 ) PRS(:,:,:,6) = PRGS(:,:,:)
+!
+! Prepare 3D number concentrations
+!
+IF ( LWARM ) PSVS(:,:,:,NSV_LIMA_NC) = PCCS(:,:,:)
+IF ( LCOLD ) PSVS(:,:,:,NSV_LIMA_NI) = PCIS(:,:,:)
+!
+IF ( LSCAV .AND. LAERO_MASS ) PSVS(:,:,:,NSV_LIMA_SCAVMASS) = PMAS(:,:,:)
+!
+IF ( LWARM .AND. NMOD_CCN .GE. 1 ) THEN
+ PSVS(:,:,:,NSV_LIMA_CCN_FREE:NSV_LIMA_CCN_FREE+NMOD_CCN-1) = PNFS(:,:,:,:)
+ PSVS(:,:,:,NSV_LIMA_CCN_ACTI:NSV_LIMA_CCN_ACTI+NMOD_CCN-1) = PNAS(:,:,:,:)
+END IF
+!
+IF ( LCOLD .AND. NMOD_IFN .GE. 1 ) THEN
+ PSVS(:,:,:,NSV_LIMA_IFN_FREE:NSV_LIMA_IFN_FREE+NMOD_IFN-1) = PIFS(:,:,:,:)
+ PSVS(:,:,:,NSV_LIMA_IFN_NUCL:NSV_LIMA_IFN_NUCL+NMOD_IFN-1) = PINS(:,:,:,:)
+END IF
+!
+IF ( LCOLD .AND. NMOD_IMM .GE. 1 ) THEN
+ PSVS(:,:,:,NSV_LIMA_IMM_NUCL:NSV_LIMA_IMM_NUCL+NMOD_IMM-1) = PNIS(:,:,:,:)
+END IF
+!
+! write SSI in LFI
+!
+IF ( tpfile%lopened ) THEN
+ ZT(:,:,:) = ( PTHS(:,:,:) * ZDT ) * ZEXNS(:,:,:)
+ ZW(:,:,:) = EXP( XALPI - XBETAI/ZT(:,:,:) - XGAMI*ALOG(ZT(:,:,:) ) )
+ ZW1(:,:,:)= 2.0*PPABST(:,:,:)-PPABSM(:,:,:)
+ ZW(:,:,:) = PRVT(:,:,:)*( ZW1(:,:,:)-ZW(:,:,:) ) / ( (XMV/XMD) * ZW(:,:,:) ) - 1.0
+
+ TZFIELD%CMNHNAME = 'SSI'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'SSI'
+ TZFIELD%CUNITS = ''
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_SSI'
+ TZFIELD%NGRID = 1
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,ZW)
+END IF
+!
+!
+!* 7. STORE THE BUDGET TERMS
+! ----------------------
+!
+if ( nbumod == kmi .and. lbu_enable ) then
+ if ( lbudget_th ) call Budget_store_end( tbudgets(NBUDGET_TH), 'CEDS', pths(:, :, :) * prhodj(:, :, :) )
+ if ( lbudget_rv ) call Budget_store_end( tbudgets(NBUDGET_RV), 'CEDS', prvs(:, :, :) * prhodj(:, :, :) )
+ if ( lbudget_rc ) call Budget_store_end( tbudgets(NBUDGET_RC), 'CEDS', prcs(:, :, :) * prhodj(:, :, :) )
+ if ( lbudget_ri ) call Budget_store_end( tbudgets(NBUDGET_RI), 'CEDS', pris(:, :, :) * prhodj(:, :, :) )
+ if ( lbudget_sv ) then
+ call Budget_store_end( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_nc), 'CEDS', pccs(:, :, :) * prhodj(:, :, :) )
+ do jl = nsv_lima_ccn_free,nsv_lima_ccn_free + nmod_ccn - 1
+ idx = NBUDGET_SV1 - 1 + jl
+ call Budget_store_end( tbudgets(idx), 'CEDS', pnfs(:, :, :, jl) * prhodj(:, :, :) )
+ end do
+ if ( lcold ) then
+ call Budget_store_end( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_ni), 'CEDS', pcis(:, :, :) * prhodj(:, :, :) )
+ do jl = 1, nsv_lima_ifn_free, nsv_lima_ifn_free + nmod_ifn - 1
+ idx = NBUDGET_SV1 - 1 + jl
+ call Budget_store_end( tbudgets(idx), 'CEDS', pifs(:, :, :, jl) * prhodj(:, :, :) )
+ end do
+ end if
+ end if
+end if
+!++cb++
+DEALLOCATE(ZRTMIN)
+DEALLOCATE(ZCTMIN)
+IF (ALLOCATED(PNFS)) DEALLOCATE(PNFS)
+IF (ALLOCATED(PNAS)) DEALLOCATE(PNAS)
+IF (ALLOCATED(PNFT)) DEALLOCATE(PNFT)
+IF (ALLOCATED(PNAT)) DEALLOCATE(PNAT)
+IF (ALLOCATED(PIFS)) DEALLOCATE(PIFS)
+IF (ALLOCATED(PINS)) DEALLOCATE(PINS)
+IF (ALLOCATED(PNIS)) DEALLOCATE(PNIS)
+!--cb--
+!
+!------------------------------------------------------------------------------
+!
+END SUBROUTINE LIMA_ADJUST_SPLIT
diff --git a/src/MNH/lima_ccn_activation.f90 b/src/MNH/lima_ccn_activation.f90
index 3854c543337cc0c2a3d9b118b4fd84b49d2a5eb7..0279cda046afd63517493bf3cfdf3e3a07bd80b6 100644
--- a/src/MNH/lima_ccn_activation.f90
+++ b/src/MNH/lima_ccn_activation.f90
@@ -10,7 +10,8 @@
INTERFACE
SUBROUTINE LIMA_CCN_ACTIVATION (PTSTEP, TPFILE, &
PRHODREF, PEXNREF, PPABST, PT, PDTHRAD, PW_NU, &
- PTHT, PRVT, PRCT, PCCT, PRRT, PNFT, PNAT )
+ PTHT, PRVT, PRCT, PCCT, PRRT, PNFT, PNAT, &
+ PCLDFR )
USE MODD_IO, ONLY: TFILEDATA
!
REAL, INTENT(IN) :: PTSTEP ! Double Time step
@@ -34,13 +35,16 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Cloud water m.r. at t
REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNFT ! CCN C. available at t
REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNAT ! CCN C. activated at t
!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCLDFR ! Precipitation fraction
+!
END SUBROUTINE LIMA_CCN_ACTIVATION
END INTERFACE
END MODULE MODI_LIMA_CCN_ACTIVATION
! #############################################################################
SUBROUTINE LIMA_CCN_ACTIVATION (PTSTEP, TPFILE, &
PRHODREF, PEXNREF, PPABST, PT, PDTHRAD, PW_NU, &
- PTHT, PRVT, PRCT, PCCT, PRRT, PNFT, PNAT )
+ PTHT, PRVT, PRCT, PCCT, PRRT, PNFT, PNAT, &
+ PCLDFR )
! #############################################################################
!
!!
@@ -95,14 +99,17 @@ END MODULE MODI_LIMA_CCN_ACTIVATION
!* 0. DECLARATIONS
! ------------
!
-USE MODD_CST, ONLY: XALPW, XBETAW, XCL, XCPD, XCPV, XGAMW, XLVTT, XMD, XMV, XRV, XTT
+USE MODD_CST, ONLY: XALPW, XBETAW, XCL, XCPD, XCPV, XGAMW, XLVTT, XMD, XMV, XRV, XTT, &
+ XMNH_EPSILON
use modd_field, only: TFIELDDATA, TYPEREAL
USE MODD_IO, ONLY: TFILEDATA
USE MODD_LUNIT_n, ONLY: TLUOUT
USE MODD_PARAMETERS, ONLY: JPHEXT, JPVEXT
-USE MODD_PARAM_LIMA, ONLY: LACTIT, NMOD_CCN, XKHEN_MULTI, XCTMIN, XLIMIT_FACTOR
+USE MODD_PARAM_LIMA, ONLY: LACTIT, NMOD_CCN, XKHEN_MULTI, XRTMIN, XCTMIN, XLIMIT_FACTOR
USE MODD_PARAM_LIMA_WARM, ONLY: XWMIN, NAHEN, NHYP, XAHENINTP1, XAHENINTP2, XCSTDCRIT, XHYPF12, &
- XHYPINTP1, XHYPINTP2, XTMIN, XHYPF32, XPSI3, XAHENG, XPSI1
+ XHYPINTP1, XHYPINTP2, XTMIN, XHYPF32, XPSI3, XAHENG, XAHENG2, XPSI1, &
+ XLBC, XLBEXC
+USE MODD_TURB_n, ONLY : LSUBG_COND
USE MODE_IO_FIELD_WRITE, only: IO_Field_write
use mode_tools, only: Countjv
@@ -134,6 +141,7 @@ REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Cloud water m.r. at t
REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNFT ! CCN C. available at t
REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNAT ! CCN C. activated at t
!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCLDFR ! Precipitation fraction
!
!* 0.1 Declarations of local variables :
!
@@ -144,8 +152,10 @@ INTEGER , DIMENSION(SIZE(GNUCT)) :: I1,I2,I3 ! Used to replace the COUNT
INTEGER :: JL ! and PACK intrinsics
!
! Packed micophysical variables
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZNFT ! available nucleus conc. source
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZNAT ! activated nucleus conc. source
+REAL, DIMENSION(:) , ALLOCATABLE :: ZRCT ! cloud mr
+REAL, DIMENSION(:) , ALLOCATABLE :: ZCCT ! cloud conc.
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZNFT ! available nucleus conc.
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZNAT ! activated nucleus conc.
!
! Other packed variables
REAL, DIMENSION(:) , ALLOCATABLE :: ZRHODREF ! RHO Dry REFerence
@@ -197,7 +207,6 @@ ZEPS= XMV / XMD
ZRVSAT(:,:,:) = ZEPS / (PPABST(:,:,:)*EXP(-XALPW+XBETAW/PT(:,:,:)+XGAMW*ALOG(PT(:,:,:))) - 1.0)
ZTDT(:,:,:) = 0.
IF (LACTIT .AND. SIZE(PDTHRAD).GT.0) ZTDT(:,:,:) = PDTHRAD(:,:,:) * PEXNREF(:,:,:)
-!IF (LACTIT) ZTDT(:,:,:) = (PT(:,:,:)-PTM(:,:,:))/PTSTEP ! dT/dt
!
! find locations where CCN are available
!
@@ -211,21 +220,22 @@ ENDDO
!
GNUCT(:,:,:) = .FALSE.
!
-! NEW : -22°C = limit sup for condensation freezing in Fridlin et al., 2007
-IF( LACTIT ) THEN
- GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) = (PW_NU(IIB:IIE,IJB:IJE,IKB:IKE)>XWMIN .OR. &
- ZTDT(IIB:IIE,IJB:IJE,IKB:IKE)<XTMIN .OR. &
- PRVT(IIB:IIE,IJB:IJE,IKB:IKE)>ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE) ) .AND.&
- PRVT(IIB:IIE,IJB:IJE,IKB:IKE)>(0.98*ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE))&
- .AND. PT(IIB:IIE,IJB:IJE,IKB:IKE)>(XTT-22.) &
- .AND. ZCONC_TOT(IIB:IIE,IJB:IJE,IKB:IKE)>XCTMIN(4)
-ELSE
- GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) = (PW_NU(IIB:IIE,IJB:IJE,IKB:IKE)>XWMIN .OR. &
- PRVT(IIB:IIE,IJB:IJE,IKB:IKE)>ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE) ) .AND.&
- PRVT(IIB:IIE,IJB:IJE,IKB:IKE)>(0.98*ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE))&
- .AND. PT(IIB:IIE,IJB:IJE,IKB:IKE)>(XTT-22.) &
- .AND. ZCONC_TOT(IIB:IIE,IJB:IJE,IKB:IKE)>XCTMIN(4)
-END IF
+GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) = PW_NU(IIB:IIE,IJB:IJE,IKB:IKE)>XWMIN &
+ .OR. PRVT(IIB:IIE,IJB:IJE,IKB:IKE)>ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE)
+IF (LACTIT) GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) = GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) &
+ .OR. ZTDT(IIB:IIE,IJB:IJE,IKB:IKE)<XTMIN
+IF (LSUBG_COND) GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) = GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) &
+ .OR. PCLDFR(IIB:IIE,IJB:IJE,IKB:IKE)>0.01
+!
+GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) = GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) &
+ .AND. PT(IIB:IIE,IJB:IJE,IKB:IKE)>(XTT-22.) &
+ .AND. ZCONC_TOT(IIB:IIE,IJB:IJE,IKB:IKE)>XCTMIN(2)
+!
+IF (.NOT. LSUBG_COND) GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) = GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) &
+ .AND. PRVT(IIB:IIE,IJB:IJE,IKB:IKE).GE.ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE)
+!
+
+
INUCT = COUNTJV( GNUCT(:,:,:),I1(:),I2(:),I3(:))
!
IF( INUCT >= 1 ) THEN
@@ -233,6 +243,8 @@ IF( INUCT >= 1 ) THEN
ALLOCATE(ZNFT(INUCT,NMOD_CCN))
ALLOCATE(ZNAT(INUCT,NMOD_CCN))
ALLOCATE(ZTMP(INUCT,NMOD_CCN))
+ ALLOCATE(ZRCT(INUCT))
+ ALLOCATE(ZCCT(INUCT))
ALLOCATE(ZZT(INUCT))
ALLOCATE(ZZTDT(INUCT))
ALLOCATE(ZSW(INUCT))
@@ -248,6 +260,8 @@ IF( INUCT >= 1 ) THEN
ALLOCATE(ZRHODREF(INUCT))
ALLOCATE(ZEXNREF(INUCT))
DO JL=1,INUCT
+ ZRCT(JL) = PRCT(I1(JL),I2(JL),I3(JL))
+ ZCCT(JL) = PCCT(I1(JL),I2(JL),I3(JL))
ZZT(JL) = PT(I1(JL),I2(JL),I3(JL))
ZZW1(JL) = ZRVSAT(I1(JL),I2(JL),I3(JL))
ZZW2(JL) = PW_NU(I1(JL),I2(JL),I3(JL))
@@ -300,6 +314,8 @@ IF( INUCT >= 1 ) THEN
ZZW3(:) = XAHENG( IVEC1(:)+1)*(ZZW4(:)**1.5)* ZVEC1(:) &
- XAHENG( IVEC1(:) )*(ZZW5(:)**1.5)*(ZVEC1(:) - 1.0)
! Cste*((Psi1*w+Psi3*dT/dt)/(G))**1.5
+ ZZW6(:) = XAHENG2( IVEC1(:)+1)*(ZZW4(:)**0.5)* ZVEC1(:) &
+ - XAHENG2( IVEC1(:) )*(ZZW5(:)**0.5)*(ZVEC1(:) - 1.0)
!
!
ELSE ! LACTIT , for clouds
@@ -315,6 +331,9 @@ IF( INUCT >= 1 ) THEN
ZZW2(:)=MAX(ZZW2(:),0.)
ZZW3(:)=XAHENG(IVEC1(:)+1)*((XPSI1(IVEC1(:)+1)*ZZW2(:))**1.5)* ZVEC1(:) &
-XAHENG(IVEC1(:) )*((XPSI1(IVEC1(:) )*ZZW2(:))**1.5)*(ZVEC1(:)-1.0)
+!
+ ZZW6(:)=XAHENG2(IVEC1(:)+1)*((XPSI1(IVEC1(:)+1)*ZZW2(:))**0.5)* ZVEC1(:) &
+ -XAHENG2(IVEC1(:) )*((XPSI1(IVEC1(:) )*ZZW2(:))**0.5)*(ZVEC1(:)-1.0)
!
END IF ! LACTIT
!
@@ -325,12 +344,17 @@ IF( INUCT >= 1 ) THEN
!
ZZW5(:) = 1.
ZZW3(:) = (ZZW3(:)/ZZW1(:))*ZRHODREF(:) ! R.H.S. of Eq 9 of CPB 98 but
- ! for multiple aerosol modes
+ ! for multiple aerosol modes
+ WHERE (ZRCT(:) > XRTMIN(2) .AND. ZCCT(:) > XCTMIN(2))
+ ZZW6(:) = ZZW6(:) * ZRHODREF(:) * ZCCT(:) / (XLBC*ZCCT(:)/ZRCT(:))**XLBEXC
+ ELSEWHERE
+ ZZW6(:)=0.
+ END WHERE
+
WHERE (ZZW3(:) == 0. .AND. .NOT.(ZSW>0.))
ZZW5(:) = -1.
END WHERE
!
-!
!-------------------------------------------------------------------------------
!
!
@@ -345,9 +369,9 @@ IF( INUCT >= 1 ) THEN
! Check with values used for tabulation in ini_lima_warm.f90
ZS1 = 1.0E-5 ! corresponds to 0.001% supersaturation
ZS2 = 5.0E-2 ! corresponds to 5.0% supersaturation
- ZXACC = 1.0E-7 ! Accuracy needed for the search in [NO UNITS]
+ ZXACC = 1.0E-10 ! Accuracy needed for the search in [NO UNITS]
!
- ZSMAX(:) = ZRIDDR(ZS1,ZS2,ZXACC,ZZW3(:),INUCT) ! ZSMAX(:) is in [NO UNITS]
+ ZSMAX(:) = ZRIDDR(ZS1,ZS2,ZXACC,ZZW3(:),ZZW6(:),INUCT) ! ZSMAX(:) is in [NO UNITS]
ZSMAX(:) = MIN(MAX(ZSMAX(:), ZSW(:)),ZS2)
!
!
@@ -394,17 +418,17 @@ IF( INUCT >= 1 ) THEN
ZZW2(:) = 0.
ZZW3(:) = 0.
!
- WHERE( SUM(ZTMP(:,:),DIM=2) .GT. 15.E6/ZRHODREF(:) )
+ WHERE( SUM(ZTMP(:,:),DIM=2) .GT. 0.01E6/ZRHODREF(:) )
ZZW1(:) = MIN( ZNFT(:,JMOD),MAX( ZTMP(:,JMOD)- ZNAT(:,JMOD) , 0.0 ) )
ENDWHERE
!
!* update the concentration of activated CCN = Na
!
- PNAT(:,:,:,JMOD) = PNAT(:,:,:,JMOD) + UNPACK( ZZW1(:), MASK=GNUCT(:,:,:), FIELD=0.0 )
+ PNAT(:,:,:,JMOD) = PNAT(:,:,:,JMOD) + PCLDFR(:,:,:) * UNPACK( ZZW1(:), MASK=GNUCT(:,:,:), FIELD=0.0 )
!
!* update the concentration of free CCN = Nf
!
- PNFT(:,:,:,JMOD) = PNFT(:,:,:,JMOD) - UNPACK( ZZW1(:), MASK=GNUCT(:,:,:), FIELD=0.0 )
+ PNFT(:,:,:,JMOD) = PNFT(:,:,:,JMOD) - PCLDFR(:,:,:) * UNPACK( ZZW1(:), MASK=GNUCT(:,:,:), FIELD=0.0 )
!
!* prepare to update the cloud water concentration
!
@@ -417,13 +441,18 @@ IF( INUCT >= 1 ) THEN
WHERE (ZZW5(:)>0.0 .AND. ZSMAX(:)>0.0) ! ZZW1 is computed with ZSMAX [NO UNIT]
ZZW1(:) = MIN(XCSTDCRIT*ZZW6(:)/(((ZZT(:)*ZSMAX(:))**3)*ZRHODREF(:)),1.E-5)
END WHERE
- ZW(:,:,:) = MIN( UNPACK( ZZW1(:),MASK=GNUCT(:,:,:),FIELD=0.0 ),PRVT(:,:,:) )
!
- PTHT(:,:,:) = PTHT(:,:,:) + ZW(:,:,:) * (XLVTT+(XCPV-XCL)*(PT(:,:,:)-XTT))/ &
+ IF (.NOT.LSUBG_COND) THEN
+ ZW(:,:,:) = MIN( UNPACK( ZZW1(:),MASK=GNUCT(:,:,:),FIELD=0.0 ),PRVT(:,:,:) )
+ PTHT(:,:,:) = PTHT(:,:,:) + ZW(:,:,:) * (XLVTT+(XCPV-XCL)*(PT(:,:,:)-XTT))/ &
(PEXNREF(:,:,:)*(XCPD+XCPV*PRVT(:,:,:)+XCL*(PRCT(:,:,:)+PRRT(:,:,:))))
- PRVT(:,:,:) = PRVT(:,:,:) - ZW(:,:,:)
- PRCT(:,:,:) = PRCT(:,:,:) + ZW(:,:,:)
- PCCT(:,:,:) = PCCT(:,:,:) + UNPACK( ZZW6(:),MASK=GNUCT(:,:,:),FIELD=0. )
+ PRVT(:,:,:) = PRVT(:,:,:) - ZW(:,:,:)
+ PRCT(:,:,:) = PRCT(:,:,:) + ZW(:,:,:)
+ PCCT(:,:,:) = PCCT(:,:,:) + UNPACK( ZZW6(:),MASK=GNUCT(:,:,:),FIELD=0. )
+ ELSE
+ ZW(:,:,:) = MIN( PCLDFR(:,:,:) * UNPACK( ZZW1(:),MASK=GNUCT(:,:,:),FIELD=0.0 ),PRVT(:,:,:) )
+ PCCT(:,:,:) = PCCT(:,:,:) + PCLDFR(:,:,:) * UNPACK( ZZW6(:),MASK=GNUCT(:,:,:),FIELD=0. )
+ END IF
!
ZW(:,:,:) = UNPACK( 100.0*ZSMAX(:),MASK=GNUCT(:,:,:),FIELD=0.0 )
ZW2(:,:,:) = UNPACK( ZZW6(:),MASK=GNUCT(:,:,:),FIELD=0.0 )
@@ -440,6 +469,8 @@ IF( INUCT >= 1 ) THEN
DEALLOCATE(ZVEC1)
DEALLOCATE(ZNFT)
DEALLOCATE(ZNAT)
+ DEALLOCATE(ZCCT)
+ DEALLOCATE(ZRCT)
DEALLOCATE(ZZT)
DEALLOCATE(ZSMAX)
DEALLOCATE(ZZW1)
@@ -498,7 +529,7 @@ END IF
CONTAINS
!------------------------------------------------------------------------------
!
- FUNCTION ZRIDDR(PX1,PX2INIT,PXACC,PZZW3,NPTS) RESULT(PZRIDDR)
+ FUNCTION ZRIDDR(PX1,PX2INIT,PXACC,PZZW3,PZZW6,NPTS) RESULT(PZRIDDR)
!
!
!!**** *ZRIDDR* - iterative algorithm to find root of a function
@@ -552,6 +583,7 @@ IMPLICIT NONE
!
INTEGER, INTENT(IN) :: NPTS
REAL, DIMENSION(:), INTENT(IN) :: PZZW3
+REAL, DIMENSION(:), INTENT(IN) :: PZZW6
REAL, INTENT(IN) :: PX1, PX2INIT, PXACC
REAL, DIMENSION(:), ALLOCATABLE :: PZRIDDR
!
@@ -573,8 +605,8 @@ ALLOCATE(PZRIDDR(NPTS))
!
PZRIDDR(:)= UNUSED
PX2 = PX2INIT
-fl(:) = FUNCSMAX(PX1,PZZW3(:),NPTS)
-fh(:) = FUNCSMAX(PX2,PZZW3(:),NPTS)
+fl(:) = FUNCSMAX(PX1,PZZW3(:),PZZW6(:),NPTS)
+fh(:) = FUNCSMAX(PX2,PZZW3(:),PZZW6(:),NPTS)
!
DO JL = 1, NPTS
PX2 = PX2INIT
@@ -583,7 +615,7 @@ DO JL = 1, NPTS
xh = PX2
do j=1,MAXIT
xm = 0.5*(xl+xh)
- fm(JL) = SINGL_FUNCSMAX(xm,PZZW3(JL),JL)
+ fm(JL) = SINGL_FUNCSMAX(xm,PZZW3(JL),PZZW6(JL),JL)
s = sqrt(fm(JL)**2-fl(JL)*fh(JL))
if (s == 0.0) then
GO TO 101
@@ -593,7 +625,7 @@ DO JL = 1, NPTS
GO TO 101
endif
PZRIDDR(JL) = xnew
- fnew(JL) = SINGL_FUNCSMAX(PZRIDDR(JL),PZZW3(JL),JL)
+ fnew(JL) = SINGL_FUNCSMAX(PZRIDDR(JL),PZZW3(JL),PZZW6(JL),JL)
if (fnew(JL) == 0.0) then
GO TO 101
endif
@@ -611,7 +643,7 @@ DO JL = 1, NPTS
else if (PX2 .lt. 0.05) then
PX2 = PX2 + 1.0E-2
PRINT*, 'PX2 ALWAYS too small, we put a greater one : PX2 =',PX2
- fh(JL) = SINGL_FUNCSMAX(PX2,PZZW3(JL),JL)
+ fh(JL) = SINGL_FUNCSMAX(PX2,PZZW3(JL),PZZW6(JL),JL)
go to 100
end if
if (abs(xh-xl) <= PXACC) then
@@ -632,7 +664,7 @@ DO JL = 1, NPTS
else if (PX2 .lt. 0.05) then
PX2 = PX2 + 1.0E-2
PRINT*, 'PX2 too small, we put a greater one : PX2 =',PX2
- fh(JL) = SINGL_FUNCSMAX(PX2,PZZW3(JL),JL)
+ fh(JL) = SINGL_FUNCSMAX(PX2,PZZW3(JL),PZZW6(JL),JL)
go to 100
else
!!$ print*, 'PZRIDDR: root must be bracketed'
@@ -655,7 +687,7 @@ END FUNCTION ZRIDDR
!
!------------------------------------------------------------------------------
!
- FUNCTION FUNCSMAX(PPZSMAX,PPZZW3,NPTS) RESULT(PFUNCSMAX)
+ FUNCTION FUNCSMAX(PPZSMAX,PPZZW3,PPZZW6,NPTS) RESULT(PFUNCSMAX)
!
!
!!**** *FUNCSMAX* - function describing SMAX function that you want to find the root
@@ -714,6 +746,7 @@ IMPLICIT NONE
INTEGER, INTENT(IN) :: NPTS
REAL, INTENT(IN) :: PPZSMAX ! supersaturation is already in no units
REAL, DIMENSION(:), INTENT(IN) :: PPZZW3 !
+REAL, DIMENSION(:), INTENT(IN) :: PPZZW6 !
REAL, DIMENSION(:), ALLOCATABLE :: PFUNCSMAX !
!
!* 0.2 declarations of local variables
@@ -726,7 +759,7 @@ INTEGER :: PIVEC1
ALLOCATE(PFUNCSMAX(NPTS))
!
PFUNCSMAX(:) = 0.
-PZVEC1 = MAX( 1.0001,MIN( REAL(NHYP)-0.0001, &
+PZVEC1 = MAX( ( 1.0 + 10.0 * XMNH_EPSILON ) ,MIN( REAL(NHYP)*( 1.0 - 10.0 * XMNH_EPSILON ) , &
XHYPINTP1*LOG(PPZSMAX)+XHYPINTP2 ) )
PIVEC1 = INT( PZVEC1 )
PZVEC1 = PZVEC1 - REAL( PIVEC1 )
@@ -741,13 +774,13 @@ DO JMOD = 1, NMOD_CCN
/ GAMMA_X0D((XKHEN_MULTI(JMOD)+3.0)/2.0)
ENDDO
! function l.h.s. minus r.h.s. of eq. (9) of CPB98 but for NMOD_CCN aerosol mode
-PFUNCSMAX(:) = PFUNCSMAX(:) - PPZZW3(:)
+PFUNCSMAX(:) = PFUNCSMAX(:) + PPZZW6(:)*PPZSMAX - PPZZW3(:)
!
END FUNCTION FUNCSMAX
!
!------------------------------------------------------------------------------
!
- FUNCTION SINGL_FUNCSMAX(PPZSMAX,PPZZW3,KINDEX) RESULT(PSINGL_FUNCSMAX)
+ FUNCTION SINGL_FUNCSMAX(PPZSMAX,PPZZW3,PPZZW6,KINDEX) RESULT(PSINGL_FUNCSMAX)
!
!
!!**** *SINGL_FUNCSMAX* - same function as FUNCSMAX
@@ -772,6 +805,7 @@ IMPLICIT NONE
INTEGER, INTENT(IN) :: KINDEX
REAL, INTENT(IN) :: PPZSMAX ! supersaturation is "no unit"
REAL, INTENT(IN) :: PPZZW3 !
+REAL, INTENT(IN) :: PPZZW6 !
REAL :: PSINGL_FUNCSMAX !
!
!* 0.2 declarations of local variables
@@ -797,7 +831,7 @@ DO JMOD = 1, NMOD_CCN
/ GAMMA_X0D((XKHEN_MULTI(JMOD)+3.0)/2.0)
ENDDO
! function l.h.s. minus r.h.s. of eq. (9) of CPB98 but for NMOD_CCN aerosol mode
-PSINGL_FUNCSMAX = PSINGL_FUNCSMAX - PPZZW3
+PSINGL_FUNCSMAX = PSINGL_FUNCSMAX + PPZZW6*PPZSMAX - PPZZW3
!
END FUNCTION SINGL_FUNCSMAX
!
diff --git a/src/MNH/lima_ccn_hom_freezing.f90 b/src/MNH/lima_ccn_hom_freezing.f90
index a716c4da7ee57d02bf637d56a4be01af1c47463d..fa5f3ed2f9686f6f1843ee76f5787f4ba0c9efa8 100644
--- a/src/MNH/lima_ccn_hom_freezing.f90
+++ b/src/MNH/lima_ccn_hom_freezing.f90
@@ -10,7 +10,8 @@
INTERFACE
SUBROUTINE LIMA_CCN_HOM_FREEZING (PRHODREF, PEXNREF, PPABST, PW_NU, &
PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
- PCCT, PCRT, PCIT, PNFT, PNHT )
+ PCCT, PCRT, PCIT, PNFT, PNHT, &
+ PICEFR )
!
REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
@@ -33,6 +34,8 @@ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIT ! Ice crystal C. source
REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNFT ! Free CCN conc.
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PNHT ! haze homogeneous freezing
!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PICEFR ! Ice fraction
+!
END SUBROUTINE LIMA_CCN_HOM_FREEZING
END INTERFACE
END MODULE MODI_LIMA_CCN_HOM_FREEZING
@@ -40,7 +43,8 @@ END MODULE MODI_LIMA_CCN_HOM_FREEZING
! ##########################################################################
SUBROUTINE LIMA_CCN_HOM_FREEZING (PRHODREF, PEXNREF, PPABST, PW_NU, &
PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
- PCCT, PCRT, PCIT, PNFT, PNHT )
+ PCCT, PCRT, PCIT, PNFT, PNHT , &
+ PICEFR )
! ##########################################################################
!
!! PURPOSE
@@ -106,6 +110,8 @@ REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIT ! Ice crystal C. source
REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNFT ! Free CCN conc.
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PNHT ! haze homogeneous freezing
!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PICEFR ! Ice fraction
+!
!* 0.2 Declarations of local variables :
!
REAL, DIMENSION(:), ALLOCATABLE :: ZRVT ! Water vapor m.r. at t
diff --git a/src/MNH/lima_compute_cloud_fractions.f90 b/src/MNH/lima_compute_cloud_fractions.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c58bfa83df8085e8ad551f2c01631520aa5f83b5
--- /dev/null
+++ b/src/MNH/lima_compute_cloud_fractions.f90
@@ -0,0 +1,172 @@
+!MNH_LIC Copyright 2013-2018 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.
+!#######################################
+MODULE MODI_LIMA_COMPUTE_CLOUD_FRACTIONS
+!#######################################
+ INTERFACE
+ SUBROUTINE LIMA_COMPUTE_CLOUD_FRACTIONS (KIB, KIE, KJB, KJE, KKB, KKE, KKL, &
+ PCCT, PRCT, &
+ PCRT, PRRT, &
+ PCIT, PRIT, &
+ PRST, PRGT, PRHT, &
+ PCLDFR, PICEFR, PPRCFR )
+ INTEGER, INTENT(IN) :: KIB !
+ INTEGER, INTENT(IN) :: KIE !
+ INTEGER, INTENT(IN) :: KJB !
+ INTEGER, INTENT(IN) :: KJE !
+ INTEGER, INTENT(IN) :: KKB !
+ INTEGER, INTENT(IN) :: KKE !
+ INTEGER, INTENT(IN) :: KKL !
+ !
+ REAL, DIMENSION(:,:,:),INTENT(IN) :: PCCT !
+ REAL, DIMENSION(:,:,:),INTENT(IN) :: PRCT !
+ !
+ REAL, DIMENSION(:,:,:),INTENT(IN) :: PCRT !
+ REAL, DIMENSION(:,:,:),INTENT(IN) :: PRRT !
+ !
+ REAL, DIMENSION(:,:,:),INTENT(IN) :: PCIT !
+ REAL, DIMENSION(:,:,:),INTENT(IN) :: PRIT !
+ !
+ REAL, DIMENSION(:,:,:),INTENT(IN) :: PRST !
+ REAL, DIMENSION(:,:,:),INTENT(IN) :: PRGT !
+ REAL, DIMENSION(:,:,:),INTENT(IN) :: PRHT !
+ !
+ REAL, DIMENSION(:,:,:),INTENT(INOUT) :: PCLDFR !
+ REAL, DIMENSION(:,:,:),INTENT(INOUT) :: PICEFR !
+ REAL, DIMENSION(:,:,:),INTENT(INOUT) :: PPRCFR !
+ !
+ END SUBROUTINE LIMA_COMPUTE_CLOUD_FRACTIONS
+ END INTERFACE
+END MODULE MODI_LIMA_COMPUTE_CLOUD_FRACTIONS
+!
+!
+!################################################################
+SUBROUTINE LIMA_COMPUTE_CLOUD_FRACTIONS (KIB, KIE, KJB, KJE, KKB, KKE, KKL, &
+ PCCT, PRCT, &
+ PCRT, PRRT, &
+ PCIT, PRIT, &
+ PRST, PRGT, PRHT, &
+ PCLDFR, PICEFR, PPRCFR )
+!################################################################
+!
+!!
+!! PURPOSE
+!! -------
+!! Compute cloud, ice and precipitating fractions
+!!
+!! AUTHOR
+!! ------
+!! B. Vié * CNRM *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/03/2019
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAM_LIMA, ONLY : XCTMIN, XRTMIN
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+INTEGER, INTENT(IN) :: KIB !
+INTEGER, INTENT(IN) :: KIE !
+INTEGER, INTENT(IN) :: KJB !
+INTEGER, INTENT(IN) :: KJE !
+INTEGER, INTENT(IN) :: KKB !
+INTEGER, INTENT(IN) :: KKE !
+INTEGER, INTENT(IN) :: KKL !
+!
+REAL, DIMENSION(:,:,:),INTENT(IN) :: PCCT !
+REAL, DIMENSION(:,:,:),INTENT(IN) :: PRCT !
+!
+REAL, DIMENSION(:,:,:),INTENT(IN) :: PCRT !
+REAL, DIMENSION(:,:,:),INTENT(IN) :: PRRT !
+!
+REAL, DIMENSION(:,:,:),INTENT(IN) :: PCIT !
+REAL, DIMENSION(:,:,:),INTENT(IN) :: PRIT !
+!
+REAL, DIMENSION(:,:,:),INTENT(IN) :: PRST !
+REAL, DIMENSION(:,:,:),INTENT(IN) :: PRGT !
+REAL, DIMENSION(:,:,:),INTENT(IN) :: PRHT !
+!
+REAL, DIMENSION(:,:,:),INTENT(INOUT) :: PCLDFR !
+REAL, DIMENSION(:,:,:),INTENT(INOUT) :: PICEFR !
+REAL, DIMENSION(:,:,:),INTENT(INOUT) :: PPRCFR !
+!
+!* 0.2 Declarations of local variables :
+!
+INTEGER :: JI, JJ, JK
+!
+!-------------------------------------------------------------------------------
+!
+! CLOUD FRACTIONS
+! ---------------
+!
+! Liquid cloud fraction is kept from input data, except where PCLDFR=0 and rc>0
+WHERE(PCLDFR(:,:,:)<1.E-10 .AND. PRCT(:,:,:)>XRTMIN(2) .AND. PCCT(:,:,:)>XCTMIN(2)) PCLDFR(:,:,:)=1.
+!
+! Ice cloud fraction is currently 0 or 1
+PICEFR(:,:,:)=0.
+WHERE(PICEFR(:,:,:)<1.E-10 .AND. PRIT(:,:,:)>XRTMIN(4) .AND. PCIT(:,:,:)>XCTMIN(4)) PICEFR(:,:,:)=1.
+!
+! Precipitation fraction
+!!$PPRCFR(:,:,:) = MAX(PCLDFR(:,:,:),PICEFR(:,:,:))
+!!$DO JI = KIB,KIE
+!!$ DO JJ = KJB, KJE
+!!$ DO JK=KKE-KKL, KKB, -KKL
+!!$ IF ( (PRRT(JI,JJ,JK).GT.XRTMIN(3) .AND. PCRT(JI,JJ,JK).GT.XCTMIN(3)) .OR. &
+!!$ PRST(JI,JJ,JK).GT.XRTMIN(5) .OR. &
+!!$ PRGT(JI,JJ,JK).GT.XRTMIN(6) .OR. &
+!!$ PRHT(JI,JJ,JK).GT.XRTMIN(7) ) THEN
+!!$ PPRCFR(JI,JJ,JK)=MAX(PPRCFR(JI,JJ,JK),PPRCFR(JI,JJ,JK+KKL))
+!!$ IF (PPRCFR(JI,JJ,JK)==0) THEN
+!!$ PPRCFR(JI,JJ,JK)=1.
+!!$ END IF
+!!$ ELSE
+!!$ !PPRCFR(JI,JJ,JK)=0.
+!!$ END IF
+!!$ END DO
+!!$ END DO
+!!$END DO
+!!$
+!!$PPRCFR(:,:,:) = MAX(PCLDFR(:,:,:),PICEFR(:,:,:))
+!!$DO JI = KIB,KIE
+!!$ DO JJ = KJB, KJE
+!!$ DO JK=KKE-KKL, KKB, -KKL
+!!$ IF ( (PRRT(JI,JJ,JK).GT.0. .AND. PCRT(JI,JJ,JK).GT.0.) .OR. &
+!!$ PRST(JI,JJ,JK).GT.0. .OR. &
+!!$ PRGT(JI,JJ,JK).GT.0. .OR. &
+!!$ PRHT(JI,JJ,JK).GT.0. ) THEN
+!!$ PPRCFR(JI,JJ,JK)=MAX(PPRCFR(JI,JJ,JK),PPRCFR(JI,JJ,JK+KKL))
+!!$ IF (PPRCFR(JI,JJ,JK)==0) THEN
+!!$ PPRCFR(JI,JJ,JK)=1.
+!!$ END IF
+!!$ ELSE
+!!$ !PPRCFR(JI,JJ,JK)=0.
+!!$ END IF
+!!$ END DO
+!!$ END DO
+!!$END DO
+!!$
+!!$PPRCFR(:,:,:) = 0.
+!!$WHERE ( (PRRT(:,:,:).GT.XRTMIN(3) .AND. PCRT(:,:,:).GT.XCTMIN(3)) .OR. &
+!!$ PRST(:,:,:).GT.XRTMIN(5) .OR. &
+!!$ PRGT(:,:,:).GT.XRTMIN(6) .OR. &
+!!$ PRHT(:,:,:).GT.XRTMIN(7) ) PPRCFR(:,:,:) = 1.
+!!$
+PPRCFR(:,:,:) = 0.
+WHERE ( (PRRT(:,:,:).GT.0. .AND. PCRT(:,:,:).GT.0.) .OR. &
+ PRST(:,:,:).GT.0. .OR. &
+ PRGT(:,:,:).GT.0. .OR. &
+ PRHT(:,:,:).GT.0. ) PPRCFR(:,:,:) = 1.
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE LIMA_COMPUTE_CLOUD_FRACTIONS
diff --git a/src/MNH/lima_conversion_melting_snow.f90 b/src/MNH/lima_conversion_melting_snow.f90
index 3102a165b0f4c0fb03e0e422c1b5b907024363c7..c1bfc58400773e1b381b55008e7554eac5335816 100644
--- a/src/MNH/lima_conversion_melting_snow.f90
+++ b/src/MNH/lima_conversion_melting_snow.f90
@@ -10,8 +10,7 @@ INTERFACE
SUBROUTINE LIMA_CONVERSION_MELTING_SNOW (LDCOMPUTE, &
PRHODREF, PPRES, PT, PKA, PDV, PCJ, &
PRVT, PRST, PLBDS, &
- P_RS_CMEL, &
- PA_RS, PA_RG )
+ P_RS_CMEL )
!
LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
!
@@ -28,9 +27,6 @@ REAL, DIMENSION(:), INTENT(IN) :: PLBDS !
!
REAL, DIMENSION(:), INTENT(INOUT) :: P_RS_CMEL
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RS
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RG
-!
END SUBROUTINE LIMA_CONVERSION_MELTING_SNOW
END INTERFACE
END MODULE MODI_LIMA_CONVERSION_MELTING_SNOW
@@ -39,8 +35,7 @@ END MODULE MODI_LIMA_CONVERSION_MELTING_SNOW
SUBROUTINE LIMA_CONVERSION_MELTING_SNOW (LDCOMPUTE, &
PRHODREF, PPRES, PT, PKA, PDV, PCJ, &
PRVT, PRST, PLBDS, &
- P_RS_CMEL, &
- PA_RS, PA_RG )
+ P_RS_CMEL )
! ##############################################################################
!
!! PURPOSE
@@ -88,9 +83,6 @@ REAL, DIMENSION(:), INTENT(IN) :: PLBDS !
!
REAL, DIMENSION(:), INTENT(INOUT) :: P_RS_CMEL
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RS
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RG
-!
!* 0.2 Declarations of local variables :
!
REAL, DIMENSION(SIZE(PRST)) :: ZW ! work arrays
@@ -122,8 +114,6 @@ WHERE( (PRST(:)>XRTMIN(5)) .AND. (PT(:)>XTT) .AND. LDCOMPUTE(:) )
!
END WHERE
!
-PA_RS(:) = PA_RS(:) + P_RS_CMEL(:)
-PA_RG(:) = PA_RG(:) - P_RS_CMEL(:)
!
!-------------------------------------------------------------------------------
!
diff --git a/src/MNH/lima_droplets_accretion.f90 b/src/MNH/lima_droplets_accretion.f90
index 6344246004384d4e0acc4bebef3f83fd9e6b5b50..865c486affb4d924dde8ce57e17f67d21e791959 100644
--- a/src/MNH/lima_droplets_accretion.f90
+++ b/src/MNH/lima_droplets_accretion.f90
@@ -11,8 +11,7 @@ INTERFACE
PRHODREF, &
PRCT, PRRT, PCCT, PCRT, &
PLBDC, PLBDC3, PLBDR, PLBDR3, &
- P_RC_ACCR, P_CC_ACCR, &
- PA_RC, PA_CC, PA_RR )
+ P_RC_ACCR, P_CC_ACCR )
!
LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
!
@@ -30,10 +29,6 @@ REAL, DIMENSION(:), INTENT(IN) :: PLBDR3 !
REAL, DIMENSION(:), INTENT(INOUT) :: P_RC_ACCR
REAL, DIMENSION(:), INTENT(INOUT) :: P_CC_ACCR
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RC
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CC
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RR
-!
END SUBROUTINE LIMA_DROPLETS_ACCRETION
END INTERFACE
END MODULE MODI_LIMA_DROPLETS_ACCRETION
@@ -43,8 +38,7 @@ END MODULE MODI_LIMA_DROPLETS_ACCRETION
PRHODREF, &
PRCT, PRRT, PCCT, PCRT, &
PLBDC, PLBDC3, PLBDR, PLBDR3, &
- P_RC_ACCR, P_CC_ACCR, &
- PA_RC, PA_CC, PA_RR )
+ P_RC_ACCR, P_CC_ACCR )
! #####################################################################
!
!! PURPOSE
@@ -94,10 +88,6 @@ REAL, DIMENSION(:), INTENT(IN) :: PLBDR3 !
REAL, DIMENSION(:), INTENT(INOUT) :: P_RC_ACCR
REAL, DIMENSION(:), INTENT(INOUT) :: P_CC_ACCR
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RC
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CC
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RR
-!
!* 0.2 Declarations of local variables :
!
REAL, DIMENSION(SIZE(PRCT)) :: ZW1, ZW2, ZW3, ZW4 ! work arrays
@@ -162,9 +152,6 @@ WHERE( GACCR(:).AND.(ZW4(:)<=1.E-4) )
P_RC_ACCR(:) = - ZW2(:)
END WHERE
!
-PA_RC(:) = PA_RC(:) + P_RC_ACCR(:)
-PA_CC(:) = PA_CC(:) + P_CC_ACCR(:)
-PA_RR(:) = PA_RR(:) - P_RC_ACCR(:)
!
!
!-------------------------------------------------------------------------------
diff --git a/src/MNH/lima_droplets_autoconversion.f90 b/src/MNH/lima_droplets_autoconversion.f90
index f88eb265d4d599ecdbb43cf0035fef6923c2212e..7a1d53b85b95eb60a5ee3ebc71079b3724403caa 100644
--- a/src/MNH/lima_droplets_autoconversion.f90
+++ b/src/MNH/lima_droplets_autoconversion.f90
@@ -9,15 +9,15 @@
INTERFACE
SUBROUTINE LIMA_DROPLETS_AUTOCONVERSION (LDCOMPUTE, &
PRHODREF, &
- PRCT, PLBDC, PLBDR, &
- P_RC_AUTO, P_CC_AUTO, P_CR_AUTO,&
- PA_RC, PA_CC, PA_RR, PA_CR )
+ PRCT, PCCT, PLBDC, PLBDR, &
+ P_RC_AUTO, P_CC_AUTO, P_CR_AUTO )
!
LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
!
REAL, DIMENSION(:), INTENT(IN) :: PRHODREF ! Reference Exner function
!
REAL, DIMENSION(:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
+REAL, DIMENSION(:), INTENT(IN) :: PCCT ! Cloud water conc. at t
REAL, DIMENSION(:), INTENT(IN) :: PLBDC !
REAL, DIMENSION(:), INTENT(IN) :: PLBDR !
!
@@ -25,11 +25,6 @@ REAL, DIMENSION(:), INTENT(INOUT) :: P_RC_AUTO
REAL, DIMENSION(:), INTENT(INOUT) :: P_CC_AUTO
REAL, DIMENSION(:), INTENT(INOUT) :: P_CR_AUTO
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RC
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CC
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RR
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CR
-!
END SUBROUTINE LIMA_DROPLETS_AUTOCONVERSION
END INTERFACE
END MODULE MODI_LIMA_DROPLETS_AUTOCONVERSION
@@ -37,9 +32,8 @@ END MODULE MODI_LIMA_DROPLETS_AUTOCONVERSION
! ##########################################################################
SUBROUTINE LIMA_DROPLETS_AUTOCONVERSION (LDCOMPUTE, &
PRHODREF, &
- PRCT, PLBDC, PLBDR, &
- P_RC_AUTO, P_CC_AUTO, P_CR_AUTO,&
- PA_RC, PA_CC, PA_RR, PA_CR )
+ PRCT, PCCT, PLBDC, PLBDR, &
+ P_RC_AUTO, P_CC_AUTO, P_CR_AUTO )
! ##########################################################################
!
!! PURPOSE
@@ -63,7 +57,7 @@ END MODULE MODI_LIMA_DROPLETS_AUTOCONVERSION
!* 0. DECLARATIONS
! ------------
!
-USE MODD_PARAM_LIMA, ONLY : XRTMIN
+USE MODD_PARAM_LIMA, ONLY : XRTMIN, XCTMIN
USE MODD_PARAM_LIMA_WARM, ONLY : XLAUTR, XAUTO1, XLAUTR_THRESHOLD, &
XITAUTR, XAUTO2, XITAUTR_THRESHOLD, &
XACCR4, XACCR5, XACCR3, XACCR1, XAC
@@ -77,6 +71,7 @@ LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
REAL, DIMENSION(:), INTENT(IN) :: PRHODREF ! Reference Exner function
!
REAL, DIMENSION(:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
+REAL, DIMENSION(:), INTENT(IN) :: PCCT ! Cloud water conc. at t
REAL, DIMENSION(:), INTENT(IN) :: PLBDC !
REAL, DIMENSION(:), INTENT(IN) :: PLBDR !
!
@@ -84,11 +79,6 @@ REAL, DIMENSION(:), INTENT(INOUT) :: P_RC_AUTO
REAL, DIMENSION(:), INTENT(INOUT) :: P_CC_AUTO
REAL, DIMENSION(:), INTENT(INOUT) :: P_CR_AUTO
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RC
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CC
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RR
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CR
-!
!* 0.2 Declarations of local variables :
!
REAL, DIMENSION(SIZE(PRCT)) :: ZW1, ZW2, ZW3 ! work arrays
@@ -109,7 +99,7 @@ P_CR_AUTO(:) = 0.0
ZW3(:) = 0.0
ZW2(:) = 0.0
ZW1(:) = 0.0
-WHERE( PRCT(:)>XRTMIN(2) .AND. PLBDC(:)>0. .AND. LDCOMPUTE(:) )
+WHERE( PRCT(:)>XRTMIN(2) .AND. PCCT(:)>XCTMIN(2) .AND. PLBDC(:)>0. .AND. LDCOMPUTE(:) )
ZW2(:) = MAX( 0.0, &
XLAUTR*PRHODREF(:)*PRCT(:)*(XAUTO1/min(PLBDC(:),1.e9)**4-XLAUTR_THRESHOLD) ) ! L
!
@@ -128,10 +118,6 @@ WHERE( PRCT(:)>XRTMIN(2) .AND. PLBDC(:)>0. .AND. LDCOMPUTE(:) )
P_CC_AUTO(:) = -ZW3(:)
P_CR_AUTO(:) = ZW3(:)
!
- PA_RC(:) = PA_RC(:) + P_RC_AUTO(:)
- PA_CC(:) = PA_CC(:) + P_CC_AUTO(:)
- PA_RR(:) = PA_RR(:) - P_RC_AUTO(:)
- PA_CR(:) = PA_CR(:) + P_CR_AUTO(:)
END WHERE
!
!
diff --git a/src/MNH/lima_droplets_riming_snow.f90 b/src/MNH/lima_droplets_riming_snow.f90
index b255295a432345a39639e258f5436bb2ffbe7a9e..dd6fcb2d1a66f484b7f69b814949f7041a066592 100644
--- a/src/MNH/lima_droplets_riming_snow.f90
+++ b/src/MNH/lima_droplets_riming_snow.f90
@@ -11,8 +11,7 @@ INTERFACE
PRHODREF, PT, &
PRCT, PCCT, PRST, PLBDC, PLBDS, PLVFACT, PLSFACT, &
P_TH_RIM, P_RC_RIM, P_CC_RIM, P_RS_RIM, P_RG_RIM, &
- P_RI_HMS, P_CI_HMS, P_RS_HMS, &
- PA_TH, PA_RC, PA_CC, PA_RI, PA_CI, PA_RS, PA_RG )
+ P_RI_HMS, P_CI_HMS, P_RS_HMS )
!
REAL, INTENT(IN) :: PTSTEP
LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
@@ -38,14 +37,6 @@ REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_HMS
REAL, DIMENSION(:), INTENT(INOUT) :: P_CI_HMS
REAL, DIMENSION(:), INTENT(INOUT) :: P_RS_HMS
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_TH
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RC
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CC
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RI
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CI
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RS
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RG
-!
END SUBROUTINE LIMA_DROPLETS_RIMING_SNOW
END INTERFACE
END MODULE MODI_LIMA_DROPLETS_RIMING_SNOW
@@ -55,8 +46,7 @@ END MODULE MODI_LIMA_DROPLETS_RIMING_SNOW
PRHODREF, PT, &
PRCT, PCCT, PRST, PLBDC, PLBDS, PLVFACT, PLSFACT, &
P_TH_RIM, P_RC_RIM, P_CC_RIM, P_RS_RIM, P_RG_RIM, &
- P_RI_HMS, P_CI_HMS, P_RS_HMS, &
- PA_TH, PA_RC, PA_CC, PA_RI, PA_CI, PA_RS, PA_RG )
+ P_RI_HMS, P_CI_HMS, P_RS_HMS )
! #########################################################################################
!
!! PURPOSE
@@ -116,14 +106,6 @@ REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_HMS
REAL, DIMENSION(:), INTENT(INOUT) :: P_CI_HMS
REAL, DIMENSION(:), INTENT(INOUT) :: P_RS_HMS
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_TH
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RC
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CC
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RI
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CI
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RS
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RG
-!
!* 0.2 Declarations of local variables :
!
LOGICAL, DIMENSION(SIZE(PRCT)) :: GRIM
@@ -237,13 +219,6 @@ WHERE ( GRIM )
END WHERE
!
!
-PA_RC(:) = PA_RC(:) + P_RC_RIM(:)
-PA_CC(:) = PA_CC(:) + P_CC_RIM(:)
-PA_RI(:) = PA_RI(:) + P_RI_HMS(:)
-PA_CI(:) = PA_CI(:) + P_CI_HMS(:)
-PA_RS(:) = PA_RS(:) + P_RS_RIM(:) + P_RS_HMS(:)
-PA_RG(:) = PA_RG(:) + P_RG_RIM(:)
-PA_TH(:) = PA_TH(:) + P_TH_RIM(:)
!
!-------------------------------------------------------------------------------
!
diff --git a/src/MNH/lima_droplets_self_collection.f90 b/src/MNH/lima_droplets_self_collection.f90
index c97e0cc55b1f66a8b2e30fe659810042dba5e7da..044353832fe7908f2610b849c79b771918e72e5a 100644
--- a/src/MNH/lima_droplets_self_collection.f90
+++ b/src/MNH/lima_droplets_self_collection.f90
@@ -10,8 +10,7 @@ INTERFACE
SUBROUTINE LIMA_DROPLETS_SELF_COLLECTION (LDCOMPUTE, &
PRHODREF, &
PCCT, PLBDC3, &
- P_CC_SELF, &
- PA_CC )
+ P_CC_SELF )
!
LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
!
@@ -22,8 +21,6 @@ REAL, DIMENSION(:), INTENT(IN) :: PLBDC3 !
!
REAL, DIMENSION(:), INTENT(INOUT) :: P_CC_SELF
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CC
-!
END SUBROUTINE LIMA_DROPLETS_SELF_COLLECTION
END INTERFACE
END MODULE MODI_LIMA_DROPLETS_SELF_COLLECTION
@@ -32,8 +29,7 @@ END MODULE MODI_LIMA_DROPLETS_SELF_COLLECTION
SUBROUTINE LIMA_DROPLETS_SELF_COLLECTION (LDCOMPUTE, &
PRHODREF, &
PCCT, PLBDC3, &
- P_CC_SELF, &
- PA_CC )
+ P_CC_SELF )
! ######################################################################
!
!! PURPOSE
@@ -73,8 +69,6 @@ REAL, DIMENSION(:), INTENT(IN) :: PLBDC3 !
!
REAL, DIMENSION(:), INTENT(INOUT) :: P_CC_SELF
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CC
-!
!* 0.2 Declarations of local variables :
!
REAL, DIMENSION(SIZE(PCCT)) :: ZW ! work arrays
@@ -91,7 +85,6 @@ P_CC_SELF(:)=0.
WHERE( PCCT(:)>XCTMIN(2) .AND. LDCOMPUTE(:) )
ZW(:) = XSELFC*(PCCT(:)/PLBDC3(:))**2 * PRHODREF(:) ! analytical integration
P_CC_SELF(:) = - ZW(:)
- PA_CC(:) = PA_CC(:) + P_CC_SELF(:)
END WHERE
!
!
diff --git a/src/MNH/lima_drops_self_collection.f90 b/src/MNH/lima_drops_self_collection.f90
index c5bdc6f91fe832689ffd23e4a7712ac76a2398c1..8ad6824cb68ca4ac1c3b07ff9abb901f9857873d 100644
--- a/src/MNH/lima_drops_self_collection.f90
+++ b/src/MNH/lima_drops_self_collection.f90
@@ -10,8 +10,7 @@ INTERFACE
SUBROUTINE LIMA_DROPS_SELF_COLLECTION (LDCOMPUTE, &
PRHODREF, &
PCRT, PLBDR, PLBDR3, &
- P_CR_SCBU, &
- PA_CR )
+ P_CR_SCBU )
!
LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
!
@@ -23,8 +22,6 @@ REAL, DIMENSION(:), INTENT(IN) :: PLBDR3 !
!
REAL, DIMENSION(:), INTENT(INOUT) :: P_CR_SCBU
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CR
-!
END SUBROUTINE LIMA_DROPS_SELF_COLLECTION
END INTERFACE
END MODULE MODI_LIMA_DROPS_SELF_COLLECTION
@@ -33,8 +30,7 @@ END MODULE MODI_LIMA_DROPS_SELF_COLLECTION
SUBROUTINE LIMA_DROPS_SELF_COLLECTION (LDCOMPUTE, &
PRHODREF, &
PCRT, PLBDR, PLBDR3, &
- P_CR_SCBU, &
- PA_CR )
+ P_CR_SCBU )
! #############################################################
!
!! PURPOSE
@@ -76,8 +72,6 @@ REAL, DIMENSION(:), INTENT(IN) :: PLBDR3 !
!
REAL, DIMENSION(:), INTENT(INOUT) :: P_CR_SCBU
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CR
-!
!* 0.2 Declarations of local variables :
!
REAL, DIMENSION(SIZE(PCRT)) :: &
@@ -122,8 +116,6 @@ END WHERE
!
P_CR_SCBU(:) = - ZW3(:) * PRHODREF(:)
!
-PA_CR(:) = PA_CR(:) + P_CR_SCBU(:)
-!
!
!-------------------------------------------------------------------------------
!
diff --git a/src/MNH/lima_graupel_deposition.f90 b/src/MNH/lima_graupel_deposition.f90
index 4c042364de5b785987f468d9c3bb5a92d7981a5a..9daf669ebaf08c7c665748f6d3ceba23368a14dc 100644
--- a/src/MNH/lima_graupel_deposition.f90
+++ b/src/MNH/lima_graupel_deposition.f90
@@ -9,8 +9,7 @@
INTERFACE
SUBROUTINE LIMA_GRAUPEL_DEPOSITION (LDCOMPUTE, PRHODREF, &
PRGT, PSSI, PLBDG, PAI, PCJ, PLSFACT, &
- P_TH_DEPG, P_RG_DEPG, &
- PA_TH, PA_RV, PA_RG )
+ P_TH_DEPG, P_RG_DEPG )
!
LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
REAL, DIMENSION(:), INTENT(IN) :: PRHODREF !
@@ -24,10 +23,6 @@ REAL, DIMENSION(:), INTENT(IN) :: PLSFACT !
!
REAL, DIMENSION(:), INTENT(INOUT) :: P_TH_DEPG
REAL, DIMENSION(:), INTENT(INOUT) :: P_RG_DEPG
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_TH
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RV
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RG
!!
END SUBROUTINE LIMA_GRAUPEL_DEPOSITION
END INTERFACE
@@ -36,8 +31,7 @@ END MODULE MODI_LIMA_GRAUPEL_DEPOSITION
! ###########################################################################
SUBROUTINE LIMA_GRAUPEL_DEPOSITION (LDCOMPUTE, PRHODREF, &
PRGT, PSSI, PLBDG, PAI, PCJ, PLSFACT, &
- P_TH_DEPG, P_RG_DEPG, &
- PA_TH, PA_RV, PA_RG )
+ P_TH_DEPG, P_RG_DEPG )
! ###########################################################################
!
!! PURPOSE
@@ -81,10 +75,6 @@ REAL, DIMENSION(:), INTENT(IN) :: PLSFACT !
REAL, DIMENSION(:), INTENT(INOUT) :: P_TH_DEPG
REAL, DIMENSION(:), INTENT(INOUT) :: P_RG_DEPG
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_TH
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RV
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RG
-!
!
!-------------------------------------------------------------------------------
!
@@ -100,10 +90,6 @@ WHERE ( (PRGT(:)>XRTMIN(6)) .AND. LDCOMPUTE(:) )
P_TH_DEPG(:) = P_RG_DEPG(:)*PLSFACT(:)
END WHERE
!
-PA_RV(:) = PA_RV(:) - P_RG_DEPG(:)
-PA_RG(:) = PA_RG(:) + P_RG_DEPG(:)
-PA_TH(:) = PA_TH(:) + P_TH_DEPG(:)
-!
!
!-------------------------------------------------------------------------------
!
diff --git a/src/MNH/lima_ice_aggregation_snow.f90 b/src/MNH/lima_ice_aggregation_snow.f90
index 09ebc41dca2aab029d52c586d4efb67476b8ee9f..7c1de8be56dcf1a905bbd346d0aec0450c09f56c 100644
--- a/src/MNH/lima_ice_aggregation_snow.f90
+++ b/src/MNH/lima_ice_aggregation_snow.f90
@@ -10,8 +10,7 @@ INTERFACE
SUBROUTINE LIMA_ICE_AGGREGATION_SNOW (LDCOMPUTE, &
PT, PRHODREF, &
PRIT, PRST, PCIT, PLBDI, PLBDS, &
- P_RI_AGGS, P_CI_AGGS, &
- PA_RI, PA_CI, PA_RS )
+ P_RI_AGGS, P_CI_AGGS )
!
LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
!
@@ -27,10 +26,6 @@ REAL, DIMENSION(:), INTENT(IN) :: PLBDS
REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_AGGS
REAL, DIMENSION(:), INTENT(INOUT) :: P_CI_AGGS
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RI
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CI
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RS
-!
END SUBROUTINE LIMA_ICE_AGGREGATION_SNOW
END INTERFACE
END MODULE MODI_LIMA_ICE_AGGREGATION_SNOW
@@ -39,8 +34,7 @@ END MODULE MODI_LIMA_ICE_AGGREGATION_SNOW
SUBROUTINE LIMA_ICE_AGGREGATION_SNOW (LDCOMPUTE, &
PT, PRHODREF, &
PRIT, PRST, PCIT, PLBDI, PLBDS, &
- P_RI_AGGS, P_CI_AGGS, &
- PA_RI, PA_CI, PA_RS )
+ P_RI_AGGS, P_CI_AGGS )
! #######################################################################
!
!! PURPOSE
@@ -86,10 +80,6 @@ REAL, DIMENSION(:), INTENT(IN) :: PLBDS
REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_AGGS
REAL, DIMENSION(:), INTENT(INOUT) :: P_CI_AGGS
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RI
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CI
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RS
-!
!* 0.2 Declarations of local variables :
!
REAL, DIMENSION(SIZE(PRIT)) :: ZZW1, ZZW2, ZZW3 ! work arrays
@@ -123,10 +113,6 @@ WHERE ( (PRIT(:)>XRTMIN(4)) .AND. (PRST(:)>XRTMIN(5)) .AND. LDCOMPUTE(:) )
END WHERE
!
!
-PA_RI(:) = PA_RI(:) + P_RI_AGGS(:)
-PA_CI(:) = PA_CI(:) + P_CI_AGGS(:)
-PA_RS(:) = PA_RS(:) - P_RI_AGGS(:)
-!
!-------------------------------------------------------------------------------
!
END SUBROUTINE LIMA_ICE_AGGREGATION_SNOW
diff --git a/src/MNH/lima_ice_deposition.f90 b/src/MNH/lima_ice_deposition.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bfa9bd881a029199e3ab92d357d95021a9702110
--- /dev/null
+++ b/src/MNH/lima_ice_deposition.f90
@@ -0,0 +1,174 @@
+!MNH_LIC Copyright 2013-2018 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.
+! #####################
+ MODULE MODI_LIMA_ICE_DEPOSITION
+! #####################
+!
+INTERFACE
+ SUBROUTINE LIMA_ICE_DEPOSITION (PTSTEP, LDCOMPUTE, &
+ PRHODREF, PSSI, PAI, PCJ, PLSFACT, &
+ PRIT, PCIT, PLBDI, &
+ P_TH_DEPI, P_RI_DEPI, &
+ P_RI_CNVS, P_CI_CNVS )
+!
+REAL, INTENT(IN) :: PTSTEP
+LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
+!
+REAL, DIMENSION(:), INTENT(IN) :: PRHODREF! Reference density
+REAL, DIMENSION(:), INTENT(IN) :: PSSI ! abs. pressure at time t
+REAL, DIMENSION(:), INTENT(IN) :: PAI ! abs. pressure at time t
+REAL, DIMENSION(:), INTENT(IN) :: PCJ ! abs. pressure at time t
+REAL, DIMENSION(:), INTENT(IN) :: PLSFACT ! abs. pressure at time t
+!
+REAL, DIMENSION(:), INTENT(IN) :: PRIT ! Cloud ice m.r. at t
+!
+REAL, DIMENSION(:), INTENT(IN) :: PCIT ! Ice crystal C. at t
+!
+REAL, DIMENSION(:), INTENT(IN) :: PLBDI ! Graupel m.r. at t
+!
+REAL, DIMENSION(:), INTENT(INOUT) :: P_TH_DEPI
+REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_DEPI
+REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_CNVS
+REAL, DIMENSION(:), INTENT(INOUT) :: P_CI_CNVS
+!
+END SUBROUTINE LIMA_ICE_DEPOSITION
+END INTERFACE
+END MODULE MODI_LIMA_ICE_DEPOSITION
+!
+! ##########################################################################
+SUBROUTINE LIMA_ICE_DEPOSITION (PTSTEP, LDCOMPUTE, &
+ PRHODREF, PSSI, PAI, PCJ, PLSFACT, &
+ PRIT, PCIT, PLBDI, &
+ P_TH_DEPI, P_RI_DEPI, &
+ P_RI_CNVS, P_CI_CNVS )
+! ##########################################################################
+!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to compute the microphysical sources
+!! for slow cold processes :
+!! - conversion of snow to ice
+!! - deposition of vapor on snow
+!! - conversion of ice to snow (Harrington 1995)
+!!
+!!
+!! AUTHOR
+!! ------
+!! J.-M. Cohard * Laboratoire d'Aerologie*
+!! J.-P. Pinty * Laboratoire d'Aerologie*
+!! S. Berthet * Laboratoire d'Aerologie*
+!! B. Vié * CNRM *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 15/03/2018
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAM_LIMA, ONLY : XRTMIN, XCTMIN, XALPHAI, XALPHAS, XNUI, XNUS
+USE MODD_PARAM_LIMA_COLD, ONLY : XCXS, XCCS, &
+ XLBDAS_MAX, XDSCNVI_LIM, XLBDASCNVI_MAX, &
+ XC0DEPSI, XC1DEPSI, XR0DEPSI, XR1DEPSI, &
+ XSCFAC, X1DEPS, X0DEPS, XEX1DEPS, XEX0DEPS, &
+ XDICNVS_LIM, XLBDAICNVS_LIM, &
+ XC0DEPIS, XC1DEPIS, XR0DEPIS, XR1DEPIS, &
+ XCOLEXIS, XAGGS_CLARGE1, XAGGS_CLARGE2, &
+ XAGGS_RLARGE1, XAGGS_RLARGE2, &
+ XDI, X0DEPI, X2DEPI
+
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+REAL, INTENT(IN) :: PTSTEP
+LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
+!
+REAL, DIMENSION(:), INTENT(IN) :: PRHODREF! Reference density
+REAL, DIMENSION(:), INTENT(IN) :: PSSI ! abs. pressure at time t
+REAL, DIMENSION(:), INTENT(IN) :: PAI ! abs. pressure at time t
+REAL, DIMENSION(:), INTENT(IN) :: PCJ ! abs. pressure at time t
+REAL, DIMENSION(:), INTENT(IN) :: PLSFACT ! abs. pressure at time t
+!
+REAL, DIMENSION(:), INTENT(IN) :: PRIT ! Cloud ice m.r. at t
+!
+REAL, DIMENSION(:), INTENT(IN) :: PCIT ! Ice crystal C. at t
+!
+REAL, DIMENSION(:), INTENT(IN) :: PLBDI ! Graupel m.r. at t
+!
+REAL, DIMENSION(:), INTENT(INOUT) :: P_TH_DEPI
+REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_DEPI
+REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_CNVS
+REAL, DIMENSION(:), INTENT(INOUT) :: P_CI_CNVS
+!
+!* 0.2 Declarations of local variables :
+!
+LOGICAL, DIMENSION(SIZE(PRHODREF)) :: GMICRO ! Computations only where necessary
+REAL, DIMENSION(SIZE(PRHODREF)) :: ZZW, ZZW2, ZZX ! Work array
+!
+!
+!-------------------------------------------------------------------------------
+!
+P_TH_DEPI(:) = 0.
+P_RI_DEPI(:) = 0.
+P_RI_CNVS(:) = 0.
+P_CI_CNVS(:) = 0.
+!
+! Physical limitations
+!
+!
+! Looking for regions where computations are necessary
+!
+GMICRO(:) = LDCOMPUTE(:) .AND. PRIT(:)>XRTMIN(4)
+!
+!
+WHERE( GMICRO )
+!
+!
+!* 2.2 Deposition of water vapor on r_i: RVDEPI
+! -----------------------------------------------
+!
+!
+ ZZW(:) = 0.0
+ WHERE ( (PRIT(:)>XRTMIN(4)) .AND. (PCIT(:)>XCTMIN(4)) )
+ ZZW(:) = ( PSSI(:) / PAI(:) ) * PCIT(:) * &
+ ( X0DEPI/PLBDI(:)+X2DEPI*PCJ(:)*PCJ(:)/PLBDI(:)**(XDI+2.0) )
+ END WHERE
+!
+ P_RI_DEPI(:) = ZZW(:)
+!!$ P_TH_DEPI(:) = P_RI_DEPI(:) * PLSFACT(:)
+!
+!!$ PA_TH(:) = PA_TH(:) + P_TH_DEPI(:)
+!!$ PA_RV(:) = PA_RV(:) - P_RI_DEPI(:)
+!!$ PA_RI(:) = PA_RI(:) + P_RI_DEPI(:)
+!
+!
+!* 2.3 Conversion of pristine ice to r_s: RICNVS
+! ------------------------------------------------
+!
+!
+ ZZW(:) = 0.0
+ ZZW2(:) = 0.0
+ WHERE ( (PLBDI(:)<XLBDAICNVS_LIM) .AND. (PCIT(:)>XCTMIN(4)) &
+ .AND. (PSSI(:)>0.0) )
+ ZZW(:) = (PLBDI(:)*XDICNVS_LIM)**(XALPHAI)
+ ZZX(:) = ( PSSI(:)/PAI(:) )*PCIT(:) * (ZZW(:)**XNUI) *EXP(-ZZW(:))
+!
+ ZZW(:) = ( XR0DEPIS + XR1DEPIS*PCJ(:) )*ZZX(:)
+!
+ ZZW2(:) = ZZW(:) * (XC0DEPIS+XC1DEPIS*PCJ(:)) / (XR0DEPIS+XR1DEPIS*PCJ(:))
+ END WHERE
+!
+P_RI_CNVS(:) = - ZZW(:)
+P_CI_CNVS(:) = - ZZW2(:)
+!
+!
+END WHERE
+!
+!
+END SUBROUTINE LIMA_ICE_DEPOSITION
diff --git a/src/MNH/lima_init_ccn_activation_spectrum.f90 b/src/MNH/lima_init_ccn_activation_spectrum.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0f02782e820c6210965edb74b77d9ade24fab8ef
--- /dev/null
+++ b/src/MNH/lima_init_ccn_activation_spectrum.f90
@@ -0,0 +1,453 @@
+! ####################
+ MODULE MODI_LIMA_INIT_CCN_ACTIVATION_SPECTRUM
+INTERFACE
+ SUBROUTINE LIMA_INIT_CCN_ACTIVATION_SPECTRUM (CTYPE,XD,XSIGMA,XLIMIT_FACTOR,XK,XMU,XBETA,XKAPPA)
+ !
+ CHARACTER(LEN=*), INTENT(IN) :: CTYPE ! Aerosol type
+ REAL, INTENT(IN) :: XD ! Aerosol PSD modal diameter
+ REAL, INTENT(IN) :: XSIGMA ! Aerosol PSD width
+ REAL, INTENT(OUT) :: XLIMIT_FACTOR ! C/Naer
+ REAL, INTENT(OUT) :: XK ! k
+ REAL, INTENT(OUT) :: XMU ! mu
+ REAL, INTENT(OUT) :: XBETA ! beta
+ REAL, INTENT(OUT) :: XKAPPA ! kappa
+!
+ END SUBROUTINE LIMA_INIT_CCN_ACTIVATION_SPECTRUM
+END INTERFACE
+END MODULE MODI_LIMA_INIT_CCN_ACTIVATION_SPECTRUM
+! ####################
+!
+! #############################################################
+ SUBROUTINE LIMA_INIT_CCN_ACTIVATION_SPECTRUM (CTYPE,XD,XSIGMA,XLIMIT_FACTOR,XK,XMU,XBETA,XKAPPA)
+! #############################################################
+
+!!
+!!
+!! PURPOSE
+!! -------
+!!
+!! Compute mu, k and beta parameters of the activation spectrum based on CCN
+!! characteristics (type and PSD)
+!!
+!!
+!! AUTHOR
+!! ------
+!! J.-P. Pinty * Laboratoire d'Aerologie*
+!! S. Berthet * Laboratoire d'Aerologie*
+!! B. Vié * Laboratoire d'Aerologie*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original ??/??/13
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CST, ONLY : XMV, XAVOGADRO, XBOLTZ, XRHOLW
+!
+USE MODI_GAMMA_INC
+USE MODI_HYPGEO
+USE MODI_HYPSER
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+CHARACTER(LEN=*), INTENT(IN) :: CTYPE ! Aerosol type
+REAL, INTENT(IN) :: XD ! Aerosol PSD modal diameter
+REAL, INTENT(IN) :: XSIGMA ! Aerosol PSD width
+REAL, INTENT(OUT) :: XLIMIT_FACTOR ! C/Naer
+REAL, INTENT(OUT) :: XK ! k
+REAL, INTENT(OUT) :: XMU ! mu
+REAL, INTENT(OUT) :: XBETA ! beta
+REAL, INTENT(OUT) :: XKAPPA ! kappa
+!
+!* 0.2 Declarations of local variables :
+!
+INTEGER, PARAMETER :: M = 1000 ! Number of points (S,Nccn) used to fit the spectra
+INTEGER, PARAMETER :: N = 3 ! Number of parameters to adjust
+REAL, DIMENSION(N) :: PARAMS ! Parameters to adjust by the LM algorithm (k, mu, beta)
+REAL, DIMENSION(M) :: FVEC ! Array to store the distance between theoretical and fitted spectra
+INTEGER :: IFLAG !
+INTEGER :: INFO !
+REAL :: TOL = 1.E-16 ! Fit precision required
+!
+INTEGER :: II, IJ ! Loop indices
+!
+REAL :: XW !
+REAL :: XDDRY = 0.1E-6 ! Dry diameter for which to compute Scrit
+REAL :: XSCRIT ! Scrit for dry diameter XDDRY
+REAL :: XMIN = 0.1E-6 ! minimum diameter for root search (m)
+REAL :: XMAX = 10.E-6 ! maximum diameter for root search (m)
+REAL :: XPREC = 1.E-8 ! precision wanted for root (m)
+!
+!REAL :: XKAPPA ! kappa coefficient
+REAL, DIMENSION(M) :: XS ! saturation ratio (S=1.01 for a 1% supersaturation)
+REAL, DIMENSION(M) :: XDCRIT ! critical diameters (m) for the chosen S values
+REAL, DIMENSION(M) :: XNCCN ! fraction of the aerosols larger than XDCRIT (ie activable)
+REAL, DIMENSION(1) :: XT ! temperature
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Select kappa value based on CTYPE
+! ---------------------------------
+!
+! Kappa values are from Petters and Kreidenweis (2007), table 1.
+!
+SELECT CASE (CTYPE)
+CASE('NH42SO4','C') ! Ammonium sulfate
+ XKAPPA = 0.61
+CASE('NH4NO3') ! Ammonium nitrate
+ XKAPPA = 0.67
+CASE('NaCl','M') ! Sea Salt
+ XKAPPA = 1.28
+CASE('H2SO4') ! Sulfuric acid
+ XKAPPA = 0.90
+CASE('NaNO3') ! Sodium nitrate
+ XKAPPA = 0.88
+CASE('NaHSO4') ! Sodium bisulfate
+ XKAPPA = 0.91
+CASE('Na2SO4') ! Sodium sulfate
+ XKAPPA = 0.80
+CASE('NH43HSO42') ! Letovicite (rare ammonium sulfate mineral)
+ XKAPPA = 0.65
+CASE('SOA') ! Secondary organic aerosol (alpha-pinene, beta-pinene)
+ XKAPPA = 0.1
+CASE DEFAULT
+ XKAPPA = 1.
+END SELECT
+!
+!XT = (/ 270., 271., 272., 273., 274., 275., 276., 277., 278., 279., 280., 281., 282., 283., 284., 285., 286., 287., 288., 289. /)
+XT = (/ 280. /)
+
+!
+! Initialize supersaturation values (in %)
+!
+DO II=1, SIZE(XS)
+ XS(II)=EXP( LOG(10.**(-3.)) + REAL(II) / REAL(SIZE(XS)) * (LOG(10.**2.)-LOG(10.**(-3.))) )
+END DO
+
+DO IJ=1, SIZE(XT)
+!
+!* 2. Compute Nccn(s) for several supersaturation values
+! --------------------------------------------------
+!
+! Get the value of Scrit at Ddry=0.1 micron
+!
+ XDDRY = XD
+ XMIN = XD
+ XMAX = XD*10.
+ XPREC = XD/100.
+ XW = 4 * 0.072 * XMV / XAVOGADRO / XBOLTZ / XT(IJ) / XRHOLW
+ XSCRIT = ZRIDDR(XMIN,XMAX,XPREC,XDDRY,XKAPPA,XT(IJ)) ! wet diameter at Scrit
+ XSCRIT = (XSCRIT**3-XDDRY**3) * EXP(XW/XSCRIT) / (XSCRIT**3-(1-XKAPPA)*XDDRY**3) ! Saturation ratio at Scrit
+ XSCRIT = (XSCRIT - 1.) * 100. ! Scrit (in %)
+!
+! Get the XDCRIT values for XS using the approx.
+! ln(100*(Sw))~Dcrit^(-3/2) where Sw is in % (Sw=1 for a 1% supersaturation)
+!
+ XW = XDDRY * XSCRIT**0.66 ! "a" factor in Ddry_crit = a*S**-0.66
+ XDCRIT(:) = XW * XS(:)**(-0.66) ! Ddry_crit for each value of S
+!
+! Compute Nccn(S) as the incomplete integral of n(D) from 0 to Ddry_crit(S)
+!
+ DO II=1, SIZE(XS)
+ XNCCN(II) = 1- ( 0.5 + SIGN(0.5,XDCRIT(II)-XD) * GAMMA_INC(0.5,(LOG(XDCRIT(II)/XD)/SQRT(2.)/LOG(XSIGMA))**2) )
+ END DO
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. Compute C, k, mu, beta, using the Levenberg-Marquardt algorithm
+! ---------------------------------------------------------------
+!
+ PARAMS(1:3) = (/ 1., 1., 1000. /)
+ IFLAG = 1
+ call lmdif1 ( DISTANCE, M, N, PARAMS, FVEC, TOL, INFO )
+!
+ XLIMIT_FACTOR = gamma(PARAMS(2))*PARAMS(3)**(PARAMS(1)/2)/gamma(1+PARAMS(1)/2)/gamma(PARAMS(2)-PARAMS(1)/2)
+ XK = PARAMS(1)
+ XMU = PARAMS(2)
+ XBETA = PARAMS(3)
+!
+END DO ! loop on temperatures
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. Functions used to compute Scrit at Ddry=0.1 micron
+! --------------------------------------------------
+!
+CONTAINS
+!
+!------------------------------------------------------------------------------
+!
+ FUNCTION ZRIDDR(PX1,PX2,PXACC,XDDRY,XKAPPA,XT) RESULT(PZRIDDR)
+!
+!
+!!**** *ZRIDDR* - iterative algorithm to find root of a function
+!!
+!!
+!! PURPOSE
+!! -------
+!! The purpose of this function is to find the root of a given function
+!! the arguments are the brackets bounds (the interval where to find the root)
+!! the accuracy needed and the input parameters of the given function.
+!! Using Ridders' method, return the root of a function known to lie between
+!! PX1 and PX2. The root, returned as PZRIDDR, will be refined to an approximate
+!! accuracy PXACC.
+!!
+!!** METHOD
+!! ------
+!! Ridders' method
+!!
+!! EXTERNAL
+!! --------
+!! FUNCSMAX
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!! NUMERICAL RECIPES IN FORTRAN 77: THE ART OF SCIENTIFIC COMPUTING
+!! (ISBN 0-521-43064-X)
+!! Copyright (C) 1986-1992 by Cambridge University Press.
+!! Programs Copyright (C) 1986-1992 by Numerical Recipes Software.
+!!
+!! AUTHOR
+!! ------
+!! Frederick Chosson *CERFACS*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 12/07/07
+!! S.BERTHET 2008 vectorization
+!------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+!
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments and result
+!
+REAL, INTENT(INOUT) :: PX1, PX2, PXACC
+REAL, INTENT(IN) :: XDDRY, XKAPPA, XT
+REAL :: PZRIDDR
+!
+!* 0.2 declarations of local variables
+!
+!
+INTEGER, PARAMETER :: MAXIT=60
+REAL, PARAMETER :: UNUSED=0.0 !-1.11e30
+REAL :: fh,fl, fm,fnew
+REAL :: s,xh,xl,xm,xnew
+INTEGER :: j, JL
+!
+PZRIDDR= 999999.
+fl = DSDD(PX1,XDDRY,XKAPPA,XT)
+fh = DSDD(PX2,XDDRY,XKAPPA,XT)
+!
+100 if ((fl > 0.0 .and. fh < 0.0) .or. (fl < 0.0 .and. fh > 0.0)) then
+ xl = PX1
+ xh = PX2
+ do j=1,MAXIT
+ xm = 0.5*(xl+xh)
+ fm = DSDD(xm,XDDRY,XKAPPA,XT)
+ s = sqrt(fm**2-fl*fh)
+ if (s == 0.0) then
+ GO TO 101
+ endif
+ xnew = xm+(xm-xl)*(sign(1.0,fl-fh)*fm/s)
+ if (abs(xnew - PZRIDDR) <= PXACC) then
+ GO TO 101
+ endif
+ PZRIDDR = xnew
+ fnew = DSDD(PZRIDDR,XDDRY,XKAPPA,XT)
+ if (fnew == 0.0) then
+ GO TO 101
+ endif
+ if (sign(fm,fnew) /= fm) then
+ xl =xm
+ fl=fm
+ xh =PZRIDDR
+ fh=fnew
+ else if (sign(fl,fnew) /= fl) then
+ xh =PZRIDDR
+ fh=fnew
+ else if (sign(fh,fnew) /= fh) then
+ xl =PZRIDDR
+ fl=fnew
+ else if (PX2 .lt. 0.05) then
+ PX2 = PX2 + 1.0E-2
+ PRINT*, 'PX2 ALWAYS too small, we put a greater one : PX2 =',PX2
+ fh = DSDD(PX2,XDDRY,XKAPPA,XT)
+ go to 100
+ STOP
+ end if
+ if (abs(xh-xl) <= PXACC) then
+ GO TO 101
+ endif
+ end do
+ STOP
+ else if (fl == 0.0) then
+ PZRIDDR=PX1
+ else if (fh == 0.0) then
+ PZRIDDR=PX2
+ else if (PX2 .lt. 0.05) then
+ PX2 = PX2 + 1.0E-2
+ PRINT*, 'PX2 too small, we put a greater one : PX2 =',PX2
+ fh = DSDD(PX2,XDDRY,XKAPPA,XT)
+ go to 100
+ else
+ PZRIDDR=0.0
+ go to 101
+ end if
+!
+101 END FUNCTION ZRIDDR
+!
+!------------------------------------------------------------------------------
+!
+ FUNCTION DSDD(XD,XDDRY,XKAPPA, XT) RESULT(DS)
+!!
+!! PURPOSE
+!! -------
+!! Derivative of S(D) from Petters and Kreidenweis 2007 (eq. 6) to get Dcrit and Scrit
+!!
+!!** METHOD
+!! ------
+!! This function is called by zriddr
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!! Petters and Kreidenweis, 2007: "A single parameter representation of hygroscopic
+!! growth and cloud condensation nucleus activity",
+!! ACP, 7, 1961-1971
+!!
+!! AUTHOR
+!! ------
+!! Benoit Vie *CNRM*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 13/11/17
+!!
+!------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+!
+ USE MODD_CST, ONLY : XMV, XAVOGADRO, XBOLTZ, XRHOLW
+!
+ IMPLICIT NONE
+!
+!* 0.1 declarations of arguments and result
+!
+ REAL, INTENT(IN) :: XD ! supersaturation is already in no units
+ REAL, INTENT(IN) :: XDDRY ! supersaturation is already in no units
+ REAL, INTENT(IN) :: XKAPPA ! supersaturation is already in no units
+ REAL, INTENT(IN) :: XT ! supersaturation is already in no units
+!
+ REAL :: DS ! result
+!
+!* 0.2 declarations of local variables
+!
+ REAL :: XA ! factor inside the exponential
+!
+ XA = 4 * 0.072 * XMV / XAVOGADRO / XBOLTZ / XT / XRHOLW
+ DS = (XD**3-XDDRY**3) * (XD**3-(1-XKAPPA)*XDDRY**3) * XA - 3. * XKAPPA * XD**4 * XDDRY**3
+ DS = DS * EXP(XA/XD) / (XD**3-(1-XKAPPA)*XDDRY**3)**2
+!
+END FUNCTION DSDD
+!
+!-------------------------------------------------------------------------------
+!
+!* 7. Functions used to fit the CCN activation spectra with C s**k F()
+! ----------------------------------------------------------------
+!
+ SUBROUTINE DISTANCE(M,N,X,FVEC,IFLAG)
+!!
+!! PURPOSE
+!! -------
+!! Derivative of S(D) from Petters and Kreidenweis 2007 (eq. 6) to get Dcrit and Scrit
+!!
+!!** METHOD
+!! ------
+!! This function is called by zriddr
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!! Petters and Kreidenweis, 2007: "A single parameter representation of hygroscopic
+!! growth and cloud condensation nucleus activity",
+!! ACP, 7, 1961-1971
+!!
+!! AUTHOR
+!! ------
+!! Benoit Vie *CNRM*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 13/11/17
+!!
+!------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+!
+!* 0.1 declarations of arguments and result
+!
+ integer M
+ integer N
+ real X(N)
+ real FVEC(M)
+ integer IFLAG
+!
+!* 0.2 declarations of local variables
+!
+ integer I
+ real C
+ real ZW, ZW2
+!
+ ! print *, "X = ", X
+ IF ( ANY(X .LT.0.) .OR. X(1).gt.2*X(2)) THEN
+ FVEC(:) = 999999.
+ ELSE
+ C=gamma(X(2))*X(3)**(X(1)/2)/gamma(1+X(1)/2)/gamma(X(2)-X(1)/2)
+ DO I=1, M
+ ! XS in "no units", ie XS=0.01 for a 1% suersaturation
+ ! ZW= C * (XS(I)/100)**X(1) * HYPGEO(X(2),X(1)/2,X(1)/2+1,X(3),XS(I)/100)
+ ZW= C * (XS(I))**X(1) * HYPGEO(X(2),X(1)/2,X(1)/2+1,X(3),XS(I))
+!!$ IF (X(3)*(XS(I)/100)**2 .LT. 0.98) THEN
+!!$ CALL HYPSER(X(2),X(1)/2,X(1)/2+1,-X(3)*(XS(I)/100)**2,ZW2)
+!!$ print *, "args= ", X(2), X(1)/2, X(1)/2+1, -X(3)*(XS(I)/100)**2, " hypser = ", ZW2
+!!$ CALL HYPSER(27.288,0.82/2,0.82/2+1,-38726*(0.5/100)**2,ZW2)
+!!$ print *, "args= ", 27.288, 0.82/2, 0.82/2+1, -38726*(0.5/100)**2, " hypser = ", ZW2
+!!$ END IF
+ ! print *, I, XS(I), C, ZW, XNCCN(I)
+ IF ( ZW.GT.0. .AND. XNCCN(I).GT.0.) THEN
+ FVEC(I) = LOG(ZW) - LOG(XNCCN(I))
+ ELSE
+ FVEC(I) = 0.
+ END IF
+ !FVEC(I) = LOG(MAX(ZW,1.E-24)) - LOG(MAX(XNCCN(I),1.E-24))
+ !FVEC(I) = ZW - XNCCN(I)
+ END DO
+ END IF
+! print *, "distance : ", SUM(FVEC*FVEC)
+!
+ END SUBROUTINE DISTANCE
+!
+!------------------------------------------------------------------------------
+END SUBROUTINE LIMA_INIT_CCN_ACTIVATION_SPECTRUM
diff --git a/src/MNH/lima_inst_procs.f90 b/src/MNH/lima_inst_procs.f90
index ff8dc1f04df51daa9018d3cf8a1778ce4bde2294..26b8e96a6a5b520fe2b5d85dedc62e642ca88925 100644
--- a/src/MNH/lima_inst_procs.f90
+++ b/src/MNH/lima_inst_procs.f90
@@ -17,7 +17,8 @@ INTERFACE
P_TH_IMLT, P_RC_IMLT, P_CC_IMLT, & ! ice melting (IMLT) : rc, Nc, ri=-rc, Ni=-Nc, th, IFNF, IFNA
PB_TH, PB_RV, PB_RC, PB_RR, PB_RI, PB_RG, &
PB_CC, PB_CR, PB_CI, &
- PB_IFNN )
+ PB_IFNN, &
+ PCF1D, PIF1D, PPF1D )
!
REAL, INTENT(IN) :: PTSTEP ! Time step
LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
@@ -59,6 +60,10 @@ REAL, DIMENSION(:) , INTENT(INOUT) :: PB_CR ! Cumulated concentration chan
REAL, DIMENSION(:) , INTENT(INOUT) :: PB_CI ! Cumulated concentration change (#/kg)
!
REAL, DIMENSION(:,:), INTENT(INOUT) :: PB_IFNN ! Cumulated concentration change (#/kg)
+!
+REAL, DIMENSION(:) , INTENT(INOUT) :: PCF1D ! Liquid cloud fraction
+REAL, DIMENSION(:) , INTENT(INOUT) :: PIF1D ! Ice cloud fraction
+REAL, DIMENSION(:) , INTENT(INOUT) :: PPF1D ! Precipitation fraction
!
END SUBROUTINE LIMA_INST_PROCS
END INTERFACE
@@ -76,7 +81,8 @@ SUBROUTINE LIMA_INST_PROCS (PTSTEP, LDCOMPUTE,
P_TH_IMLT, P_RC_IMLT, P_CC_IMLT, & ! ice melting (IMLT) : rc, Nc, ri=-rc, Ni=-Nc, th, IFNF, IFNA
PB_TH, PB_RV, PB_RC, PB_RR, PB_RI, PB_RG, &
PB_CC, PB_CR, PB_CI, &
- PB_IFNN )
+ PB_IFNN, &
+ PCF1D, PIF1D, PPF1D )
! ###########################################################################
!
!! PURPOSE
@@ -146,10 +152,14 @@ REAL, DIMENSION(:) , INTENT(INOUT) :: PB_CI ! Cumulated concentration chan
!
REAL, DIMENSION(:,:), INTENT(INOUT) :: PB_IFNN ! Cumulated concentration change (#/kg)
!
+REAL, DIMENSION(:) , INTENT(INOUT) :: PCF1D ! Liquid cloud fraction
+REAL, DIMENSION(:) , INTENT(INOUT) :: PIF1D ! Ice cloud fraction
+REAL, DIMENSION(:) , INTENT(INOUT) :: PPF1D ! Precipitation fraction
+!
!-------------------------------------------------------------------------------
!
IF (LWARM .AND. LRAIN) THEN
- CALL LIMA_DROPS_BREAK_UP (LDCOMPUTE, &
+ CALL LIMA_DROPS_BREAK_UP (LDCOMPUTE, & ! no dependance on CF, IF or PF
PCRT, PRRT, &
P_CR_BRKU, &
PB_CR )
@@ -158,7 +168,7 @@ END IF
!-------------------------------------------------------------------------------
!
IF (LCOLD .AND. LWARM .AND. LRAIN) THEN
- CALL LIMA_DROPS_HOM_FREEZING (PTSTEP, LDCOMPUTE, &
+ CALL LIMA_DROPS_HOM_FREEZING (PTSTEP, LDCOMPUTE, & ! no dependance on CF, IF or PF
PEXNREF, PPABST, &
PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
PCRT, &
@@ -169,12 +179,16 @@ END IF
!-------------------------------------------------------------------------------
!
IF (LCOLD .AND. LWARM) THEN
- CALL LIMA_ICE_MELTING (PTSTEP, LDCOMPUTE, &
- PEXNREF, PPABST, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
+ CALL LIMA_ICE_MELTING (PTSTEP, LDCOMPUTE, & ! no dependance on CF, IF or PF
+ PEXNREF, PPABST, & ! but ice fraction becomes cloud fraction
+ PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, & ! -> where ?
PCIT, PINT, &
P_TH_IMLT, P_RC_IMLT, P_CC_IMLT, &
PB_TH, PB_RC, PB_CC, PB_RI, PB_CI, PB_IFNN)
+ !
+ !PCF1D(:)=MAX(PCF1D(:),PIF1D(:))
+ !PIF1D(:)=0.
+ !
END IF
!
!-------------------------------------------------------------------------------
diff --git a/src/MNH/lima_meyers_nucleation.f90 b/src/MNH/lima_meyers_nucleation.f90
index 7798bd5d4d90d8cd81615ce516de228d55143ecb..879799e96f2af6336e6e98d823fd10cb63b0ffb1 100644
--- a/src/MNH/lima_meyers_nucleation.f90
+++ b/src/MNH/lima_meyers_nucleation.f90
@@ -13,7 +13,8 @@ INTERFACE
PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
PCCT, PCIT, PINT, &
P_TH_HIND, P_RI_HIND, P_CI_HIND, &
- P_TH_HINC, P_RC_HINC, P_CC_HINC )
+ P_TH_HINC, P_RC_HINC, P_CC_HINC, &
+ PICEFR )
!
REAL, INTENT(IN) :: PTSTEP
!
@@ -40,6 +41,8 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: P_TH_HINC
REAL, DIMENSION(:,:,:), INTENT(OUT) :: P_RC_HINC
REAL, DIMENSION(:,:,:), INTENT(OUT) :: P_CC_HINC
!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PICEFR
+!
END SUBROUTINE LIMA_MEYERS_NUCLEATION
END INTERFACE
END MODULE MODI_LIMA_MEYERS_NUCLEATION
@@ -50,7 +53,8 @@ END MODULE MODI_LIMA_MEYERS_NUCLEATION
PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
PCCT, PCIT, PINT, &
P_TH_HIND, P_RI_HIND, P_CI_HIND, &
- P_TH_HINC, P_RC_HINC, P_CC_HINC )
+ P_TH_HINC, P_RC_HINC, P_CC_HINC, &
+ PICEFR )
! #############################################################################
!!
!! PURPOSE
@@ -113,6 +117,8 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: P_TH_HINC
REAL, DIMENSION(:,:,:), INTENT(OUT) :: P_RC_HINC
REAL, DIMENSION(:,:,:), INTENT(OUT) :: P_CC_HINC
!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PICEFR
+!
!
!* 0.2 Declarations of local variables :
!
diff --git a/src/MNH/lima_mixrat_to_nconc.f90 b/src/MNH/lima_mixrat_to_nconc.f90
new file mode 100644
index 0000000000000000000000000000000000000000..15cdd6b426cbdbd8077855098f372b7ea776f746
--- /dev/null
+++ b/src/MNH/lima_mixrat_to_nconc.f90
@@ -0,0 +1,187 @@
+! ################################
+ MODULE MODI_LIMA_MIXRAT_TO_NCONC
+! ################################
+INTERFACE
+SUBROUTINE LIMA_MIXRAT_TO_NCONC(PPABST, PTHT, PRVT, PSVT)
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! Absolute pressure
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Potential temperature
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water Vapor mix. ratio
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PSVT ! Mixing ratios IN, conc. OUT
+!
+END SUBROUTINE LIMA_MIXRAT_TO_NCONC
+END INTERFACE
+END MODULE MODI_LIMA_MIXRAT_TO_NCONC
+!
+! ########################################################
+ SUBROUTINE LIMA_MIXRAT_TO_NCONC(PPABST, PTHT, PRVT, PSVT)
+! ########################################################
+!
+!
+!!**** *LIMA_MIXRAT_TO_NCONC* - converts CAMS aerosol mixing ratios into
+!! number concentrations
+!!
+!! PURPOSE
+!! -------
+!!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 23/01/16 (J.-P. Pinty)
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+!
+USE MODD_CST, ONLY : XP00, XMD, XMV, XRD, XCPD, XTT, XPI, XRHOLW, &
+ XALPW, XBETAW, XGAMW, XALPI, XBETAI, XGAMI
+USE MODD_NSV, ONLY : NSV_LIMA_CCN_FREE, NSV_LIMA_IFN_FREE
+USE MODD_PARAM_LIMA, ONLY : NMOD_CCN, NMOD_IFN, &
+ XR_MEAN_CCN, XLOGSIG_CCN, XRHO_CCN, &
+ XMDIAM_IFN, XSIGMA_IFN, XRHO_IFN, &
+ NSPECIE, XFRAC, &
+ CCCN_MODES, CIFN_SPECIES
+!
+IMPLICIT NONE
+!
+!* 0.1. Declaration of arguments
+! ------------------------
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! Absolute pressure
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Potential temperature
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water Vapor mix. ratio
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PSVT ! Mixing ratios IN, conc. OUT
+!
+!* 0.2 Declaration of local variables
+! ------------------------------
+!
+REAL,DIMENSION(SIZE(PTHT,1),SIZE(PTHT,2),SIZE(PTHT,3)) :: ZT ! Temperature
+REAL,DIMENSION(SIZE(PTHT,1),SIZE(PTHT,2),SIZE(PTHT,3)) :: ZREHU ! Relat. Humid.
+REAL,DIMENSION(SIZE(PTHT,1),SIZE(PTHT,2),SIZE(PTHT,3)) :: ZGROWTH_FACT
+REAL,DIMENSION(SIZE(PTHT,1),SIZE(PTHT,2),SIZE(PTHT,3)) :: ZRHO_CCN_WET
+REAL,DIMENSION(SIZE(PTHT,1),SIZE(PTHT,2),SIZE(PTHT,3)) :: ZWORK
+!
+INTEGER :: JLOC, JCCN, JIFN, JSPECIE
+REAL :: ZFACT_CCN, ZFACT_IFN
+!
+!----------------------------------------------------------------------
+!
+! Temperature to compute the relative humidity
+!
+ZT(:,:,:) = PTHT(:,:,:)*(PPABST(:,:,:)/XP00)**(XRD/XCPD)
+ZWORK(:,:,:) = PRVT(:,:,:)*PPABST(:,:,:)/((XMV/XMD)+PRVT(:,:,:))
+ ! water vapor partial pressure
+ZREHU(:,:,:) = ZWORK(:,:,:)/EXP( XALPW-XBETAW/ZT(:,:,:)-XGAMW*ALOG(ZT(:,:,:)) )
+ ! saturation over water
+WHERE ( ZT(:,:,:)<XTT )
+ ZREHU(:,:,:) = ZWORK(:,:,:)/EXP(XALPI-XBETAI/ZT(:,:,:)-XGAMI*ALOG(ZT(:,:,:)))
+ ! saturation over ice
+END WHERE
+ZREHU(:,:,:) = MIN( 0.99, MAX( 0.01,ZREHU(:,:,:) ) )
+!
+! All size distribution parameters are XLOGSIG_CCN and XR_MEAN_CCN (radii)
+! Treatment of the soluble aerosols (CCN)
+!
+! All CAMS aerosol mr are given for dry particles, except for sea-salt (given at Hu=80%)
+!
+!
+
+!IF( NAERO_TYPE=="CCN" ) THEN
+!
+! sea-salt, sulfate, hydrophilic (GADS data)
+!
+! NMOD_CCN=3
+ IF (.NOT.(ALLOCATED(XR_MEAN_CCN))) ALLOCATE(XR_MEAN_CCN(NMOD_CCN))
+ IF (.NOT.(ALLOCATED(XLOGSIG_CCN))) ALLOCATE(XLOGSIG_CCN(NMOD_CCN))
+ IF (.NOT.(ALLOCATED(XRHO_CCN))) ALLOCATE(XRHO_CCN(NMOD_CCN))
+ IF( CCCN_MODES=='CAMS_ACC') THEN
+ XR_MEAN_CCN(:) = (/ 0.2E-6 , 0.5E-6 , 0.4E-6 /)
+ XLOGSIG_CCN(:) = (/ 0.693 , 0.476 , 0.788 /)
+ XRHO_CCN(:) = (/ 2200. , 1700. , 1800. /)
+ END IF
+!
+ IF( CCCN_MODES=='CAMS_AIT') THEN
+ XR_MEAN_CCN(:) = (/ 0.2E-6 , 0.05E-6 , 0.02E-6 /)
+ XLOGSIG_CCN(:) = (/ 0.693 , 0.693 , 0.788 /)
+ XRHO_CCN(:) = (/ 2200. , 1700. , 1800. /)
+ END IF
+!
+DO JCCN = 1,NMOD_CCN
+!
+ JLOC = NSV_LIMA_CCN_FREE + JCCN-1 ! CCN free then CCN acti
+!
+ ZFACT_CCN = ( (0.75/XPI)*EXP(-4.5*(XLOGSIG_CCN(JCCN))**2) )/XR_MEAN_CCN(JCCN)**3
+!
+! JCCN=1 is for Sea Salt
+! JCCN=2 is for Sulphate
+! JCCN=3 is for Hydrophilic OC and BC (sulphate coating)
+!
+ IF( JCCN==1 ) THEN ! Sea salt : convert mass at Hu=80% to dry mass
+ PSVT(:,:,:,JLOC) = PSVT(:,:,:,JLOC) / 4.302
+ END IF
+!
+! compute the CCN number concentration
+!
+! Pourquoi 0.5* ?
+! PSVT(:,:,:,JLOC) =0.5* ZFACT_CCN*(PSVT(:,:,:,JLOC)/XRHO_CCN(JCCN)) ! Result
+ PSVT(:,:,:,JLOC) = ZFACT_CCN*(PSVT(:,:,:,JLOC)/XRHO_CCN(JCCN)) ! Result
+ ! is in #/Kg of dry air
+END DO
+!
+! All size distribution parameters are XSIGMA_IFN and XMDIAM_IFN (diameters)
+! Treatment of the insoluble aerosols (IFN)
+!
+!ELSE IF( NAERO_TYPE=="IFN" ) THEN
+!
+! dust, hydrophobic BIO+ORGA (GADS data)
+!
+! NMOD_IFN=2
+ NSPECIE=4
+ IF (.NOT.(ALLOCATED(XMDIAM_IFN))) ALLOCATE(XMDIAM_IFN(NSPECIE))
+ IF (.NOT.(ALLOCATED(XSIGMA_IFN))) ALLOCATE(XSIGMA_IFN(NSPECIE))
+ IF (.NOT.(ALLOCATED(XRHO_IFN))) ALLOCATE(XRHO_IFN(NSPECIE))
+ IF( CIFN_SPECIES=='CAMS_ACC') THEN
+ XMDIAM_IFN = (/0.8E-6, 3.0E-6, 0.04E-6, 0.8E-6 /)
+ XSIGMA_IFN = (/2.0, 2.15, 2.0, 2.2 /)
+ XRHO_IFN = (/2600., 2600., 1000., 2000. /)
+ END IF
+ IF( CIFN_SPECIES=='CAMS_AIT') THEN
+ XMDIAM_IFN = (/0.8E-6, 3.0E-6, 0.04E-6, 0.04E-6/)
+ XSIGMA_IFN = (/2.0, 2.15, 2.0, 2.2 /)
+ XRHO_IFN = (/2600., 2600., 1000., 1800./)
+ END IF
+ IF (.NOT.(ALLOCATED(XFRAC))) ALLOCATE(XFRAC(NSPECIE,NMOD_IFN))
+ XFRAC(1,1)=1.0
+ XFRAC(2,1)=0.0
+ XFRAC(3,1)=0.0
+ XFRAC(4,1)=0.0
+ XFRAC(1,2)=0.0
+ XFRAC(2,2)=0.0
+ XFRAC(3,2)=0.0
+ XFRAC(4,2)=1.0
+!
+DO JIFN = 1,NMOD_IFN
+!
+! compute the number concentration assuming no deposition of water
+! IFN are considered as insoluble dry aerosols
+!
+ ZFACT_IFN = 0.0
+ DO JSPECIE = 1,NSPECIE ! Conversion factor is weighted by XFRAC
+ ZFACT_IFN = ZFACT_IFN + XFRAC(JSPECIE,JIFN)* &
+ ( (6/XPI)*EXP(-(9.0/2.0)*LOG(XSIGMA_IFN(JSPECIE))**2) ) / &
+ ( XRHO_IFN(JSPECIE)*XMDIAM_IFN(JSPECIE)**3 )
+ END DO
+ JLOC = NSV_LIMA_IFN_FREE + JIFN-1 ! IFN free then IFN nucl
+! Pourquoi 0.5* ?
+! PSVT(:,:,:,JLOC) = 0.5* ZFACT_IFN*PSVT(:,:,:,JLOC) ! Result is in #/Kg of dry air
+ PSVT(:,:,:,JLOC) = ZFACT_IFN*PSVT(:,:,:,JLOC) ! Result is in #/Kg of dry air
+END DO
+!
+END SUBROUTINE LIMA_MIXRAT_TO_NCONC
diff --git a/src/MNH/lima_notadjust.f90 b/src/MNH/lima_notadjust.f90
new file mode 100644
index 0000000000000000000000000000000000000000..deea40102cc8d1d79199e4b5a7ecc3dfb37a8b2e
--- /dev/null
+++ b/src/MNH/lima_notadjust.f90
@@ -0,0 +1,592 @@
+!MNH_LIC Copyright 1994-2018 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.
+!-----------------------------------------------------------------
+! ##########################
+ MODULE MODI_LIMA_NOTADJUST
+! ##########################
+!
+INTERFACE
+!
+ SUBROUTINE LIMA_NOTADJUST(KRR, KMI, KTCOUNT, TPFILE, HRAD, &
+ PTSTEP, PRHODJ, PPABSM, PPABST, PRHODREF, PEXNREF, PZZ, &
+ PTHT,PRT, PSVT, PTHS, PRS,PSVS, PCLDFR, PSRCS )
+!
+USE MODD_IO, ONLY: TFILEDATA
+!
+INTEGER, INTENT(IN) :: KRR ! Number of moist variables
+INTEGER, INTENT(IN) :: KMI ! Model index
+INTEGER, INTENT(IN) :: KTCOUNT ! Number of moist variables
+TYPE(TFILEDATA), INTENT(IN) :: TPFILE ! Output file
+CHARACTER(len=4), INTENT(IN) :: HRAD ! Radiation scheme name
+REAL, INTENT(IN) :: PTSTEP ! Double Time step
+ ! (single if cold start)
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSM ! Absolute Pressure at t-dt
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! Absolute Pressure at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Reference density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Reference density
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! m.r. at t
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PSVT ! Concentrations source
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRS ! m.r. source
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PSVS ! Concentrations source
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PSRCS ! Second-order flux
+ ! s'rc'/2Sigma_s2 at time t+1
+ ! multiplied by Lambda_3
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PCLDFR ! Cloud fraction
+!
+!
+END SUBROUTINE LIMA_NOTADJUST
+!
+END INTERFACE
+!
+END MODULE MODI_LIMA_NOTADJUST
+!
+! ################################################################################
+ SUBROUTINE LIMA_NOTADJUST(KRR, KMI, KTCOUNT, TPFILE, HRAD, &
+ PTSTEP, PRHODJ, PPABSM, PPABST, PRHODREF, PEXNREF, PZZ, &
+ PTHT,PRT, PSVT, PTHS, PRS,PSVS, PCLDFR, PSRCS )
+! ################################################################################
+!
+!!**** * - compute pseudo-prognostic of supersaturation according to Thouron
+! et al. 2012
+!! PURPOSE
+!! -------
+!!
+!!** METHOD
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Thouron, O., J.-L. Brenguier, and F. Burnet, Supersaturation calculation
+!! in large eddy simulation models for prediction of the droplet number
+!! concentration, Geosci. Model Dev., 5, 761-772, 2012.
+!!
+!! AUTHOR
+!! ------
+!! B.Vie forked from lima_adjust.f90
+!!
+!! MODIFICATIONS
+!! -------------
+!
+!* 0. DECLARATIONS
+!
+use modd_budget, only: lbu_enable, nbumod, &
+ lbudget_th, lbudget_rv, lbudget_rc, lbudget_ri, lbudget_sv, &
+ NBUDGET_TH, NBUDGET_RV, NBUDGET_RC, NBUDGET_RI, NBUDGET_SV1, &
+ tbudgets
+USE MODD_CONF
+USE MODD_CST
+USE MODD_FIELD, ONLY: TFIELDDATA,TYPEREAL
+USE MODD_IO, ONLY: TFILEDATA
+USE MODD_LUNIT_n, ONLY: TLUOUT
+USE MODD_NSV
+USE MODD_PARAMETERS
+USE MODD_PARAM_LIMA
+USE MODD_PARAM_LIMA_COLD
+
+!
+use mode_budget, only: Budget_store_init, Budget_store_end
+USE MODE_IO_FIELD_WRITE, only: IO_Field_write
+USE MODE_MSG
+use mode_tools, only: Countjv
+use mode_tools_ll, only: GET_INDICE_ll
+!
+USE MODI_PROGNOS_LIMA
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+!
+INTEGER, INTENT(IN) :: KRR ! Number of moist variables
+INTEGER, INTENT(IN) :: KMI ! Model index
+INTEGER, INTENT(IN) :: KTCOUNT ! Number of moist variables
+TYPE(TFILEDATA), INTENT(IN) :: TPFILE ! Output file
+CHARACTER(len=4), INTENT(IN) :: HRAD ! Radiation scheme name
+REAL, INTENT(IN) :: PTSTEP ! Double Time step
+ ! (single if cold start)
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSM ! Absolute Pressure at t-dt
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! Absolute Pressure at t
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Reference density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference density
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Reference density
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! m.r. at t
+REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PSVT ! Concentrations source
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRS ! m.r. source
+REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PSVS ! Concentrations source
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PSRCS ! Second-order flux
+ ! s'rc'/2Sigma_s2 at time t+1
+ ! multiplied by Lambda_3
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PCLDFR ! Cloud fraction
+!
+!
+!* 0.2 Declarations of local variables :
+!
+!
+!
+INTEGER :: IRESP ! Return code of FM routines
+INTEGER :: ILUOUT ! Logical unit of output listing
+
+! For Activation :
+LOGICAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
+ :: GNUCT, GMICRO ! Test where to compute the HEN process
+INTEGER , DIMENSION(SIZE(GNUCT)) :: I1,I2,I3 ! Used to replace the COUNT
+INTEGER :: JL, JMOD ! and PACK intrinsics
+REAL, DIMENSION(:), ALLOCATABLE ::ZPRES,ZRHOD,ZRR,ZTT,ZRV,ZRC,ZS0,ZCCL, &
+ ZZDZ, ZZLV, ZZCPH, &
+ ZRVT, ZRIT, ZCIT, ZRVS, ZRIS, ZCIS, &
+ ZTHS, ZRHODREF, ZZT, ZEXNREF, ZZW, &
+ ZLSFACT, ZRVSATI, ZRVSATI_PRIME, &
+ ZDELTI, ZAI, ZKA, ZDV, ZITI, ZAII, ZDEP, &
+ ZCJ
+!
+INTEGER :: INUCT
+INTEGER :: IMICRO
+INTEGER :: IIB ! Define the domain where
+INTEGER :: IIE ! the microphysical sources have to be computed
+INTEGER :: IJB !
+INTEGER :: IJE !
+INTEGER :: IKB !
+INTEGER :: IKE !
+
+REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) ::&
+ ZEXNT,ZEXNS,ZT,ZRVSAT,ZWORK,ZLV,ZLS,ZCPH, ZW1, &
+ ZDZ, ZW
+REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) ::&
+ ZSAT,ZCCS
+INTEGER :: JK ! For loop
+integer :: idx
+TYPE(TFIELDDATA) :: TZFIELD
+REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: ZNFS ! CCN C. available source
+REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: ZNAS ! Cloud C. nuclei C. source
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZZNFS ! CCN C. available source
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZZNAS ! Cloud C. nuclei C. source
+REAL :: ZEPS
+
+!-------------------------------------------------------------------------------
+!
+!* 1. PRELIMINARIES
+! -------------
+!
+ILUOUT = TLUOUT%NLU
+CALL GET_INDICE_ll (IIB,IJB,IIE,IJE)
+IKB=1+JPVEXT
+IKE=SIZE(PZZ,3) - JPVEXT
+!
+!-------------------------------------------------------------------------------
+if ( nbumod == kmi .and. lbu_enable ) then
+ if ( lbudget_th ) call Budget_store_init( tbudgets(NBUDGET_TH), 'CEDS', pths(:, :, :) * prhodj(:, :, :) )
+ if ( lbudget_rv ) call Budget_store_init( tbudgets(NBUDGET_RV), 'CEDS', prs(:, :, :, 1) * prhodj(:, :, :) )
+ if ( lbudget_rc ) call Budget_store_init( tbudgets(NBUDGET_RC), 'CEDS', prs(:, :, :, 2) * prhodj(:, :, :) )
+ if ( lbudget_ri ) call Budget_store_init( tbudgets(NBUDGET_RI), 'CEDS', prs(:, :, :, 4) * prhodj(:, :, :) )
+ if ( lbudget_sv ) then
+ call Budget_store_init( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_nc), 'CEDS', psvs(:, :, :, nsv_lima_nc) * prhodj(:, :, :) )
+ do jl = nsv_lima_ccn_free,nsv_lima_ccn_free + nmod_ccn - 1
+ idx = NBUDGET_SV1 - 1 + jl
+ call Budget_store_init( tbudgets(idx), 'CEDS', psvs(:, :, :, jl) * prhodj(:, :, :) )
+ end do
+ if ( lcold ) then
+ call Budget_store_init( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_ni), 'CEDS', psvs(:, :, :, nsv_lima_ni) * prhodj(:, :, :) )
+ do jl = 1, nsv_lima_ifn_free, nsv_lima_ifn_free + nmod_ifn - 1
+ idx = NBUDGET_SV1 - 1 + jl
+ call Budget_store_init( tbudgets(idx), 'CEDS', psvs(:, :, :, jl) * prhodj(:, :, :) )
+ end do
+ end if
+ end if
+end if
+!
+!* 2. COMPUTE QUANTITIES WITH THE GUESS OF THE FUTURE INSTANT
+! -------------------------------------------------------
+!
+!* 2.1 remove negative non-precipitating negative water
+! ------------------------------------------------
+!
+IF (ANY(PRS(:,:,:,2) < 0. .OR. PSVS(:,:,:,NSV_LIMA_NC) < 0.)) THEN
+ WRITE(ILUOUT,*) 'LIMA_NOTADJUST beginning: negative values of PRCS or PCCS'
+ WRITE(ILUOUT,*) ' location of minimum of PRCS:', MINLOC(PRS(:,:,:,2))
+ WRITE(ILUOUT,*) ' value of minimum :', MINVAL(PRS(:,:,:,2))
+ WRITE(ILUOUT,*) ' location of minimum of PCCS:', MINLOC(PSVS(:,:,:,NSV_LIMA_NC))
+ WRITE(ILUOUT,*) ' value of minimum :', MINVAL(PSVS(:,:,:,NSV_LIMA_NC))
+END IF
+!
+IF (ANY(PRS(:,:,:,2)+PRS(:,:,:,1) < 0.) .AND. NVERB>5) THEN
+ WRITE(ILUOUT,*) 'LIMA_NOT_ADJUST: negative values of total water (reset to zero)'
+ WRITE(ILUOUT,*) ' location of minimum:', MINLOC(PRS(:,:,:,2)+PRS(:,:,:,1))
+ WRITE(ILUOUT,*) ' value of minimum :', MINVAL(PRS(:,:,:,2)+PRS(:,:,:,1))
+!callabortstop
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','LIMA_NOTADJUST','')
+END IF
+!
+!
+!* 2.2 estimate the Exner function at t+1 and t respectively
+!
+ZEXNS(:,:,:)=((2.* PPABST(:,:,:)-PPABSM(:,:,:))/XP00 )**(XRD/XCPD)
+ZEXNT(:,:,:)=(PPABST(:,:,:)/XP00 )**(XRD/XCPD)
+!sources terms *dt
+PRS(:,:,:,:) = PRS(:,:,:,:) * PTSTEP
+PSVS(:,:,:,:) = PSVS(:,:,:,:) * PTSTEP
+ZSAT(:,:,:) = PSVS(:,:,:,NSV_LIMA_SPRO)-1.0
+ZCCS(:,:,:) = PSVS(:,:,:,NSV_LIMA_NC)
+IF ( NMOD_CCN .GE. 1 ) THEN
+ ALLOCATE( ZNFS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),NMOD_CCN) )
+ ALLOCATE( ZNAS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),NMOD_CCN) )
+ ZNFS(:,:,:,:) = PSVS(:,:,:,NSV_LIMA_CCN_FREE:NSV_LIMA_CCN_FREE+NMOD_CCN-1)
+ ZNAS(:,:,:,:) = PSVS(:,:,:,NSV_LIMA_CCN_ACTI:NSV_LIMA_CCN_ACTI+NMOD_CCN-1)
+ELSE
+ ALLOCATE( ZNFS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),1) )
+ ALLOCATE( ZNAS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),1) )
+ ZNFS(:,:,:,:) = 0.
+ ZNAS(:,:,:,:) = 0.
+END IF
+ZW(:,:,:)=SUM(ZNAS,4)
+!
+!state temperature at t+dt
+PTHS(:,:,:) = PTHS(:,:,:) * PTSTEP * ZEXNS(:,:,:)
+
+!state temperature at t
+ZT(:,:,:)=PTHT(:,:,:)*ZEXNT(:,:,:)
+!Lv and Cph at t
+ZLV(:,:,:) = XLVTT+(XCPV-XCL)*(ZT(:,:,:)-XTT)
+ZLS(:,:,:) = XLSTT + ( XCPV - XCI ) * ( ZT(:,:,:) -XTT )
+ZCPH(:,:,:)= XCPD+XCPV*PRT(:,:,:,1)+XCL*(PRT(:,:,:,2)+PRT(:,:,:,3)) &
+ +XCI*(PRT(:,:,:,4)+PRT(:,:,:,5)+PRT(:,:,:,6))
+!dz
+DO JK=1,IKE
+ ZDZ(:,:,JK)=PZZ(:,:,JK+1)-PZZ(:,:,JK)
+END DO
+!
+!* 2.3 compute the latent heat of vaporization Lv(T*) at t+1
+!
+!Removed negligible values
+!
+WHERE ( ((PRS(:,:,:,2).LT.XRTMIN(2)) .AND. (ZSAT(:,:,:).LT.0.0)) .OR. &
+ ((PRS(:,:,:,2).GT.0.0) .AND. (ZCCS(:,:,:).LE.0.0)) )
+ PTHS(:,:,:) = PTHS(:,:,:)-(ZLV(:,:,:)/ZCPH(:,:,:))*PRS(:,:,:,2)
+ PRS(:,:,:,1) = PRS(:,:,:,1)+PRS(:,:,:,2)
+ PRS(:,:,:,2) = 0.0
+!ZSAT(:,:,:) = 0.0
+ ZCCS(:,:,:) = 0.0
+!ZNFS(:,:,:,1:NMOD_CCN) = ZNFS(:,:,:,1:NMOD_CCN) + ZNAS(:,:,:,1:NMOD_CCN)
+!ZNAS(:,:,:,1:NMOD_CCN) = 0.
+END WHERE
+!
+
+
+!
+! Ice deposition/sublimation
+!
+ZEPS= XMV / XMD
+GMICRO(:,:,:)=.FALSE.
+GMICRO(IIB:IIE,IJB:IJE,IKB:IKE) = (PRS(IIB:IIE,IJB:IJE,IKB:IKE,4)>XRTMIN(4)/PTSTEP .AND. &
+ PSVS(IIB:IIE,IJB:IJE,IKB:IKE,NSV_LIMA_NI)>XCTMIN(4)/PTSTEP )
+IMICRO = COUNTJV( GMICRO(:,:,:),I1(:),I2(:),I3(:))
+IF( IMICRO >= 1 .AND. .NOT.LPTSPLIT) THEN
+ ALLOCATE(ZRVT(IMICRO))
+ ALLOCATE(ZRIT(IMICRO))
+ ALLOCATE(ZCIT(IMICRO))
+!
+ ALLOCATE(ZRVS(IMICRO))
+ ALLOCATE(ZRIS(IMICRO))
+ ALLOCATE(ZCIS(IMICRO)) !!!BVIE!!!
+ ALLOCATE(ZTHS(IMICRO))
+!
+ ALLOCATE(ZRHODREF(IMICRO))
+ ALLOCATE(ZZT(IMICRO))
+ ALLOCATE(ZPRES(IMICRO))
+ ALLOCATE(ZEXNREF(IMICRO))
+ ALLOCATE(ZZCPH(IMICRO))
+ DO JL=1,IMICRO
+ ZRVT(JL) = PRT(I1(JL),I2(JL),I3(JL),1)
+ ZRIT(JL) = PRT(I1(JL),I2(JL),I3(JL),4)
+ ZCIT(JL) = PSVT(I1(JL),I2(JL),I3(JL),NSV_LIMA_NI)
+!
+ ZRVS(JL) = PRS(I1(JL),I2(JL),I3(JL),1)
+ ZRIS(JL) = PRS(I1(JL),I2(JL),I3(JL),4)
+ ZCIS(JL) = PSVS(I1(JL),I2(JL),I3(JL),NSV_LIMA_NI) !!!BVIE!!!
+ ZTHS(JL) = PTHS(I1(JL),I2(JL),I3(JL))
+!
+ ZRHODREF(JL) = PRHODREF(I1(JL),I2(JL),I3(JL))
+ ZZT(JL) = ZT(I1(JL),I2(JL),I3(JL))
+ ZPRES(JL) = 2.0*PPABST(I1(JL),I2(JL),I3(JL))-PPABSM(I1(JL),I2(JL),I3(JL))
+ ZEXNREF(JL) = PEXNREF(I1(JL),I2(JL),I3(JL))
+ ZZCPH(JL) = ZCPH(I1(JL),I2(JL),I3(JL))
+ ENDDO
+ ALLOCATE(ZZW(IMICRO))
+ ALLOCATE(ZLSFACT(IMICRO))
+ ZLSFACT(:) = (XLSTT+(XCPV-XCI)*(ZZT(:)-XTT))/ZZCPH(:) ! L_s/C_ph
+ ALLOCATE(ZRVSATI(IMICRO))
+ ALLOCATE(ZRVSATI_PRIME(IMICRO))
+ ALLOCATE(ZDELTI(IMICRO))
+ ALLOCATE(ZAI(IMICRO))
+ ALLOCATE(ZCJ(IMICRO))
+ ALLOCATE(ZKA(IMICRO))
+ ALLOCATE(ZDV(IMICRO))
+ ALLOCATE(ZITI(IMICRO))
+!
+ ZKA(:) = 2.38E-2 + 0.0071E-2 * ( ZZT(:) - XTT ) ! k_a
+ ZDV(:) = 0.211E-4 * (ZZT(:)/XTT)**1.94 * (XP00/ZPRES(:)) ! D_v
+ ZCJ(:) = XSCFAC * ZRHODREF(:)**0.3 / SQRT( 1.718E-5+0.0049E-5*(ZZT(:)-XTT) )
+!
+ ZZW(:) = EXP( XALPI - XBETAI/ZZT(:) - XGAMI*ALOG(ZZT(:) ) ) ! es_i
+ ZRVSATI(:) = ZEPS*ZZW(:) / ( ZPRES(:)-ZZW(:) ) ! r_si
+ ZRVSATI_PRIME(:) = (( XBETAI/ZZT(:) - XGAMI ) / ZZT(:)) & ! r'_si
+ * ZRVSATI(:) * ( 1. + ZRVSATI(:)/ZEPS )
+!
+ ZDELTI(:) = ZRVS(:)*PTSTEP - ZRVSATI(:)
+ ZAI(:) = ( XLSTT + (XCPV-XCI)*(ZZT(:)-XTT) )**2 / (ZKA(:)*XRV*ZZT(:)**2) &
+ + ( XRV*ZZT(:) ) / (ZDV(:)*ZZW(:))
+ ZZW(:) = MIN(1.E8,( XLBI* MAX(ZCIT(:),XCTMIN(4)) &
+ /(MAX(ZRIT(:),XRTMIN(4))) )**XLBEXI)
+ ! Lbda_I
+ ZITI(:) = ZCIT(:) * (X0DEPI/ZZW(:) + X2DEPI*ZCJ(:)*ZCJ(:)/ZZW(:)**(XDI+2.0)) &
+ / (ZRVSATI(:)*ZAI(:))
+!
+ ALLOCATE(ZAII(IMICRO))
+ ALLOCATE(ZDEP(IMICRO))
+!
+ ZAII(:) = 1.0 + ZRVSATI_PRIME(:)*ZLSFACT(:)
+ ZDEP(:) = 0.0
+!
+ ZZW(:) = ZAII(:)*ZITI(:)*PTSTEP ! R*delta_T
+ WHERE( ZZW(:)<1.0E-2 )
+ ZDEP(:) = ZITI(:)*ZDELTI(:)*(1.0 - (ZZW(:)/2.0)*(1.0-ZZW(:)/3.0))
+ ELSEWHERE
+ ZDEP(:) = ZITI(:)*ZDELTI(:)*(1.0 - EXP(-ZZW(:)))/ZZW(:)
+ END WHERE
+!
+! Integration
+!
+ WHERE( ZDEP(:) < 0.0 )
+ ZDEP(:) = MAX ( ZDEP(:), -ZRIS(:) )
+ ELSEWHERE
+ ZDEP(:) = MIN ( ZDEP(:), ZRVS(:) )
+! ZDEP(:) = MIN ( ZDEP(:), ZCIS(:)*5.E-10 ) !!!BVIE!!!
+ END WHERE
+ WHERE( ZRIS(:) < XRTMIN(4)/PTSTEP )
+ ZDEP(:) = 0.0
+ END WHERE
+ ZRVS(:) = ZRVS(:) - ZDEP(:)
+ ZRIS(:) = ZRIS(:) + ZDEP(:)
+ ZTHS(:) = ZTHS(:) + ZDEP(:) * ZLSFACT(:) / ZEXNREF(:)
+!
+! Implicit ice crystal sublimation if ice saturated conditions are not met
+!
+ ZZT(:) = ( ZTHS(:) * PTSTEP ) * ( ZPRES(:) / XP00 ) ** (XRD/XCPD)
+ ZZW(:) = EXP( XALPI - XBETAI/ZZT(:) - XGAMI*ALOG(ZZT(:) ) ) ! es_i
+ ZRVSATI(:) = ZEPS*ZZW(:) / ( ZPRES(:)-ZZW(:) ) ! r_si
+ WHERE( ZRVS(:)*PTSTEP<ZRVSATI(:) )
+ ZZW(:) = ZRVS(:) + ZRIS(:)
+ ZRVS(:) = MIN( ZZW(:),ZRVSATI(:)/PTSTEP )
+ ZTHS(:) = ZTHS(:) + ( MAX( 0.0,ZZW(:)-ZRVS(:) )-ZRIS(:) ) &
+ * ZLSFACT(:) / ZEXNREF(:)
+ ZRIS(:) = MAX( 0.0,ZZW(:)-ZRVS(:) )
+ END WHERE
+!
+!
+ ZW(:,:,:) = PRS(:,:,:,1)
+ PRS(:,:,:,1) = UNPACK( ZRVS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
+ ZW(:,:,:) = PRS(:,:,:,4)
+ PRS(:,:,:,4) = UNPACK( ZRIS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
+ ZW(:,:,:) = PTHS(:,:,:)
+ PTHS(:,:,:) = UNPACK( ZTHS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
+!
+ DEALLOCATE(ZRVT)
+ DEALLOCATE(ZRIT)
+ DEALLOCATE(ZCIT)
+ DEALLOCATE(ZRVS)
+ DEALLOCATE(ZRIS)
+ DEALLOCATE(ZCIS) !!!BVIE!!!
+ DEALLOCATE(ZTHS)
+ DEALLOCATE(ZRHODREF)
+ DEALLOCATE(ZZT)
+ DEALLOCATE(ZPRES)
+ DEALLOCATE(ZEXNREF)
+ DEALLOCATE(ZZCPH)
+ DEALLOCATE(ZZW)
+ DEALLOCATE(ZLSFACT)
+ DEALLOCATE(ZRVSATI)
+ DEALLOCATE(ZRVSATI_PRIME)
+ DEALLOCATE(ZDELTI)
+ DEALLOCATE(ZAI)
+ DEALLOCATE(ZCJ)
+ DEALLOCATE(ZKA)
+ DEALLOCATE(ZDV)
+ DEALLOCATE(ZITI)
+ DEALLOCATE(ZAII)
+ DEALLOCATE(ZDEP)
+END IF ! IMICRO
+!
+!selection of mesh where condensation/evaportion/activation is performed
+GNUCT(:,:,:) = .FALSE.
+!GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) = ZSAT(IIB:IIE,IJB:IJE,IKB:IKE)>0.0 .OR. &
+! ZCCS(IIB:IIE,IJB:IJE,IKB:IKE)>0.0
+!GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) = ZSAT(IIB:IIE,IJB:IJE,IKB:IKE)>0.0
+GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) = ZSAT(IIB:IIE,IJB:IJE,IKB:IKE)>0.0 .OR. &
+! ZCCS(IIB:IIE,IJB:IJE,IKB:IKE)>1.E+05
+ ZCCS(IIB:IIE,IJB:IJE,IKB:IKE)>XCTMIN(2)
+INUCT = COUNTJV( GNUCT(:,:,:),I1(:),I2(:),I3(:))
+!3D array to 1D array
+!
+IF( INUCT >= 1 ) THEN
+ ALLOCATE(ZZNFS(INUCT,NMOD_CCN))
+ ALLOCATE(ZZNAS(INUCT,NMOD_CCN))
+ ALLOCATE(ZPRES(INUCT))
+ ALLOCATE(ZRHOD(INUCT))
+ ALLOCATE(ZRR(INUCT))
+ ALLOCATE(ZTT(INUCT))
+ ALLOCATE(ZRV(INUCT))
+ ALLOCATE(ZRC(INUCT))
+ ALLOCATE(ZS0(INUCT))
+ ALLOCATE(ZCCL(INUCT))
+ ALLOCATE(ZZDZ(INUCT))
+ ALLOCATE(ZZLV(INUCT))
+ ALLOCATE(ZZCPH(INUCT))
+ DO JL=1,INUCT
+ ZPRES(JL) = 2. * PPABST(I1(JL),I2(JL),I3(JL)) - PPABSM(I1(JL),I2(JL),I3(JL))
+ ZRHOD(JL) = PRHODREF(I1(JL),I2(JL),I3(JL))
+ ZRR(JL) = PRS(I1(JL),I2(JL),I3(JL),3)
+ ZTT(JL) = PTHS(I1(JL),I2(JL),I3(JL))
+ ZRV(JL) = PRS(I1(JL),I2(JL),I3(JL),1)
+ ZRC(JL) = PRS(I1(JL),I2(JL),I3(JL),2)
+ ZS0(JL) = ZSAT(I1(JL),I2(JL),I3(JL))
+ DO JMOD = 1,NMOD_CCN
+ ZZNFS(JL,JMOD) = ZNFS(I1(JL),I2(JL),I3(JL),JMOD)
+ ZZNAS(JL,JMOD) = ZNAS(I1(JL),I2(JL),I3(JL),JMOD)
+ ENDDO
+ ZCCL(JL) = ZCCS(I1(JL),I2(JL),I3(JL))
+ ZZDZ(JL)=ZDZ(I1(JL),I2(JL),I3(JL))
+ ZZLV(JL)=ZLV(I1(JL),I2(JL),I3(JL))
+ ZZCPH(JL)=ZCPH(I1(JL),I2(JL),I3(JL))
+ ENDDO
+ !
+ !Evaporation/Condensation/activation
+ CALL PROGNOS_LIMA(PTSTEP,ZZDZ,ZZLV,ZZCPH,ZPRES,ZRHOD, &
+ ZRR,ZTT,ZRV,ZRC,ZS0,ZZNAS,ZCCL,ZZNFS)
+ !
+!1D array to 3D array
+ DO JMOD = 1, NMOD_CCN
+ ZWORK(:,:,:) = ZNAS(:,:,:,JMOD)
+ ZNAS(:,:,:,JMOD) = UNPACK( ZZNAS(:,JMOD) ,MASK=GNUCT(:,:,:),FIELD=ZWORK(:,:,:) )
+ ZWORK(:,:,:) = ZNFS(:,:,:,JMOD)
+ ZNFS(:,:,:,JMOD) = UNPACK( ZZNFS(:,JMOD) ,MASK=GNUCT(:,:,:),FIELD=ZWORK(:,:,:) )
+ END DO
+ PSVS(:,:,:,NSV_LIMA_CCN_FREE:NSV_LIMA_CCN_FREE+NMOD_CCN-1) = ZNFS(:,:,:,:)
+ PSVS(:,:,:,NSV_LIMA_CCN_ACTI:NSV_LIMA_CCN_ACTI+NMOD_CCN-1) = ZNAS(:,:,:,:)
+ !
+ ZWORK(:,:,:) = ZCCS(:,:,:)
+ ZCCS(:,:,:) = UNPACK( ZCCL(:),MASK=GNUCT(:,:,:),FIELD=ZWORK(:,:,:) )
+ PSVS(:,:,:,NSV_LIMA_NC) = ZCCS(:,:,:)
+ !
+ ZWORK(:,:,:) = PTHS(:,:,:)
+ PTHS(:,:,:) = UNPACK( ZTT(:),MASK=GNUCT(:,:,:),FIELD=ZWORK(:,:,:) )
+ ZWORK(:,:,:) = PRS(:,:,:,1)
+ PRS(:,:,:,1) = UNPACK( ZRV(:),MASK=GNUCT(:,:,:),FIELD=ZWORK(:,:,:) )
+ ZWORK(:,:,:) = PRS(:,:,:,2)
+ PRS(:,:,:,2) = UNPACK( ZRC(:),MASK=GNUCT(:,:,:),FIELD=ZWORK(:,:,:) )
+ ZWORK(:,:,:) = ZSAT(:,:,:)
+ ZSAT(:,:,:) = UNPACK( ZS0(:),MASK=GNUCT(:,:,:),FIELD=ZWORK(:,:,:) )
+ !
+ DEALLOCATE(ZPRES)
+ DEALLOCATE(ZRHOD)
+ DEALLOCATE(ZRR)
+ DEALLOCATE(ZTT)
+ DEALLOCATE(ZRV)
+ DEALLOCATE(ZRC)
+ DEALLOCATE(ZS0)
+ DEALLOCATE(ZZNFS)
+ DEALLOCATE(ZZNAS)
+ DEALLOCATE(ZCCL)
+ DEALLOCATE(ZZDZ)
+!
+ENDIF
+!
+!Computation of saturation in the meshes where there is no
+!condensation/evaporation/activation
+WHERE(.NOT.GNUCT(:,:,:) )
+ ZRVSAT(:,:,:) = EXP(XALPW-XBETAW/PTHS(:,:,:)-XGAMW*ALOG(PTHS(:,:,:)))
+ !rvsat
+ ZRVSAT(:,:,:) = (XMV / XMD)*ZRVSAT(:,:,:)/((2.* PPABST(:,:,:)-PPABSM(:,:,:))-ZRVSAT(:,:,:))
+ ZSAT(:,:,:) = (PRS(:,:,:,1)/ZRVSAT(:,:,:))-1D0
+ENDWHERE
+!
+!source terms /dt
+PRS(:,:,:,:) = PRS(:,:,:,:)/PTSTEP
+PTHS(:,:,:) = PTHS(:,:,:)/PTSTEP/ZEXNS(:,:,:)
+ZSAT(:,:,:) = ZSAT(:,:,:)+1.0
+PSVS(:,:,:,NSV_LIMA_SPRO) = ZSAT(:,:,:)
+PSVS(:,:,:,:) = PSVS(:,:,:,:)/PTSTEP
+!
+IF (ANY(PRS(:,:,:,2)+PRS(:,:,:,1) < 0.) .AND. NVERB>5) THEN
+ WRITE(*,*) 'LIMA_NOTADJUST: negative values of total water (reset to zero)'
+ WRITE(*,*) ' location of minimum:', MINLOC(PRS(:,:,:,2)+PRS(:,:,:,1))
+ WRITE(*,*) ' value of minimum :', MINVAL(PRS(:,:,:,2)+PRS(:,:,:,1))
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','LIMA_NOTADJUST','')
+END IF
+!
+!* compute the cloud fraction PCLDFR
+!
+WHERE (PRS(:,:,:,2) > 0. )
+ ZW1(:,:,:) = 1.
+ELSEWHERE
+ ZW1(:,:,:) = 0.
+ENDWHERE
+IF ( SIZE(PSRCS,3) /= 0 ) THEN
+ PSRCS(:,:,:) = ZW1(:,:,:)
+END IF
+!
+IF ( HRAD /= 'NONE' ) THEN
+ PCLDFR(:,:,:) = ZW1(:,:,:)
+END IF
+!
+IF ( tpfile%lopened ) THEN
+ ZW(:,:,:)=SUM(ZNAS,4)-ZW(:,:,:)
+ TZFIELD%CMNHNAME = 'NACT'
+ TZFIELD%CSTDNAME = ''
+ TZFIELD%CLONGNAME = 'NACT'
+ TZFIELD%CUNITS = ''
+ TZFIELD%CDIR = 'XY'
+ TZFIELD%CCOMMENT = 'X_Y_Z_NACT'
+ TZFIELD%NGRID = 1
+ TZFIELD%NTYPE = TYPEREAL
+ TZFIELD%NDIMS = 3
+ TZFIELD%LTIMEDEP = .TRUE.
+ CALL IO_Field_write(TPFILE,TZFIELD,ZW)
+END IF
+!
+!* 7. STORE THE BUDGET TERMS
+! ----------------------
+!
+if ( nbumod == kmi .and. lbu_enable ) then
+ if ( lbudget_th ) call Budget_store_end( tbudgets(NBUDGET_TH), 'CEDS', pths(:, :, :) * prhodj(:, :, :) )
+ if ( lbudget_rv ) call Budget_store_end( tbudgets(NBUDGET_RV), 'CEDS', prs(:, :, :, 1) * prhodj(:, :, :) )
+ if ( lbudget_rc ) call Budget_store_end( tbudgets(NBUDGET_RC), 'CEDS', prs(:, :, :, 2) * prhodj(:, :, :) )
+ if ( lbudget_ri ) call Budget_store_end( tbudgets(NBUDGET_RI), 'CEDS', prs(:, :, :, 4) * prhodj(:, :, :) )
+ if ( lbudget_sv ) then
+ call Budget_store_end( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_nc), 'CEDS', psvs(:, :, :, nsv_lima_nc) * prhodj(:, :, :) )
+ do jl = nsv_lima_ccn_free,nsv_lima_ccn_free + nmod_ccn - 1
+ idx = NBUDGET_SV1 - 1 + jl
+ call Budget_store_end( tbudgets(idx), 'CEDS', psvs(:, :, :, jl) * prhodj(:, :, :) )
+ end do
+ if ( lcold ) then
+ call Budget_store_end( tbudgets(NBUDGET_SV1 - 1 + nsv_lima_ni), 'CEDS', psvs(:, :, :, nsv_lima_ni) * prhodj(:, :, :) )
+ do jl = 1, nsv_lima_ifn_free, nsv_lima_ifn_free + nmod_ifn - 1
+ idx = NBUDGET_SV1 - 1 + jl
+ call Budget_store_end( tbudgets(idx), 'CEDS', psvs(:, :, :, jl) * prhodj(:, :, :) )
+ end do
+ end if
+ end if
+end if
+!
+END SUBROUTINE LIMA_NOTADJUST
diff --git a/src/MNH/lima_nucleation_procs.f90 b/src/MNH/lima_nucleation_procs.f90
index a86bbd8525eac5df91766d54ee8a56d7133d7244..fac3f8ce7706b0b223731cf9aef9063616a9b3ce 100644
--- a/src/MNH/lima_nucleation_procs.f90
+++ b/src/MNH/lima_nucleation_procs.f90
@@ -8,11 +8,12 @@
! ###############################
!
INTERFACE
- SUBROUTINE LIMA_NUCLEATION_PROCS (PTSTEP, TPFILE, PRHODJ, &
- PRHODREF, PEXNREF, PPABST, PT, PDTHRAD, PW_NU, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
- PCCT, PCRT, PCIT, &
- PNFT, PNAT, PIFT, PINT, PNIT, PNHT )
+ SUBROUTINE LIMA_NUCLEATION_PROCS (PTSTEP, TPFILE, PRHODJ, &
+ PRHODREF, PEXNREF, PPABST, PT, PDTHRAD, PW_NU,&
+ PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
+ PCCT, PCRT, PCIT, &
+ PNFT, PNAT, PIFT, PINT, PNIT, PNHT, &
+ PCLDFR, PICEFR, PPRCFR )
!
USE MODD_IO, ONLY: TFILEDATA
!
@@ -46,16 +47,21 @@ REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PINT ! IFN C. activated at t
REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNIT ! Coated IFN activated at t
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PNHT ! CCN hom freezing
!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCLDFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PICEFR ! Ice fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPRCFR ! Precipitation fraction
+!
END SUBROUTINE LIMA_NUCLEATION_PROCS
END INTERFACE
END MODULE MODI_LIMA_NUCLEATION_PROCS
-! ############################################################################
-SUBROUTINE LIMA_NUCLEATION_PROCS (PTSTEP, TPFILE, PRHODJ, &
- PRHODREF, PEXNREF, PPABST, PT, PDTHRAD, PW_NU, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
- PCCT, PCRT, PCIT, &
- PNFT, PNAT, PIFT, PINT, PNIT, PNHT )
-! ############################################################################
+! #############################################################################
+SUBROUTINE LIMA_NUCLEATION_PROCS (PTSTEP, TPFILE, PRHODJ, &
+ PRHODREF, PEXNREF, PPABST, PT, PDTHRAD, PW_NU,&
+ PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
+ PCCT, PCRT, PCIT, &
+ PNFT, PNAT, PIFT, PINT, PNIT, PNHT, &
+ PCLDFR, PICEFR, PPRCFR )
+! #############################################################################
!
!! PURPOSE
!! -------
@@ -83,7 +89,8 @@ USE MODD_IO, ONLY: TFILEDATA
USE MODD_NSV, ONLY : NSV_LIMA_NC, NSV_LIMA_NR, NSV_LIMA_CCN_FREE, NSV_LIMA_CCN_ACTI, &
NSV_LIMA_NI, NSV_LIMA_IFN_FREE, NSV_LIMA_IFN_NUCL, NSV_LIMA_IMM_NUCL, NSV_LIMA_HOM_HAZE
USE MODD_PARAM_LIMA, ONLY : LCOLD, LNUCL, LMEYERS, LSNOW, LWARM, LACTI, LRAIN, LHHONI, &
- NMOD_CCN, NMOD_IFN, NMOD_IMM
+ NMOD_CCN, NMOD_IFN, NMOD_IMM, XCTMIN, XRTMIN, LSPRO
+USE MODD_TURB_n, ONLY : LSUBG_COND
use mode_budget, only: Budget_store_add, Budget_store_init, Budget_store_end
@@ -128,6 +135,10 @@ REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PINT ! IFN C. activated at t
REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNIT ! Coated IFN activated at t
REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PNHT ! CCN hom. freezing
!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCLDFR ! Cloud fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PICEFR ! Ice fraction
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PPRCFR ! Precipitation fraction
+!
!-------------------------------------------------------------------------------
!
REAL, DIMENSION(SIZE(PT,1),SIZE(PT,2),SIZE(PT,3)) :: Z_TH_HIND, Z_RI_HIND, Z_CI_HIND, Z_TH_HINC, Z_RC_HINC, Z_CC_HINC
@@ -152,11 +163,12 @@ IF ( LWARM .AND. LACTI .AND. NMOD_CCN >=1 ) THEN
end do
end if
end if
-
- CALL LIMA_CCN_ACTIVATION (PTSTEP, TPFILE, &
+ IF (.NOT.LSUBG_COND .AND. .NOT.LSPRO) THEN
+ CALL LIMA_CCN_ACTIVATION (PTSTEP, TPFILE, &
PRHODREF, PEXNREF, PPABST, PT, PDTHRAD, PW_NU, &
- PTHT, PRVT, PRCT, PCCT, PRRT, PNFT, PNAT )
-
+ PTHT, PRVT, PRCT, PCCT, PRRT, PNFT, PNAT, PCLDFR )
+ END IF
+ WHERE(PCLDFR(:,:,:)<1.E-10 .AND. PRCT(:,:,:)>XRTMIN(2) .AND. PCCT(:,:,:)>XCTMIN(2)) PCLDFR(:,:,:)=1.
if ( lbu_enable ) then
if ( lbudget_th ) call Budget_store_end( tbudgets(NBUDGET_TH), 'HENU', ptht(:, :, :) * prhodj(:, :, :) / ptstep )
if ( lbudget_rv ) call Budget_store_end( tbudgets(NBUDGET_RV), 'HENU', prvt(:, :, :) * prhodj(:, :, :) / ptstep )
@@ -201,8 +213,10 @@ IF ( LCOLD .AND. LNUCL .AND. .NOT.LMEYERS .AND. NMOD_IFN >= 1 ) THEN
PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
PCCT, PCIT, PNAT, PIFT, PINT, PNIT, &
Z_TH_HIND, Z_RI_HIND, Z_CI_HIND, &
- Z_TH_HINC, Z_RC_HINC, Z_CC_HINC )
-
+ Z_TH_HINC, Z_RC_HINC, Z_CC_HINC, &
+ PICEFR )
+ WHERE(PICEFR(:,:,:)<1.E-10 .AND. PRIT(:,:,:)>XRTMIN(4) .AND. PCIT(:,:,:)>XCTMIN(4)) PICEFR(:,:,:)=1.
+!
if ( lbu_enable ) then
if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'HIND', z_th_hind(:, :, :) * prhodj(:, :, :) / ptstep )
if ( lbudget_rv ) call Budget_store_add( tbudgets(NBUDGET_RV), 'HIND', -z_ri_hind(:, :, :) * prhodj(:, :, :) / ptstep )
@@ -243,8 +257,10 @@ IF (LCOLD .AND. LNUCL .AND. LMEYERS) THEN
PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
PCCT, PCIT, PINT, &
Z_TH_HIND, Z_RI_HIND, Z_CI_HIND, &
- Z_TH_HINC, Z_RC_HINC, Z_CC_HINC )
-
+ Z_TH_HINC, Z_RC_HINC, Z_CC_HINC, &
+ PICEFR )
+ WHERE(PICEFR(:,:,:)<1.E-10 .AND. PRIT(:,:,:)>XRTMIN(4) .AND. PCIT(:,:,:)>XCTMIN(4)) PICEFR(:,:,:)=1.
+!
if ( lbu_enable ) then
if ( lbudget_th ) call Budget_store_add( tbudgets(NBUDGET_TH), 'HIND', z_th_hind(:, :, :) * prhodj(:, :, :) / ptstep )
if ( lbudget_rv ) call Budget_store_add( tbudgets(NBUDGET_RV), 'HIND', -z_ri_hind(:, :, :) * prhodj(:, :, :) / ptstep )
@@ -288,8 +304,10 @@ IF ( LCOLD .AND. LNUCL .AND. LHHONI .AND. NMOD_CCN >= 1) THEN
CALL LIMA_CCN_HOM_FREEZING (PRHODREF, PEXNREF, PPABST, PW_NU, &
PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
- PCCT, PCRT, PCIT, PNFT, PNHT )
-
+ PCCT, PCRT, PCIT, PNFT, PNHT, &
+ PICEFR )
+ WHERE(PICEFR(:,:,:)<1.E-10 .AND. PRIT(:,:,:)>XRTMIN(4) .AND. PCIT(:,:,:)>XCTMIN(4)) PICEFR(:,:,:)=1.
+!
if ( lbu_enable ) then
if ( lbudget_th ) call Budget_store_end( tbudgets(NBUDGET_TH), 'HONH', PTHT(:, :, :) * prhodj(:, :, :) / ptstep )
if ( lbudget_rv ) call Budget_store_end( tbudgets(NBUDGET_RV), 'HONH', PRVT(:, :, :) * prhodj(:, :, :) / ptstep )
diff --git a/src/MNH/lima_phillips_ifn_nucleation.f90 b/src/MNH/lima_phillips_ifn_nucleation.f90
index a1103f50bc911925298ab1689f110fbecf87e57f..f184e5c6408d9e79f6e46c8537037aa46cb8bc5a 100644
--- a/src/MNH/lima_phillips_ifn_nucleation.f90
+++ b/src/MNH/lima_phillips_ifn_nucleation.f90
@@ -13,7 +13,8 @@ INTERFACE
PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
PCCT, PCIT, PNAT, PIFT, PINT, PNIT, &
P_TH_HIND, P_RI_HIND, P_CI_HIND, &
- P_TH_HINC, P_RC_HINC, P_CC_HINC )
+ P_TH_HINC, P_RC_HINC, P_CC_HINC, &
+ PICEFR )
!
REAL, INTENT(IN) :: PTSTEP
!
@@ -43,6 +44,8 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: P_TH_HINC
REAL, DIMENSION(:,:,:), INTENT(OUT) :: P_RC_HINC
REAL, DIMENSION(:,:,:), INTENT(OUT) :: P_CC_HINC
!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PICEFR
+!
END SUBROUTINE LIMA_PHILLIPS_IFN_NUCLEATION
END INTERFACE
END MODULE MODI_LIMA_PHILLIPS_IFN_NUCLEATION
@@ -53,7 +56,8 @@ END MODULE MODI_LIMA_PHILLIPS_IFN_NUCLEATION
PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
PCCT, PCIT, PNAT, PIFT, PINT, PNIT, &
P_TH_HIND, P_RI_HIND, P_CI_HIND, &
- P_TH_HINC, P_RC_HINC, P_CC_HINC )
+ P_TH_HINC, P_RC_HINC, P_CC_HINC, &
+ PICEFR )
! #################################################################################
!!
!! PURPOSE
@@ -158,6 +162,8 @@ REAL, DIMENSION(:,:,:), INTENT(OUT) :: P_TH_HINC
REAL, DIMENSION(:,:,:), INTENT(OUT) :: P_RC_HINC
REAL, DIMENSION(:,:,:), INTENT(OUT) :: P_CC_HINC
!
+REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PICEFR
+!
!
!* 0.2 Declarations of local variables :
!
diff --git a/src/MNH/lima_rain_accr_snow.f90 b/src/MNH/lima_rain_accr_snow.f90
index 60817d81741a913204da6857f538a1bfd4c13c22..2dae0d91175a51654822e39a5e0349891fc4f1cc 100644
--- a/src/MNH/lima_rain_accr_snow.f90
+++ b/src/MNH/lima_rain_accr_snow.f90
@@ -11,8 +11,7 @@ INTERFACE
SUBROUTINE LIMA_RAIN_ACCR_SNOW (PTSTEP, LDCOMPUTE, &
PRHODREF, PT, &
PRRT, PCRT, PRST, PLBDR, PLBDS, PLVFACT, PLSFACT, &
- P_TH_ACC, P_RR_ACC, P_CR_ACC, P_RS_ACC, P_RG_ACC, &
- PA_TH, PA_RR, PA_CR, PA_RS, PA_RG )
+ P_TH_ACC, P_RR_ACC, P_CR_ACC, P_RS_ACC, P_RG_ACC )
!
REAL, INTENT(IN) :: PTSTEP
LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
@@ -34,12 +33,6 @@ REAL, DIMENSION(:), INTENT(INOUT) :: P_CR_ACC
REAL, DIMENSION(:), INTENT(INOUT) :: P_RS_ACC
REAL, DIMENSION(:), INTENT(INOUT) :: P_RG_ACC
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_TH
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RR
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CR
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RS
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RG
-!
END SUBROUTINE LIMA_RAIN_ACCR_SNOW
END INTERFACE
END MODULE MODI_LIMA_RAIN_ACCR_SNOW
@@ -48,8 +41,7 @@ END MODULE MODI_LIMA_RAIN_ACCR_SNOW
SUBROUTINE LIMA_RAIN_ACCR_SNOW (PTSTEP, LDCOMPUTE, &
PRHODREF, PT, &
PRRT, PCRT, PRST, PLBDR, PLBDS, PLVFACT, PLSFACT, &
- P_TH_ACC, P_RR_ACC, P_CR_ACC, P_RS_ACC, P_RG_ACC, &
- PA_TH, PA_RR, PA_CR, PA_RS, PA_RG )
+ P_TH_ACC, P_RR_ACC, P_CR_ACC, P_RS_ACC, P_RG_ACC )
! ###################################################################################
!
!! PURPOSE
@@ -107,12 +99,6 @@ REAL, DIMENSION(:), INTENT(INOUT) :: P_CR_ACC
REAL, DIMENSION(:), INTENT(INOUT) :: P_RS_ACC
REAL, DIMENSION(:), INTENT(INOUT) :: P_RG_ACC
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_TH
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RR
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CR
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RS
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RG
-!
!* 0.2 Declarations of local variables :
!
LOGICAL, DIMENSION(SIZE(PRRT)) :: GACC
@@ -265,12 +251,6 @@ WHERE( GACC )
END WHERE
!
!
-PA_RR(:) = PA_RR(:) + P_RR_ACC(:)
-PA_CR(:) = PA_CR(:) + P_CR_ACC(:)
-PA_RS(:) = PA_RS(:) + P_RS_ACC(:)
-PA_RG(:) = PA_RG(:) + P_RG_ACC(:)
-PA_TH(:) = PA_TH(:) + P_TH_ACC(:)
-!
!-------------------------------------------------------------------------------
!
CONTAINS
diff --git a/src/MNH/lima_rain_evaporation.f90 b/src/MNH/lima_rain_evaporation.f90
index 9762a2e2607643f7aba69497a6b4934eb6594ea9..5882923c1a88c2ef5de5b074beba6021ce6a8130 100644
--- a/src/MNH/lima_rain_evaporation.f90
+++ b/src/MNH/lima_rain_evaporation.f90
@@ -11,7 +11,6 @@ INTERFACE
PRHODREF, PT, PLV, PLVFACT, PEVSAT, PRVSAT, &
PRVT, PRCT, PRRT, PLBDR, &
P_TH_EVAP, P_RR_EVAP, &
- PA_RV, PA_RR, PA_TH, &
PEVAP3D )
!
REAL, INTENT(IN) :: PTSTEP ! Time step
@@ -32,10 +31,6 @@ REAL, DIMENSION(:), INTENT(IN) :: PLBDR ! Lambda(rain)
REAL, DIMENSION(:), INTENT(INOUT) :: P_TH_EVAP
REAL, DIMENSION(:), INTENT(INOUT) :: P_RR_EVAP
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RV
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RR
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_TH
-!
REAL, DIMENSION(:), INTENT(INOUT) :: PEVAP3D ! Rain evap profile
!
END SUBROUTINE LIMA_RAIN_EVAPORATION
@@ -46,7 +41,6 @@ END MODULE MODI_LIMA_RAIN_EVAPORATION
PRHODREF, PT, PLV, PLVFACT, PEVSAT, PRVSAT, &
PRVT, PRCT, PRRT, PLBDR, &
P_TH_EVAP, P_RR_EVAP, &
- PA_RV, PA_RR, PA_TH, &
PEVAP3D )
! ###############################################################################
!
@@ -99,10 +93,6 @@ REAL, DIMENSION(:), INTENT(IN) :: PLBDR ! Lambda(rain)
REAL, DIMENSION(:), INTENT(INOUT) :: P_TH_EVAP
REAL, DIMENSION(:), INTENT(INOUT) :: P_RR_EVAP
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RV
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RR
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_TH
-!
REAL, DIMENSION(:), INTENT(INOUT) :: PEVAP3D ! Rain evap profile
!
!* 0.1 Declarations of local variables :
@@ -148,12 +138,9 @@ WHERE ( GEVAP )
ZZW2(:) = MAX(ZZW2(:),0.0)
!
P_RR_EVAP(:) = - ZZW2(:)
- P_TH_EVAP(:) = P_RR_EVAP(:) * PLVFACT(:)
- PEVAP3D(:) = - P_RR_EVAP(:)
+! P_TH_EVAP(:) = P_RR_EVAP(:) * PLVFACT(:)
+! PEVAP3D(:) = - P_RR_EVAP(:)
!
-PA_TH(:) = PA_TH(:) + P_TH_EVAP(:)
-PA_RV(:) = PA_RV(:) - P_RR_EVAP(:)
-PA_RR(:) = PA_RR(:) + P_RR_EVAP(:)
END WHERE
!
!-----------------------------------------------------------------------------
diff --git a/src/MNH/lima_rain_freezing.f90 b/src/MNH/lima_rain_freezing.f90
index d09fc393ac6bc796a4af57a2f14cd7bbaa5f89dc..08475324a8186502583b1eeb346d495f3732c5eb 100644
--- a/src/MNH/lima_rain_freezing.f90
+++ b/src/MNH/lima_rain_freezing.f90
@@ -10,8 +10,7 @@ INTERFACE
SUBROUTINE LIMA_RAIN_FREEZING (LDCOMPUTE, &
PRHODREF, PT, PLVFACT, PLSFACT, &
PRRT, PCRT, PRIT, PCIT, PLBDR, &
- P_TH_CFRZ, P_RR_CFRZ, P_CR_CFRZ, P_RI_CFRZ, P_CI_CFRZ, &
- PA_TH, PA_RR, PA_CR, PA_RI, PA_CI, PA_RG )
+ P_TH_CFRZ, P_RR_CFRZ, P_CR_CFRZ, P_RI_CFRZ, P_CI_CFRZ )
!
LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
!
@@ -32,13 +31,6 @@ REAL, DIMENSION(:), INTENT(INOUT) :: P_CR_CFRZ
REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_CFRZ
REAL, DIMENSION(:), INTENT(INOUT) :: P_CI_CFRZ
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_TH
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RR
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CR
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RI
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CI
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RG
-!
END SUBROUTINE LIMA_RAIN_FREEZING
END INTERFACE
END MODULE MODI_LIMA_RAIN_FREEZING
@@ -47,8 +39,7 @@ END MODULE MODI_LIMA_RAIN_FREEZING
SUBROUTINE LIMA_RAIN_FREEZING (LDCOMPUTE, &
PRHODREF, PT, PLVFACT, PLSFACT, &
PRRT, PCRT, PRIT, PCIT, PLBDR, &
- P_TH_CFRZ, P_RR_CFRZ, P_CR_CFRZ, P_RI_CFRZ, P_CI_CFRZ, &
- PA_TH, PA_RR, PA_CR, PA_RI, PA_CI, PA_RG )
+ P_TH_CFRZ, P_RR_CFRZ, P_CR_CFRZ, P_RI_CFRZ, P_CI_CFRZ )
! #######################################################################################
!
!! PURPOSE
@@ -99,13 +90,6 @@ REAL, DIMENSION(:), INTENT(INOUT) :: P_CR_CFRZ
REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_CFRZ
REAL, DIMENSION(:), INTENT(INOUT) :: P_CI_CFRZ
!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_TH
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RR
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CR
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RI
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_CI
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RG
-!
!* 0.2 Declarations of local variables :
!
REAL, DIMENSION(SIZE(PRRT)) :: ZW1, ZW2 ! work arrays
@@ -144,14 +128,6 @@ WHERE( (PRIT(:)>XRTMIN(4)) .AND. (PRRT(:)>XRTMIN(3)) .AND. (PT(:)<XTT) .AND. LDC
!
END WHERE
!
-PA_TH(:) = PA_TH(:) + P_TH_CFRZ(:)
-PA_RR(:) = PA_RR(:) + P_RR_CFRZ(:)
-PA_CR(:) = PA_CR(:) + P_CR_CFRZ(:)
-PA_RI(:) = PA_RI(:) + P_RI_CFRZ(:)
-PA_CI(:) = PA_CI(:) + P_CI_CFRZ(:)
-PA_RG(:) = PA_RG(:) - P_RR_CFRZ(:) - P_RI_CFRZ(:)
-!
-!
!-------------------------------------------------------------------------------
!
END SUBROUTINE LIMA_RAIN_FREEZING
diff --git a/src/MNH/lima_snow_deposition.f90 b/src/MNH/lima_snow_deposition.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b26ea46ad1ca8cc66c650bd83b5a2609009d2646
--- /dev/null
+++ b/src/MNH/lima_snow_deposition.f90
@@ -0,0 +1,162 @@
+!MNH_LIC Copyright 2013-2018 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.
+! #####################
+ MODULE MODI_LIMA_SNOW_DEPOSITION
+! #####################
+!
+INTERFACE
+ SUBROUTINE LIMA_SNOW_DEPOSITION (LDCOMPUTE, &
+ PRHODREF, PSSI, PAI, PCJ, PLSFACT, &
+ PRST, PLBDS, &
+ P_RI_CNVI, P_CI_CNVI, &
+ P_TH_DEPS, P_RS_DEPS )
+!
+LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
+!
+REAL, DIMENSION(:), INTENT(IN) :: PRHODREF! Reference density
+REAL, DIMENSION(:), INTENT(IN) :: PSSI ! abs. pressure at time t
+REAL, DIMENSION(:), INTENT(IN) :: PAI ! abs. pressure at time t
+REAL, DIMENSION(:), INTENT(IN) :: PCJ ! abs. pressure at time t
+REAL, DIMENSION(:), INTENT(IN) :: PLSFACT ! abs. pressure at time t
+!
+REAL, DIMENSION(:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
+!
+REAL, DIMENSION(:), INTENT(IN) :: PLBDS ! Graupel m.r. at t
+!
+REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_CNVI
+REAL, DIMENSION(:), INTENT(INOUT) :: P_CI_CNVI
+REAL, DIMENSION(:), INTENT(INOUT) :: P_TH_DEPS
+REAL, DIMENSION(:), INTENT(INOUT) :: P_RS_DEPS
+!
+END SUBROUTINE LIMA_SNOW_DEPOSITION
+END INTERFACE
+END MODULE MODI_LIMA_SNOW_DEPOSITION
+!
+! ##########################################################################
+SUBROUTINE LIMA_SNOW_DEPOSITION (LDCOMPUTE, &
+ PRHODREF, PSSI, PAI, PCJ, PLSFACT, &
+ PRST, PLBDS, &
+ P_RI_CNVI, P_CI_CNVI, &
+ P_TH_DEPS, P_RS_DEPS )
+! ##########################################################################
+!
+!! PURPOSE
+!! -------
+!! The purpose of this routine is to compute the microphysical sources
+!! for slow cold processes :
+!! - conversion of snow to ice
+!! - deposition of vapor on snow
+!! - conversion of ice to snow (Harrington 1995)
+!!
+!!
+!! AUTHOR
+!! ------
+!! J.-M. Cohard * Laboratoire d'Aerologie*
+!! J.-P. Pinty * Laboratoire d'Aerologie*
+!! S. Berthet * Laboratoire d'Aerologie*
+!! B. Vié * CNRM *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 15/03/2018
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAM_LIMA, ONLY : XRTMIN, XCTMIN, XALPHAI, XALPHAS, XNUI, XNUS
+USE MODD_PARAM_LIMA_COLD, ONLY : XCXS, XCCS, &
+ XLBDAS_MAX, XDSCNVI_LIM, XLBDASCNVI_MAX, &
+ XC0DEPSI, XC1DEPSI, XR0DEPSI, XR1DEPSI, &
+ XSCFAC, X1DEPS, X0DEPS, XEX1DEPS, XEX0DEPS, &
+ XDICNVS_LIM, XLBDAICNVS_LIM, &
+ XC0DEPIS, XC1DEPIS, XR0DEPIS, XR1DEPIS, &
+ XCOLEXIS, XAGGS_CLARGE1, XAGGS_CLARGE2, &
+ XAGGS_RLARGE1, XAGGS_RLARGE2
+
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
+!
+REAL, DIMENSION(:), INTENT(IN) :: PRHODREF! Reference density
+REAL, DIMENSION(:), INTENT(IN) :: PSSI ! abs. pressure at time t
+REAL, DIMENSION(:), INTENT(IN) :: PAI ! abs. pressure at time t
+REAL, DIMENSION(:), INTENT(IN) :: PCJ ! abs. pressure at time t
+REAL, DIMENSION(:), INTENT(IN) :: PLSFACT ! abs. pressure at time t
+!
+REAL, DIMENSION(:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
+!
+REAL, DIMENSION(:), INTENT(IN) :: PLBDS ! Graupel m.r. at t
+!
+REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_CNVI
+REAL, DIMENSION(:), INTENT(INOUT) :: P_CI_CNVI
+REAL, DIMENSION(:), INTENT(INOUT) :: P_TH_DEPS
+REAL, DIMENSION(:), INTENT(INOUT) :: P_RS_DEPS
+!
+!* 0.2 Declarations of local variables :
+!
+LOGICAL, DIMENSION(SIZE(PRHODREF)) :: GMICRO ! Computations only where necessary
+REAL, DIMENSION(SIZE(PRHODREF)) :: ZZW, ZZW2, ZZX ! Work array
+!
+!
+!-------------------------------------------------------------------------------
+!
+P_RI_CNVI(:) = 0.
+P_CI_CNVI(:) = 0.
+P_TH_DEPS(:) = 0.
+P_RS_DEPS(:) = 0.
+!
+! Physical limitations
+!
+!
+! Looking for regions where computations are necessary
+!
+GMICRO(:) = LDCOMPUTE(:) .AND. PRST(:)>XRTMIN(5)
+!
+!
+WHERE( GMICRO )
+!
+!* 2.1 Conversion of snow to r_i: RSCNVI
+! ----------------------------------------
+!
+!
+ ZZW2(:) = 0.0
+ ZZW(:) = 0.0
+ WHERE ( PLBDS(:)<XLBDASCNVI_MAX .AND. (PRST(:)>XRTMIN(5)) &
+ .AND. (PSSI(:)<0.0) )
+ ZZW(:) = (PLBDS(:)*XDSCNVI_LIM)**(XALPHAS)
+ ZZX(:) = ( -PSSI(:)/PAI(:) ) * (XCCS*PLBDS(:)**XCXS) * (ZZW(:)**XNUS) * EXP(-ZZW(:))
+!
+ ZZW(:) = ( XR0DEPSI+XR1DEPSI*PCJ(:) )*ZZX(:)
+!
+ ZZW2(:) = ZZW(:)*( XC0DEPSI+XC1DEPSI*PCJ(:) )/( XR0DEPSI+XR1DEPSI*PCJ(:) )
+ END WHERE
+!
+ P_RI_CNVI(:) = ZZW(:)
+ P_CI_CNVI(:) = ZZW2(:)
+!
+!
+!* 2.2 Deposition of water vapor on r_s: RVDEPS
+! -----------------------------------------------
+!
+!
+ ZZW(:) = 0.0
+ WHERE ( (PRST(:)>XRTMIN(5)) )
+ ZZW(:) = ( PSSI(:)/(PAI(:)) ) * &
+ ( X0DEPS*PLBDS(:)**XEX0DEPS + X1DEPS*PCJ(:)*PLBDS(:)**XEX1DEPS )
+ ZZW(:) = ZZW(:)*(0.5+SIGN(0.5,ZZW(:))) - ABS(ZZW(:))*(0.5-SIGN(0.5,ZZW(:)))
+ END WHERE
+!
+ P_RS_DEPS(:) = ZZW(:)
+!!$ P_TH_DEPS(:) = P_RS_DEPS(:) * PLSFACT(:)
+!
+END WHERE
+!
+!
+END SUBROUTINE LIMA_SNOW_DEPOSITION
diff --git a/src/MNH/lima_tendencies.f90 b/src/MNH/lima_tendencies.f90
index 02bf151fce8c8ec637810ab26ae2682d13520e0b..4649a0c402ee2d99472321bf3b52bfc330a66fe5 100644
--- a/src/MNH/lima_tendencies.f90
+++ b/src/MNH/lima_tendencies.f90
@@ -18,6 +18,7 @@ MODULE MODI_LIMA_TENDENCIES
P_TH_EVAP, P_RR_EVAP, &
P_RI_CNVI, P_CI_CNVI, &
P_TH_DEPS, P_RS_DEPS, &
+ P_TH_DEPI, P_RI_DEPI, &
P_RI_CNVS, P_CI_CNVS, &
P_RI_AGGS, P_CI_AGGS, &
P_TH_DEPG, P_RG_DEPG, &
@@ -39,7 +40,8 @@ MODULE MODI_LIMA_TENDENCIES
!!! Z_RR_HMLT, Z_CR_HMLT ! hail melting (HMLT) : rr, Nr, rh=-rr, th
PA_TH, PA_RV, PA_RC, PA_CC, PA_RR, PA_CR, &
PA_RI, PA_CI, PA_RS, PA_RG, PA_RH, &
- PEVAP3D )
+ PEVAP3D, &
+ PCF1D, PIF1D, PPF1D )
!
REAL, INTENT(IN) :: PTSTEP
LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
@@ -85,6 +87,9 @@ REAL, DIMENSION(:), INTENT(INOUT) :: P_CI_CNVI ! conversion snow -> ice (CNVI
REAL, DIMENSION(:), INTENT(INOUT) :: P_TH_DEPS
REAL, DIMENSION(:), INTENT(INOUT) :: P_RS_DEPS ! deposition of vapor on snow (DEPS) : rv=-rs, rs, th
!
+REAL, DIMENSION(:), INTENT(INOUT) :: P_TH_DEPI
+REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_DEPI ! deposition of vapor on ice (DEPI) : rv=-ri, ri, th
+!
REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_CNVS
REAL, DIMENSION(:), INTENT(INOUT) :: P_CI_CNVS ! conversion ice -> snow (CNVS) : ri, Ni, rs=-ri
!
@@ -163,6 +168,10 @@ REAL, DIMENSION(:), INTENT(INOUT) :: PA_RG
REAL, DIMENSION(:), INTENT(INOUT) :: PA_RH
!
REAL, DIMENSION(:), INTENT(INOUT) :: PEVAP3D
+!
+REAL, DIMENSION(:), INTENT(IN) :: PCF1D
+REAL, DIMENSION(:), INTENT(IN) :: PIF1D
+REAL, DIMENSION(:), INTENT(IN) :: PPF1D
!
END SUBROUTINE LIMA_TENDENCIES
END INTERFACE
@@ -182,6 +191,7 @@ SUBROUTINE LIMA_TENDENCIES (PTSTEP, LDCOMPUTE,
P_TH_EVAP, P_RR_EVAP, &
P_RI_CNVI, P_CI_CNVI, &
P_TH_DEPS, P_RS_DEPS, &
+ P_TH_DEPI, P_RI_DEPI, &
P_RI_CNVS, P_CI_CNVS, &
P_RI_AGGS, P_CI_AGGS, &
P_TH_DEPG, P_RG_DEPG, &
@@ -203,7 +213,8 @@ SUBROUTINE LIMA_TENDENCIES (PTSTEP, LDCOMPUTE,
!!! Z_RR_HMLT, Z_CR_HMLT ! hail melting (HMLT) : rr, Nr, rh=-rr, th
PA_TH, PA_RV, PA_RC, PA_CC, PA_RR, PA_CR, &
PA_RI, PA_CI, PA_RS, PA_RG, PA_RH, &
- PEVAP3D )
+ PEVAP3D, &
+ PCF1D, PIF1D, PPF1D )
! ######################################################################
!!
!! PURPOSE
@@ -238,10 +249,10 @@ USE MODI_LIMA_DROPLETS_AUTOCONVERSION
USE MODI_LIMA_DROPLETS_ACCRETION
USE MODI_LIMA_DROPS_SELF_COLLECTION
USE MODI_LIMA_RAIN_EVAPORATION
-USE MODI_LIMA_ICE_SNOW_DEPOSITION
+USE MODI_LIMA_ICE_DEPOSITION
+USE MODI_LIMA_SNOW_DEPOSITION
USE MODI_LIMA_ICE_AGGREGATION_SNOW
USE MODI_LIMA_GRAUPEL_DEPOSITION
-USE MODI_LIMA_BERGERON
USE MODI_LIMA_DROPLETS_RIMING_SNOW
USE MODI_LIMA_RAIN_ACCR_SNOW
USE MODI_LIMA_CONVERSION_MELTING_SNOW
@@ -296,6 +307,9 @@ REAL, DIMENSION(:), INTENT(INOUT) :: P_CI_CNVI ! conversion snow -> ice (CNVI
REAL, DIMENSION(:), INTENT(INOUT) :: P_TH_DEPS
REAL, DIMENSION(:), INTENT(INOUT) :: P_RS_DEPS ! deposition of vapor on snow (DEPS) : rv=-rs, rs, th
!
+REAL, DIMENSION(:), INTENT(INOUT) :: P_TH_DEPI
+REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_DEPI ! deposition of vapor on ice (DEPI) : rv=-ri, ri, th
+!
REAL, DIMENSION(:), INTENT(INOUT) :: P_RI_CNVS
REAL, DIMENSION(:), INTENT(INOUT) :: P_CI_CNVS ! conversion ice -> snow (CNVS) : ri, Ni, rs=-ri
!
@@ -375,6 +389,10 @@ REAL, DIMENSION(:), INTENT(INOUT) :: PA_RH
!
REAL, DIMENSION(:), INTENT(INOUT) :: PEVAP3D
!
+REAL, DIMENSION(:), INTENT(IN) :: PCF1D
+REAL, DIMENSION(:), INTENT(IN) :: PIF1D
+REAL, DIMENSION(:), INTENT(IN) :: PPF1D
+!
!* 0.2 Declarations of local variables :
!
REAL, DIMENSION(SIZE(PRCT)) :: ZT
@@ -409,9 +427,28 @@ REAL, DIMENSION(SIZE(PRCT)) :: ZLSFACT
!
REAL, DIMENSION(SIZE(PRCT)) :: ZW
!
+REAL, DIMENSION(SIZE(PRCT)) :: ZCF1D
+REAL, DIMENSION(SIZE(PRCT)) :: ZIF1D
+REAL, DIMENSION(SIZE(PRCT)) :: ZPF1D
+!
!-------------------------------------------------------------------------------
! Pre-compute quantities
!
+! Prevent fractions to reach 0 (divide by 0)
+!
+ZCF1D(:) = MAX(PCF1D(:),0.01)
+ZIF1D(:) = MAX(PIF1D(:),0.01)
+ZPF1D(:) = MAX(PPF1D(:),0.01)
+!
+! Is it necessary to compute the following quantities
+! accounting for subgrig cloud fraction ?
+! lambda does not depend on cloud fraction for 2-m species
+! lambda depends on CF for 1-m species ?
+!
+!
+! Is it necessary to change water vapour in cloudy / non cloudy parts ?
+!
+!
WHERE (LDCOMPUTE(:))
ZT(:) = PTHT(:) * ( PPABST(:)/XP00 ) ** (XRD/XCPD)
!
@@ -480,66 +517,122 @@ END WHERE
! Call microphysical processes
!
IF (LCOLD .AND. LWARM) THEN
- CALL LIMA_DROPLETS_HOM_FREEZING (PTSTEP, LDCOMPUTE, &
+ CALL LIMA_DROPLETS_HOM_FREEZING (PTSTEP, LDCOMPUTE, & ! indepenedent from CF,IF,PF
ZT, ZLVFACT, ZLSFACT, &
PRCT, PCCT, ZLBDC, &
P_TH_HONC, P_RC_HONC, P_CC_HONC, &
PA_TH, PA_RC, PA_CC, PA_RI, PA_CI )
END IF
!
-IF (LWARM .AND. LRAIN) THEN
- CALL LIMA_DROPLETS_SELF_COLLECTION (LDCOMPUTE, &
- PRHODREF, &
- PCCT, ZLBDC3, &
- P_CC_SELF, &
- PA_CC )
+IF (LWARM) THEN
+ CALL LIMA_DROPLETS_SELF_COLLECTION (LDCOMPUTE, & ! depends on CF
+ PRHODREF, &
+ PCCT/ZCF1D, ZLBDC3, &
+ P_CC_SELF )
+ P_CC_SELF(:) = P_CC_SELF(:) * ZCF1D(:)
+ PA_CC(:) = PA_CC(:) + P_CC_SELF(:)
END IF
!
IF (LWARM .AND. LRAIN) THEN
- CALL LIMA_DROPLETS_AUTOCONVERSION (LDCOMPUTE, &
- PRHODREF, &
- PRCT, ZLBDC, ZLBDR, &
- P_RC_AUTO, P_CC_AUTO, P_CR_AUTO, &
- PA_RC, PA_CC, PA_RR, PA_CR )
+ CALL LIMA_DROPLETS_AUTOCONVERSION (LDCOMPUTE, & ! depends on CF
+ PRHODREF, &
+ PRCT/ZCF1D, PCCT/ZCF1D, ZLBDC, ZLBDR, &
+ P_RC_AUTO, P_CC_AUTO, P_CR_AUTO )
+ P_RC_AUTO(:) = P_RC_AUTO(:) * ZCF1D(:)
+ P_CC_AUTO(:) = P_CC_AUTO(:) * ZCF1D(:)
+ P_CR_AUTO(:) = P_CR_AUTO(:) * ZCF1D(:)
+ !
+ PA_RC(:) = PA_RC(:) + P_RC_AUTO(:)
+ PA_CC(:) = PA_CC(:) + P_CC_AUTO(:)
+ PA_RR(:) = PA_RR(:) - P_RC_AUTO(:)
+ PA_CR(:) = PA_CR(:) + P_CR_AUTO(:)
END IF
!
IF (LWARM .AND. LRAIN) THEN
- CALL LIMA_DROPLETS_ACCRETION (LDCOMPUTE, &
- PRHODREF, &
- PRCT, PRRT, PCCT, PCRT, &
- ZLBDC, ZLBDC3, ZLBDR, ZLBDR3, &
- P_RC_ACCR, P_CC_ACCR, &
- PA_RC, PA_CC, PA_RR )
+ CALL LIMA_DROPLETS_ACCRETION (LDCOMPUTE, & ! depends on CF, PF
+ PRHODREF, &
+ PRCT/ZCF1D, PRRT/ZPF1D, PCCT/ZCF1D, PCRT/ZPF1D,&
+ ZLBDC, ZLBDC3, ZLBDR, ZLBDR3, &
+ P_RC_ACCR, P_CC_ACCR )
+ !
+ P_CC_ACCR(:) = P_CC_ACCR(:) * ZCF1D(:)
+ P_RC_ACCR(:) = P_RC_ACCR(:) * ZCF1D(:)
+ !
+ PA_RC(:) = PA_RC(:) + P_RC_ACCR(:)
+ PA_CC(:) = PA_CC(:) + P_CC_ACCR(:)
+ PA_RR(:) = PA_RR(:) - P_RC_ACCR(:)
END IF
!
IF (LWARM .AND. LRAIN) THEN
- CALL LIMA_DROPS_SELF_COLLECTION (LDCOMPUTE, &
+ CALL LIMA_DROPS_SELF_COLLECTION (LDCOMPUTE, & ! depends on PF
PRHODREF, &
- PCRT, ZLBDR, ZLBDR3, &
- P_CR_SCBU, &
- PA_CR )
+ PCRT/ZPF1D(:), ZLBDR, ZLBDR3, &
+ P_CR_SCBU )
+ !
+ P_CR_SCBU(:) = P_CR_SCBU(:) * ZPF1D(:)
+ !
+ PA_CR(:) = PA_CR(:) + P_CR_SCBU(:)
END IF
!
IF (LWARM .AND. LRAIN) THEN
- CALL LIMA_RAIN_EVAPORATION (PTSTEP, LDCOMPUTE, &
+ CALL LIMA_RAIN_EVAPORATION (PTSTEP, LDCOMPUTE, & ! depends on PF > CF
PRHODREF, ZT, ZLV, ZLVFACT, ZEVSAT, ZRVSAT, &
- PRVT, PRCT, PRRT, ZLBDR, &
+ PRVT, PRCT/ZPF1D, PRRT/ZPF1D, ZLBDR, &
P_TH_EVAP, P_RR_EVAP, &
- PA_RV, PA_RR, PA_TH, &
PEVAP3D )
+ P_RR_EVAP(:) = P_RR_EVAP(:) * MAX((ZPF1D(:) - ZCF1D(:)),0.)
+ P_TH_EVAP(:) = P_RR_EVAP(:) * ZLVFACT(:)
+ PEVAP3D(:) = - P_RR_EVAP(:)
+ !
+ PA_TH(:) = PA_TH(:) + P_TH_EVAP(:)
+ PA_RV(:) = PA_RV(:) - P_RR_EVAP(:)
+ PA_RR(:) = PA_RR(:) + P_RR_EVAP(:)
+END IF
+!
+IF (LCOLD) THEN
+ !
+ ! Includes vapour deposition on ice, ice -> snow conversion
+ !
+ CALL LIMA_ICE_DEPOSITION (PTSTEP, LDCOMPUTE, & ! depends on IF, PF
+ PRHODREF, ZSSI, ZAI, ZCJ, ZLSFACT, &
+ PRIT/ZIF1D, PCIT/ZIF1D, ZLBDI, &
+ P_TH_DEPI, P_RI_DEPI, &
+ P_RI_CNVS, P_CI_CNVS )
+ !
+ P_RI_DEPI(:) = P_RI_DEPI(:) * ZIF1D(:)
+ P_RI_CNVS(:) = P_RI_CNVS(:) * ZIF1D(:)
+ P_CI_CNVS(:) = P_CI_CNVS(:) * ZIF1D(:)
+ P_TH_DEPI(:) = P_RI_DEPI(:) * ZLSFACT(:)
+ !
+ PA_TH(:) = PA_TH(:) + P_TH_DEPI(:)
+ PA_RV(:) = PA_RV(:) - P_RI_DEPI(:)
+ PA_RI(:) = PA_RI(:) + P_RI_DEPI(:) + P_RI_CNVS(:)
+ PA_CI(:) = PA_CI(:) + P_CI_CNVS(:)
+ PA_RS(:) = PA_RS(:) - P_RI_CNVS(:)
+
END IF
!
IF (LCOLD .AND. LSNOW) THEN
!
- ! Includes vapour deposition on snow, ice -> snow and snow -> ice exchanges
+ ! Includes vapour deposition on snow, snow -> ice conversion
!
- CALL LIMA_ICE_SNOW_DEPOSITION (PTSTEP, LDCOMPUTE, &
- PRHODREF, ZSSI, ZAI, ZCJ, ZLSFACT, &
- PRIT, PRST, PCIT, ZLBDI, ZLBDS, &
- P_RI_CNVI, P_CI_CNVI, &
- P_TH_DEPS, P_RS_DEPS, &
- P_RI_CNVS, P_CI_CNVS, &
- PA_TH, PA_RV, PA_RI, PA_CI, PA_RS )
+ CALL LIMA_SNOW_DEPOSITION (LDCOMPUTE, & ! depends on IF, PF
+ PRHODREF, ZSSI, ZAI, ZCJ, ZLSFACT, &
+ PRST/ZPF1D, ZLBDS, &
+ P_RI_CNVI, P_CI_CNVI, &
+ P_TH_DEPS, P_RS_DEPS )
+ !
+ P_RI_CNVI(:) = P_RI_CNVI(:) * ZPF1D(:)
+ P_CI_CNVI(:) = P_CI_CNVI(:) * ZPF1D(:)
+ P_RS_DEPS(:) = P_RS_DEPS(:) * ZPF1D(:)
+ P_TH_DEPS(:) = P_RS_DEPS(:) * ZLSFACT(:)
+ !
+ PA_RI(:) = PA_RI(:) + P_RI_CNVI(:)
+ PA_CI(:) = PA_CI(:) + P_CI_CNVI(:)
+ PA_RS(:) = PA_RS(:) - P_RI_CNVI(:) + P_RS_DEPS(:)
+ PA_TH(:) = PA_TH(:) + P_TH_DEPS(:)
+ PA_RV(:) = PA_RV(:) - P_RS_DEPS(:)
+
END IF
!
! Lambda_s limited for collection processes to prevent too high concentrations
@@ -549,47 +642,87 @@ ZLBDS(:) = MIN( XLBDAS_MAX, ZLBDS(:))
!
!
IF (LCOLD .AND. LSNOW) THEN
- CALL LIMA_ICE_AGGREGATION_SNOW (LDCOMPUTE, &
- ZT, PRHODREF, &
- PRIT, PRST, PCIT, ZLBDI, ZLBDS, &
- P_RI_AGGS, P_CI_AGGS, &
- PA_RI, PA_CI, PA_RS )
+ CALL LIMA_ICE_AGGREGATION_SNOW (LDCOMPUTE, & ! depends on IF, PF
+ ZT, PRHODREF, &
+ PRIT/ZIF1D, PRST/ZPF1D, PCIT/ZIF1D, ZLBDI, ZLBDS, &
+ P_RI_AGGS, P_CI_AGGS )
+ P_CI_AGGS(:) = P_CI_AGGS(:) * ZIF1D(:)
+ P_RI_AGGS(:) = P_RI_AGGS(:) * ZIF1D(:)
+ !
+ PA_RI(:) = PA_RI(:) + P_RI_AGGS(:)
+ PA_CI(:) = PA_CI(:) + P_CI_AGGS(:)
+ PA_RS(:) = PA_RS(:) - P_RI_AGGS(:)
END IF
!
IF (LWARM .AND. LCOLD) THEN
- CALL LIMA_GRAUPEL_DEPOSITION (LDCOMPUTE, PRHODREF, &
- PRGT, ZSSI, ZLBDG, ZAI, ZCJ, ZLSFACT, &
- P_TH_DEPG, P_RG_DEPG, &
- PA_TH, PA_RV, PA_RG )
+ CALL LIMA_GRAUPEL_DEPOSITION (LDCOMPUTE, PRHODREF, & ! depends on PF ?
+ PRGT/ZPF1D, ZSSI, ZLBDG, ZAI, ZCJ, ZLSFACT, &
+ P_TH_DEPG, P_RG_DEPG )
+ P_RG_DEPG(:) = P_RG_DEPG(:) * ZPF1D(:)
+ P_TH_DEPG(:) = P_RG_DEPG(:) * ZLSFACT(:)
+ !
+ PA_RV(:) = PA_RV(:) - P_RG_DEPG(:)
+ PA_RG(:) = PA_RG(:) + P_RG_DEPG(:)
+ PA_TH(:) = PA_TH(:) + P_TH_DEPG(:)
END IF
!
-IF (LWARM .AND. LCOLD) THEN
- CALL LIMA_BERGERON (LDCOMPUTE, &
- PRCT, PRIT, PCIT, ZLBDI, &
- ZSSIW, ZAI, ZCJ, ZLVFACT, ZLSFACT, &
- P_TH_BERFI, P_RC_BERFI, &
- PA_TH, PA_RC, PA_RI )
-END IF
+!!$IF (LWARM .AND. LCOLD) THEN
+!!$ CALL LIMA_BERGERON (LDCOMPUTE, & ! depends on CF, IF
+!!$ PRCT, PRIT, PCIT, ZLBDI, &
+!!$ ZSSIW, ZAI, ZCJ, ZLVFACT, ZLSFACT, &
+!!$ P_TH_BERFI, P_RC_BERFI, &
+!!$ PA_TH, PA_RC, PA_RI )
+!!$END IF
+P_TH_BERFI(:) = 0.
+P_RC_BERFI(:) = 0.
+!
!
IF (LWARM .AND. LCOLD .AND. LSNOW) THEN
!
! Graupel production as tendency (or should be tendency + instant to stick to the previous version ?)
! Includes the Hallett Mossop process for riming of droplets by snow (HMS)
!
- CALL LIMA_DROPLETS_RIMING_SNOW (PTSTEP, LDCOMPUTE, &
+ CALL LIMA_DROPLETS_RIMING_SNOW (PTSTEP, LDCOMPUTE, & ! depends on CF
PRHODREF, ZT, &
- PRCT, PCCT, PRST, ZLBDC, ZLBDS, ZLVFACT, ZLSFACT, &
+ PRCT/ZCF1D, PCCT/ZCF1D, PRST/ZPF1D, ZLBDC, ZLBDS, ZLVFACT, ZLSFACT, &
P_TH_RIM, P_RC_RIM, P_CC_RIM, P_RS_RIM, P_RG_RIM, &
- P_RI_HMS, P_CI_HMS, P_RS_HMS, &
- PA_TH, PA_RC, PA_CC, PA_RI, PA_CI, PA_RS, PA_RG )
+ P_RI_HMS, P_CI_HMS, P_RS_HMS )
+ P_RC_RIM(:) = P_RC_RIM(:) * ZCF1D(:)
+ P_CC_RIM(:) = P_CC_RIM(:) * ZCF1D(:)
+ P_RS_RIM(:) = P_RS_RIM(:) * ZCF1D(:)
+ P_RG_RIM(:) = P_RG_RIM(:) * ZCF1D(:)
+ P_TH_RIM(:) = - P_RC_RIM(:) * (ZLSFACT(:)-ZLVFACT(:))
+ P_RI_HMS(:) = P_RI_HMS(:) * ZCF1D(:)
+ P_CI_HMS(:) = P_CI_HMS(:) * ZCF1D(:)
+ P_RS_HMS(:) = P_RS_HMS(:) * ZCF1D(:)
+ !
+ PA_RC(:) = PA_RC(:) + P_RC_RIM(:)
+ PA_CC(:) = PA_CC(:) + P_CC_RIM(:)
+ PA_RI(:) = PA_RI(:) + P_RI_HMS(:)
+ PA_CI(:) = PA_CI(:) + P_CI_HMS(:)
+ PA_RS(:) = PA_RS(:) + P_RS_RIM(:) + P_RS_HMS(:)
+ PA_RG(:) = PA_RG(:) + P_RG_RIM(:)
+ PA_TH(:) = PA_TH(:) + P_TH_RIM(:)
+
END IF
!
IF (LWARM .AND. LRAIN .AND. LCOLD .AND. LSNOW) THEN
- CALL LIMA_RAIN_ACCR_SNOW (PTSTEP, LDCOMPUTE, &
+ CALL LIMA_RAIN_ACCR_SNOW (PTSTEP, LDCOMPUTE, & ! depends on PF
PRHODREF, ZT, &
- PRRT, PCRT, PRST, ZLBDR, ZLBDS, ZLVFACT, ZLSFACT, &
- P_TH_ACC, P_RR_ACC, P_CR_ACC, P_RS_ACC, P_RG_ACC, &
- PA_TH, PA_RR, PA_CR, PA_RS, PA_RG )
+ PRRT/ZPF1D, PCRT/ZPF1D, PRST/ZPF1D, ZLBDR, ZLBDS, ZLVFACT, ZLSFACT, &
+ P_TH_ACC, P_RR_ACC, P_CR_ACC, P_RS_ACC, P_RG_ACC )
+ P_RR_ACC(:) = P_RR_ACC(:) * ZPF1D(:)
+ P_CR_ACC(:) = P_CR_ACC(:) * ZPF1D(:)
+ P_RS_ACC(:) = P_RS_ACC(:) * ZPF1D(:)
+ P_RG_ACC(:) = P_RG_ACC(:) * ZPF1D(:)
+ P_TH_ACC(:) = - P_RR_ACC(:) * (ZLSFACT(:)-ZLVFACT(:))
+ !
+ PA_RR(:) = PA_RR(:) + P_RR_ACC(:)
+ PA_CR(:) = PA_CR(:) + P_CR_ACC(:)
+ PA_RS(:) = PA_RS(:) + P_RS_ACC(:)
+ PA_RG(:) = PA_RG(:) + P_RG_ACC(:)
+ PA_TH(:) = PA_TH(:) + P_TH_ACC(:)
+
END IF
!
IF (LWARM .AND. LCOLD .AND. LSNOW) THEN
@@ -597,19 +730,35 @@ IF (LWARM .AND. LCOLD .AND. LSNOW) THEN
! Conversion melting of snow should account for collected droplets and drops where T>0C, but does not !
! Some thermodynamical computations inside, to externalize ?
!
- CALL LIMA_CONVERSION_MELTING_SNOW (LDCOMPUTE, &
+ CALL LIMA_CONVERSION_MELTING_SNOW (LDCOMPUTE, & ! depends on PF
PRHODREF, PPABST, ZT, ZKA, ZDV, ZCJ, &
- PRVT, PRST, ZLBDS, &
- P_RS_CMEL, &
- PA_RS, PA_RG )
+ PRVT, PRST/ZPF1D, ZLBDS, &
+ P_RS_CMEL )
+ P_RS_CMEL(:) = P_RS_CMEL(:) * ZPF1D(:)
+ !
+ PA_RS(:) = PA_RS(:) + P_RS_CMEL(:)
+ PA_RG(:) = PA_RG(:) - P_RS_CMEL(:)
+
END IF
!
IF (LWARM .AND. LRAIN .AND. LCOLD ) THEN
- CALL LIMA_RAIN_FREEZING (LDCOMPUTE, &
+ CALL LIMA_RAIN_FREEZING (LDCOMPUTE, & ! depends on PF, IF
PRHODREF, ZT, ZLVFACT, ZLSFACT, &
- PRRT, PCRT, PRIT, PCIT, ZLBDR, &
- P_TH_CFRZ, P_RR_CFRZ, P_CR_CFRZ, P_RI_CFRZ, P_CI_CFRZ, &
- PA_TH, PA_RR, PA_CR, PA_RI, PA_CI, PA_RG )
+ PRRT/ZPF1D, PCRT/ZPF1D, PRIT/ZIF1D, PCIT/ZIF1D, ZLBDR, &
+ P_TH_CFRZ, P_RR_CFRZ, P_CR_CFRZ, P_RI_CFRZ, P_CI_CFRZ )
+ P_RR_CFRZ(:) = P_RR_CFRZ(:) * ZIF1D(:)
+ P_CR_CFRZ(:) = P_CR_CFRZ(:) * ZIF1D(:)
+ P_RI_CFRZ(:) = P_RI_CFRZ(:) * ZIF1D(:)
+ P_CI_CFRZ(:) = P_CI_CFRZ(:) * ZIF1D(:)
+ P_TH_CFRZ(:) = - P_RR_CFRZ(:) * (ZLSFACT(:)-ZLVFACT(:))
+!
+ PA_TH(:) = PA_TH(:) + P_TH_CFRZ(:)
+ PA_RR(:) = PA_RR(:) + P_RR_CFRZ(:)
+ PA_CR(:) = PA_CR(:) + P_CR_CFRZ(:)
+ PA_RI(:) = PA_RI(:) + P_RI_CFRZ(:)
+ PA_CI(:) = PA_CI(:) + P_CI_CFRZ(:)
+ PA_RG(:) = PA_RG(:) - P_RR_CFRZ(:) - P_RI_CFRZ(:)
+
END IF
!
IF (LWARM .AND. LCOLD) THEN
@@ -620,7 +769,7 @@ IF (LWARM .AND. LCOLD) THEN
! Includes Hallett-Mossop process for riming of droplets by graupel (HMG)
! Some thermodynamical computations inside, to externalize ?
!
- CALL LIMA_GRAUPEL (PTSTEP, LDCOMPUTE, &
+ CALL LIMA_GRAUPEL (PTSTEP, LDCOMPUTE, & ! depends on PF, CF, IF
PRHODREF, PPABST, ZT, ZKA, ZDV, ZCJ, &
PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
PCCT, PCRT, PCIT, &
diff --git a/src/MNH/lima_warm.f90 b/src/MNH/lima_warm.f90
index ff1523ffd7e7d2fd9f3f116a3feefc0ffcd2f2b1..b3989e7a25e1d7101f0504fc1e774f8efce25024 100644
--- a/src/MNH/lima_warm.f90
+++ b/src/MNH/lima_warm.f90
@@ -131,6 +131,7 @@ END MODULE MODI_LIMA_WARM
! B. Vie 03/03/2020: use DTHRAD instead of dT/dt in Smax diagnostic computation
! P. Wautelet 28/05/2020: bugfix: correct array start for PSVT and PSVS
! P. Wautelet 02/02/2021: budgets: add missing source terms for SV budgets in LIMA
+! B. Vie 06/2021 Add prognostic supersaturation for LIMA
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
@@ -374,11 +375,12 @@ IF ( LACTI .AND. NMOD_CCN > 0 ) THEN
call Budget_store_init( tbudgets(idx), 'HENU', znas(:, :, :, jl) * prhodj(:, :, :) )
end do
end if
-
- CALL LIMA_WARM_NUCL( OACTIT, PTSTEP, KMI, TPFILE, &
- PRHODREF, PEXNREF, PPABST, ZT, PTHM, PW_NU, &
- PRCM, PRVT, PRCT, PRRT, &
- PTHS, PRVS, PRCS, PCCS, ZNFS, ZNAS )
+ IF (.NOT. LSPRO) THEN
+ CALL LIMA_WARM_NUCL(OACTIT, PTSTEP, KMI, TPFILE, &
+ PRHODREF, PEXNREF, PPABST, ZT, PTHM, PW_NU, &
+ PRCM, PRVT, PRCT, PRRT, &
+ PTHS, PRVS, PRCS, PCCS, ZNFS, ZNAS )
+ END IF
if ( lbudget_th ) call Budget_store_end( tbudgets(NBUDGET_TH), 'HENU', pths(:, :, :) * prhodj(:, :, :) )
if ( lbudget_rv ) call Budget_store_end( tbudgets(NBUDGET_RV), 'HENU', prvs(:, :, :) * prhodj(:, :, :) )
diff --git a/src/MNH/lima_warm_nucl.f90 b/src/MNH/lima_warm_nucl.f90
index a0e6ac692cb57fbbf87a0a3d8f287951d593255b..549a5fc8460f4ac857a2171b64b324f9aec84b95 100644
--- a/src/MNH/lima_warm_nucl.f90
+++ b/src/MNH/lima_warm_nucl.f90
@@ -167,6 +167,7 @@ INTEGER , DIMENSION(SIZE(GNUCT)) :: I1,I2,I3 ! Used to replace the COUNT
INTEGER :: JL ! and PACK intrinsics
!
! Packed micophysical variables
+REAL, DIMENSION(:) , ALLOCATABLE :: ZRCS ! cloud mr source
REAL, DIMENSION(:) , ALLOCATABLE :: ZCCS ! cloud conc. source
REAL, DIMENSION(:,:), ALLOCATABLE :: ZNFS ! available nucleus conc. source
REAL, DIMENSION(:,:), ALLOCATABLE :: ZNAS ! activated nucleus conc. source
@@ -223,26 +224,9 @@ ZCTMIN(:) = XCTMIN(:) / PTSTEP
! Saturation vapor mixing ratio and radiative tendency
!
ZEPS= XMV / XMD
-!
-ZRVSAT(:,:,:) = ZEPS / (PPABST(:,:,:) * &
- EXP(-XALPW+XBETAW/PT(:,:,:)+XGAMW*ALOG(PT(:,:,:))) - 1.0)
+ZRVSAT(:,:,:) = ZEPS / (PPABST(:,:,:)*EXP(-XALPW+XBETAW/PT(:,:,:)+XGAMW*ALOG(PT(:,:,:))) - 1.0)
ZTDT(:,:,:) = 0.
-!! ZDRC(:,:,:) = 0.
-IF (OACTIT .AND. SIZE(PTM).GT.0) THEN
- ZTDT(:,:,:) = PTM(:,:,:) ! dThRad
-! ZTDT(:,:,:) = (PT(:,:,:)-PTM(:,:,:))/PTSTEP ! dT/dt
-!!! JPP
-!!! JPP
-!!! ZDRC(:,:,:) = (PRCT(:,:,:)-PRCM(:,:,:))/PTSTEP ! drc/dt
-!! ZDRC(:,:,:) = PRCS(:,:,:)-(PRCT(:,:,:)/PTSTEP) ! drc/dt
-!!! JPP
-!!! JPP
-!!
-!! BV - W and drc/dt effect should not be included in ZTDT (already accounted for in the computations) ?
-!!
-!! ZTDT(:,:,:) = MIN(0.,ZTDT(:,:,:)+(XG*PW_NU(:,:,:))/XCPD- &
-!! (XLVTT+(XCPV-XCL)*(PT(:,:,:)-XTT))*ZDRC(:,:,:)/XCPD)
-END IF
+IF (OACTIT .AND. SIZE(PTM).GT.0) ZTDT(:,:,:) = PTM(:,:,:) * PEXNREF(:,:,:) ! dThRad
!
! find locations where CCN are available
!
@@ -261,24 +245,24 @@ IF( OACTIT ) THEN
GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) = (PW_NU(IIB:IIE,IJB:IJE,IKB:IKE)>XWMIN .OR. &
ZTDT(IIB:IIE,IJB:IJE,IKB:IKE)<XTMIN .OR. &
PRVT(IIB:IIE,IJB:IJE,IKB:IKE)>ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE) ) .AND.&
- PRVT(IIB:IIE,IJB:IJE,IKB:IKE)>(0.98*ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE))&
+ PRVT(IIB:IIE,IJB:IJE,IKB:IKE).GE.ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE)&
.AND. PT(IIB:IIE,IJB:IJE,IKB:IKE)>(XTT-22.) &
- .AND. ZCONC_TOT(IIB:IIE,IJB:IJE,IKB:IKE)>ZCTMIN(4)
+ .AND. ZCONC_TOT(IIB:IIE,IJB:IJE,IKB:IKE)>ZCTMIN(2)
ELSE
GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) = (PW_NU(IIB:IIE,IJB:IJE,IKB:IKE)>XWMIN .OR. &
PRVT(IIB:IIE,IJB:IJE,IKB:IKE)>ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE) ) .AND.&
- PRVT(IIB:IIE,IJB:IJE,IKB:IKE)>(0.98*ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE))&
+ PRVT(IIB:IIE,IJB:IJE,IKB:IKE).GE.ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE)&
.AND. PT(IIB:IIE,IJB:IJE,IKB:IKE)>(XTT-22.) &
- .AND. ZCONC_TOT(IIB:IIE,IJB:IJE,IKB:IKE)>ZCTMIN(4)
+ .AND. ZCONC_TOT(IIB:IIE,IJB:IJE,IKB:IKE)>ZCTMIN(2)
END IF
INUCT = COUNTJV( GNUCT(:,:,:),I1(:),I2(:),I3(:))
!
-!
IF( INUCT >= 1 ) THEN
!
ALLOCATE(ZNFS(INUCT,NMOD_CCN))
ALLOCATE(ZNAS(INUCT,NMOD_CCN))
ALLOCATE(ZTMP(INUCT,NMOD_CCN))
+ ALLOCATE(ZRCS(INUCT))
ALLOCATE(ZCCS(INUCT))
ALLOCATE(ZZT(INUCT))
ALLOCATE(ZZTDT(INUCT))
@@ -295,6 +279,7 @@ IF( INUCT >= 1 ) THEN
ALLOCATE(ZRHODREF(INUCT))
ALLOCATE(ZEXNREF(INUCT))
DO JL=1,INUCT
+ ZRCS(JL) = PRCS(I1(JL),I2(JL),I3(JL))
ZCCS(JL) = PCCS(I1(JL),I2(JL),I3(JL))
ZZT(JL) = PT(I1(JL),I2(JL),I3(JL))
ZZW1(JL) = ZRVSAT(I1(JL),I2(JL),I3(JL))
@@ -324,8 +309,7 @@ IF( INUCT >= 1 ) THEN
! Remark : in LIMA's nucleation parameterization, Smax=0.01 for a supersaturation of 1% !
!
!
- ZVEC1(:) = MAX( 1.0001, MIN( REAL(NAHEN)-0.0001, &
- XAHENINTP1 * ZZT(:) + XAHENINTP2 ) )
+ ZVEC1(:) = MAX( 1.0001, MIN( REAL(NAHEN)-0.0001, XAHENINTP1 * ZZT(:) + XAHENINTP2 ) )
IVEC1(:) = INT( ZVEC1(:) )
ZVEC1(:) = ZVEC1(:) - REAL( IVEC1(:) )
ALLOCATE(ZSMAX(INUCT))
@@ -349,6 +333,8 @@ IF( INUCT >= 1 ) THEN
ZZW3(:) = XAHENG( IVEC1(:)+1)*(ZZW4(:)**1.5)* ZVEC1(:) &
- XAHENG( IVEC1(:) )*(ZZW5(:)**1.5)*(ZVEC1(:) - 1.0)
! Cste*((Psi1*w+Psi3*dT/dt)/(G))**1.5
+ ZZW6(:) = XAHENG2( IVEC1(:)+1)*(ZZW4(:)**0.5)* ZVEC1(:) &
+ - XAHENG2( IVEC1(:) )*(ZZW5(:)**0.5)*(ZVEC1(:) - 1.0)
!
!
ELSE ! OACTIT , for clouds
@@ -364,6 +350,9 @@ IF( INUCT >= 1 ) THEN
ZZW2(:)=MAX(ZZW2(:),0.)
ZZW3(:)=XAHENG(IVEC1(:)+1)*((XPSI1(IVEC1(:)+1)*ZZW2(:))**1.5)* ZVEC1(:) &
-XAHENG(IVEC1(:) )*((XPSI1(IVEC1(:) )*ZZW2(:))**1.5)*(ZVEC1(:)-1.0)
+!
+ ZZW6(:)=XAHENG2(IVEC1(:)+1)*((XPSI1(IVEC1(:)+1)*ZZW2(:))**0.5)* ZVEC1(:) &
+ -XAHENG2(IVEC1(:) )*((XPSI1(IVEC1(:) )*ZZW2(:))**0.5)*(ZVEC1(:)-1.0)
!
END IF ! OACTIT
!
@@ -374,12 +363,17 @@ IF( INUCT >= 1 ) THEN
!
ZZW5(:) = 1.
ZZW3(:) = (ZZW3(:)/ZZW1(:))*ZRHODREF(:) ! R.H.S. of Eq 9 of CPB 98 but
- ! for multiple aerosol modes
+ ! for multiple aerosol modes
+ WHERE (ZRCS(:) > XRTMIN(2) .AND. ZCCS(:) > XCTMIN(2))
+ ZZW6(:) = ZZW6(:) * ZRHODREF(:) * ZCCS(:) * PTSTEP / (XLBC*ZCCS(:)/ZRCS(:))**XLBEXC
+ ELSEWHERE
+ ZZW6(:)=0.
+ END WHERE
+
WHERE (ZZW3(:) == 0. .AND. .NOT.(ZSW>0.))
ZZW5(:) = -1.
END WHERE
!
-!
!-------------------------------------------------------------------------------
!
!
@@ -394,9 +388,9 @@ IF( INUCT >= 1 ) THEN
! Check with values used for tabulation in ini_lima_warm.f90
ZS1 = 1.0E-5 ! corresponds to 0.001% supersaturation
ZS2 = 5.0E-2 ! corresponds to 5.0% supersaturation
- ZXACC = 1.0E-7 ! Accuracy needed for the search in [NO UNITS]
+ ZXACC = 1.0E-10 ! Accuracy needed for the search in [NO UNITS]
!
- ZSMAX(:) = ZRIDDR(ZS1,ZS2,ZXACC,ZZW3(:),INUCT) ! ZSMAX(:) is in [NO UNITS]
+ ZSMAX(:) = ZRIDDR(ZS1,ZS2,ZXACC,ZZW3(:),ZZW6(:),INUCT) ! ZSMAX(:) is in [NO UNITS]
ZSMAX(:) = MIN(MAX(ZSMAX(:), ZSW(:)),ZS2)
!
!
@@ -411,8 +405,7 @@ IF( INUCT >= 1 ) THEN
! Modified values for Beta and C (see in init_aerosol_properties) account for that
!
WHERE (ZZW5(:) > 0. .AND. ZSMAX(:) > 0.)
- ZVEC1(:) = MAX( 1.0001, MIN( REAL(NHYP)-0.0001, &
- XHYPINTP1*LOG(ZSMAX(:))+XHYPINTP2 ) )
+ ZVEC1(:) = MAX( 1.0001, MIN( REAL(NHYP)-0.0001, XHYPINTP1*LOG(ZSMAX(:))+XHYPINTP2 ) )
IVEC1(:) = INT( ZVEC1(:) )
ZVEC1(:) = ZVEC1(:) - REAL( IVEC1(:) )
END WHERE
@@ -428,12 +421,11 @@ IF( INUCT >= 1 ) THEN
ZZW2(:) = 0.
ZZW3(:) = 0.
!
- WHERE( ZSMAX(:)>0.0 )
+ WHERE( ZZW5(:) > 0. .AND. ZSMAX(:)>0.0 )
ZZW2(:) = XHYPF12( IVEC1(:)+1,JMOD )* ZVEC1(:) & ! hypergeo function
- XHYPF12( IVEC1(:) ,JMOD )*(ZVEC1(:) - 1.0) ! XHYPF12 is tabulated
!
- ZTMP(:,JMOD) = (ZCHEN_MULTI(:,JMOD)/ZRHODREF(:))*ZSMAX(:)**XKHEN_MULTI(JMOD) &
- *ZZW2(:)/PTSTEP
+ ZTMP(:,JMOD) = ZCHEN_MULTI(:,JMOD)/ZRHODREF(:)*ZSMAX(:)**XKHEN_MULTI(JMOD)*ZZW2(:)/PTSTEP
ENDWHERE
ENDDO
!
@@ -445,19 +437,17 @@ IF( INUCT >= 1 ) THEN
ZZW2(:) = 0.
ZZW3(:) = 0.
!
- WHERE( SUM(ZTMP(:,:),DIM=2)*PTSTEP .GT. 15.E6/ZRHODREF(:) )
+ WHERE( SUM(ZTMP(:,:),DIM=2)*PTSTEP .GT. 0.01E6/ZRHODREF(:) )
ZZW1(:) = MIN( ZNFS(:,JMOD),MAX( ZTMP(:,JMOD)- ZNAS(:,JMOD) , 0.0 ) )
ENDWHERE
!
!* update the concentration of activated CCN = Na
!
- PNAS(:,:,:,JMOD) = PNAS(:,:,:,JMOD) + &
- UNPACK( ZZW1(:), MASK=GNUCT(:,:,:), FIELD=0.0 )
+ PNAS(:,:,:,JMOD) = PNAS(:,:,:,JMOD) + UNPACK( ZZW1(:), MASK=GNUCT(:,:,:), FIELD=0.0 )
!
!* update the concentration of free CCN = Nf
!
- PNFS(:,:,:,JMOD) = PNFS(:,:,:,JMOD) - &
- UNPACK( ZZW1(:), MASK=GNUCT(:,:,:), FIELD=0.0 )
+ PNFS(:,:,:,JMOD) = PNFS(:,:,:,JMOD) - UNPACK( ZZW1(:), MASK=GNUCT(:,:,:), FIELD=0.0 )
!
!* prepare to update the cloud water concentration
!
@@ -497,6 +487,7 @@ IF( INUCT >= 1 ) THEN
DEALLOCATE(ZNFS)
DEALLOCATE(ZNAS)
DEALLOCATE(ZCCS)
+ DEALLOCATE(ZRCS)
DEALLOCATE(ZZT)
DEALLOCATE(ZSMAX)
DEALLOCATE(ZZW1)
@@ -558,7 +549,7 @@ END IF
CONTAINS
!------------------------------------------------------------------------------
!
- FUNCTION ZRIDDR(PX1,PX2INIT,PXACC,PZZW3,NPTS) RESULT(PZRIDDR)
+ FUNCTION ZRIDDR(PX1,PX2INIT,PXACC,PZZW3,PZZW6,NPTS) RESULT(PZRIDDR)
!
!
!!**** *ZRIDDR* - iterative algorithm to find root of a function
@@ -612,6 +603,7 @@ IMPLICIT NONE
!
INTEGER, INTENT(IN) :: NPTS
REAL, DIMENSION(:), INTENT(IN) :: PZZW3
+REAL, DIMENSION(:), INTENT(IN) :: PZZW6
REAL, INTENT(IN) :: PX1, PX2INIT, PXACC
REAL, DIMENSION(:), ALLOCATABLE :: PZRIDDR
!
@@ -633,8 +625,8 @@ ALLOCATE(PZRIDDR(NPTS))
!
PZRIDDR(:)= UNUSED
PX2 = PX2INIT
-fl(:) = FUNCSMAX(PX1,PZZW3(:),NPTS)
-fh(:) = FUNCSMAX(PX2,PZZW3(:),NPTS)
+fl(:) = FUNCSMAX(PX1,PZZW3(:),PZZW6(:),NPTS)
+fh(:) = FUNCSMAX(PX2,PZZW3(:),PZZW6(:),NPTS)
!
DO JL = 1, NPTS
PX2 = PX2INIT
@@ -643,7 +635,7 @@ DO JL = 1, NPTS
xh = PX2
do j=1,MAXIT
xm = 0.5*(xl+xh)
- fm(JL) = SINGL_FUNCSMAX(xm,PZZW3(JL),JL)
+ fm(JL) = SINGL_FUNCSMAX(xm,PZZW3(JL),PZZW6(JL),JL)
s = sqrt(fm(JL)**2-fl(JL)*fh(JL))
if (s == 0.0) then
GO TO 101
@@ -653,7 +645,7 @@ DO JL = 1, NPTS
GO TO 101
endif
PZRIDDR(JL) = xnew
- fnew(JL) = SINGL_FUNCSMAX(PZRIDDR(JL),PZZW3(JL),JL)
+ fnew(JL) = SINGL_FUNCSMAX(PZRIDDR(JL),PZZW3(JL),PZZW6(JL),JL)
if (fnew(JL) == 0.0) then
GO TO 101
endif
@@ -671,7 +663,7 @@ DO JL = 1, NPTS
else if (PX2 .lt. 0.05) then
PX2 = PX2 + 1.0E-2
PRINT*, 'PX2 ALWAYS too small, we put a greater one : PX2 =',PX2
- fh(JL) = SINGL_FUNCSMAX(PX2,PZZW3(JL),JL)
+ fh(JL) = SINGL_FUNCSMAX(PX2,PZZW3(JL),PZZW6(JL),JL)
go to 100
end if
if (abs(xh-xl) <= PXACC) then
@@ -692,7 +684,7 @@ DO JL = 1, NPTS
else if (PX2 .lt. 0.05) then
PX2 = PX2 + 1.0E-2
PRINT*, 'PX2 too small, we put a greater one : PX2 =',PX2
- fh(JL) = SINGL_FUNCSMAX(PX2,PZZW3(JL),JL)
+ fh(JL) = SINGL_FUNCSMAX(PX2,PZZW3(JL),PZZW6(JL),JL)
go to 100
else
!!$ print*, 'PZRIDDR: root must be bracketed'
@@ -715,7 +707,7 @@ END FUNCTION ZRIDDR
!
!------------------------------------------------------------------------------
!
- FUNCTION FUNCSMAX(PPZSMAX,PPZZW3,NPTS) RESULT(PFUNCSMAX)
+ FUNCTION FUNCSMAX(PPZSMAX,PPZZW3,PPZZW6,NPTS) RESULT(PFUNCSMAX)
!
!
!!**** *FUNCSMAX* - function describing SMAX function that you want to find the root
@@ -774,6 +766,7 @@ IMPLICIT NONE
INTEGER, INTENT(IN) :: NPTS
REAL, INTENT(IN) :: PPZSMAX ! supersaturation is already in no units
REAL, DIMENSION(:), INTENT(IN) :: PPZZW3 !
+REAL, DIMENSION(:), INTENT(IN) :: PPZZW6 !
REAL, DIMENSION(:), ALLOCATABLE :: PFUNCSMAX !
!
!* 0.2 declarations of local variables
@@ -801,13 +794,13 @@ DO JMOD = 1, NMOD_CCN
/ GAMMA_X0D((XKHEN_MULTI(JMOD)+3.0)/2.0)
ENDDO
! function l.h.s. minus r.h.s. of eq. (9) of CPB98 but for NMOD_CCN aerosol mode
-PFUNCSMAX(:) = PFUNCSMAX(:) - PPZZW3(:)
+PFUNCSMAX(:) = PFUNCSMAX(:) + PPZZW6(:)*PPZSMAX - PPZZW3(:)
!
END FUNCTION FUNCSMAX
!
!------------------------------------------------------------------------------
!
- FUNCTION SINGL_FUNCSMAX(PPZSMAX,PPZZW3,KINDEX) RESULT(PSINGL_FUNCSMAX)
+ FUNCTION SINGL_FUNCSMAX(PPZSMAX,PPZZW3,PPZZW6,KINDEX) RESULT(PSINGL_FUNCSMAX)
!
!
!!**** *SINGL_FUNCSMAX* - same function as FUNCSMAX
@@ -832,6 +825,7 @@ IMPLICIT NONE
INTEGER, INTENT(IN) :: KINDEX
REAL, INTENT(IN) :: PPZSMAX ! supersaturation is "no unit"
REAL, INTENT(IN) :: PPZZW3 !
+REAL, INTENT(IN) :: PPZZW6 !
REAL :: PSINGL_FUNCSMAX !
!
!* 0.2 declarations of local variables
@@ -857,7 +851,7 @@ DO JMOD = 1, NMOD_CCN
/ GAMMA_X0D((XKHEN_MULTI(JMOD)+3.0)/2.0)
ENDDO
! function l.h.s. minus r.h.s. of eq. (9) of CPB98 but for NMOD_CCN aerosol mode
-PSINGL_FUNCSMAX = PSINGL_FUNCSMAX - PPZZW3
+PSINGL_FUNCSMAX = PSINGL_FUNCSMAX + PPZZW6*PPZSMAX - PPZZW3
!
END FUNCTION SINGL_FUNCSMAX
!
diff --git a/src/MNH/minpack.f90 b/src/MNH/minpack.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c927712e40538d3f25197984d88e40d459f953e7
--- /dev/null
+++ b/src/MNH/minpack.f90
@@ -0,0 +1,5780 @@
+!!$ Minpack Copyright Notice (1999) University of Chicago. All rights reserved
+!!$
+!!$ Redistribution and use in source and binary forms, with or
+!!$ without modification, are permitted provided that the
+!!$ following conditions are met:
+!!$
+!!$ 1. Redistributions of source code must retain the above
+!!$ copyright notice, this list of conditions and the following
+!!$ disclaimer.
+!!$
+!!$ 2. Redistributions in binary form must reproduce the above
+!!$ copyright notice, this list of conditions and the following
+!!$ disclaimer in the documentation and/or other materials
+!!$ provided with the distribution.
+!!$
+!!$ 3. The end-user documentation included with the
+!!$ redistribution, if any, must include the following
+!!$ acknowledgment:
+!!$
+!!$ "This product includes software developed by the
+!!$ University of Chicago, as Operator of Argonne National
+!!$ Laboratory."
+!!$
+!!$ Alternately, this acknowledgment may appear in the software
+!!$ itself, if and wherever such third-party acknowledgments
+!!$ normally appear.
+!!$
+!!$ 4. WARRANTY DISCLAIMER. THE SOFTWARE IS SUPPLIED "AS IS"
+!!$ WITHOUT WARRANTY OF ANY KIND. THE COPYRIGHT HOLDER, THE
+!!$ UNITED STATES, THE UNITED STATES DEPARTMENT OF ENERGY, AND
+!!$ THEIR EMPLOYEES: (1) DISCLAIM ANY WARRANTIES, EXPRESS OR
+!!$ IMPLIED, INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES
+!!$ OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, TITLE
+!!$ OR NON-INFRINGEMENT, (2) DO NOT ASSUME ANY LEGAL LIABILITY
+!!$ OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, OR
+!!$ USEFULNESS OF THE SOFTWARE, (3) DO NOT REPRESENT THAT USE OF
+!!$ THE SOFTWARE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS, (4)
+!!$ DO NOT WARRANT THAT THE SOFTWARE WILL FUNCTION
+!!$ UNINTERRUPTED, THAT IT IS ERROR-FREE OR THAT ANY ERRORS WILL
+!!$ BE CORRECTED.
+!!$
+!!$ 5. LIMITATION OF LIABILITY. IN NO EVENT WILL THE COPYRIGHT
+!!$ HOLDER, THE UNITED STATES, THE UNITED STATES DEPARTMENT OF
+!!$ ENERGY, OR THEIR EMPLOYEES: BE LIABLE FOR ANY INDIRECT,
+!!$ INCIDENTAL, CONSEQUENTIAL, SPECIAL OR PUNITIVE DAMAGES OF
+!!$ ANY KIND OR NATURE, INCLUDING BUT NOT LIMITED TO LOSS OF
+!!$ PROFITS OR LOSS OF DATA, FOR ANY REASON WHATSOEVER, WHETHER
+!!$ SUCH LIABILITY IS ASSERTED ON THE BASIS OF CONTRACT, TORT
+!!$ (INCLUDING NEGLIGENCE OR STRICT LIABILITY), OR OTHERWISE,
+!!$ EVEN IF ANY OF SAID PARTIES HAS BEEN WARNED OF THE
+!!$ POSSIBILITY OF SUCH LOSS OR DAMAGES.
+
+subroutine chkder ( m, n, x, fvec, fjac, ldfjac, xp, fvecp, mode, err )
+
+!*****************************************************************************80
+!
+!! CHKDER checks the gradients of M functions of N variables.
+!
+! Discussion:
+!
+! CHKDER checks the gradients of M nonlinear functions in N variables,
+! evaluated at a point X, for consistency with the functions themselves.
+!
+! The user calls CHKDER twice, first with MODE = 1 and then with MODE = 2.
+!
+! MODE = 1.
+! On input,
+! X contains the point of evaluation.
+! On output,
+! XP is set to a neighboring point.
+!
+! Now the user must evaluate the function and gradients at X, and the
+! function at XP. Then the subroutine is called again:
+!
+! MODE = 2.
+! On input,
+! FVEC contains the function values at X,
+! FJAC contains the function gradients at X.
+! FVECP contains the functions evaluated at XP.
+! On output,
+! ERR contains measures of correctness of the respective gradients.
+!
+! The subroutine does not perform reliably if cancellation or
+! rounding errors cause a severe loss of significance in the
+! evaluation of a function. Therefore, none of the components
+! of X should be unusually small (in particular, zero) or any
+! other value which may cause loss of significance.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, integer ( kind = 4 ) M, is the number of functions.
+!
+! Input, integer ( kind = 4 ) N, is the number of variables.
+!
+! Input, real ( kind = 8 ) X(N), the point at which the jacobian is to be
+! evaluated.
+!
+! Input, real ( kind = 8 ) FVEC(M), is used only when MODE = 2.
+! In that case, it should contain the function values at X.
+!
+! Input, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array. When MODE = 2,
+! FJAC(I,J) should contain the value of dF(I)/dX(J).
+!
+! Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC.
+! LDFJAC must be at least M.
+!
+! Output, real ( kind = 8 ) XP(N), on output with MODE = 1, is a neighboring
+! point of X, at which the function is to be evaluated.
+!
+! Input, real ( kind = 8 ) FVECP(M), on input with MODE = 2, is the function
+! value at XP.
+!
+! Input, integer ( kind = 4 ) MODE, should be set to 1 on the first call, and
+! 2 on the second.
+!
+! Output, real ( kind = 8 ) ERR(M). On output when MODE = 2, ERR contains
+! measures of correctness of the respective gradients. If there is no
+! severe loss of significance, then if ERR(I):
+! = 1.0D+00, the I-th gradient is correct,
+! = 0.0D+00, the I-th gradient is incorrect.
+! > 0.5D+00, the I-th gradient is probably correct.
+! < 0.5D+00, the I-th gradient is probably incorrect.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldfjac
+ integer ( kind = 4 ) m
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) eps
+ real ( kind = 8 ) epsf
+ real ( kind = 8 ) epslog
+ real ( kind = 8 ) epsmch
+ real ( kind = 8 ) err(m)
+ real ( kind = 8 ) fjac(ldfjac,n)
+ real ( kind = 8 ) fvec(m)
+ real ( kind = 8 ) fvecp(m)
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) j
+ integer ( kind = 4 ) mode
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) x(n)
+ real ( kind = 8 ) xp(n)
+
+ epsmch = epsilon ( epsmch )
+ eps = sqrt ( epsmch )
+!
+! MODE = 1.
+!
+ if ( mode == 1 ) then
+
+ do j = 1, n
+ temp = eps * abs ( x(j) )
+ if ( temp == 0.0D+00 ) then
+ temp = eps
+ end if
+ xp(j) = x(j) + temp
+ end do
+!
+! MODE = 2.
+!
+ else if ( mode == 2 ) then
+
+ epsf = 100.0D+00 * epsmch
+ epslog = log10 ( eps )
+
+ err = 0.0D+00
+
+ do j = 1, n
+ temp = abs ( x(j) )
+ if ( temp == 0.0D+00 ) then
+ temp = 1.0D+00
+ end if
+ err(1:m) = err(1:m) + temp * fjac(1:m,j)
+ end do
+
+ do i = 1, m
+
+ temp = 1.0D+00
+
+ if ( fvec(i) /= 0.0D+00 .and. fvecp(i) /= 0.0D+00 .and. &
+ abs ( fvecp(i)-fvec(i)) >= epsf * abs ( fvec(i) ) ) then
+ temp = eps * abs ( (fvecp(i)-fvec(i)) / eps - err(i) ) &
+ / ( abs ( fvec(i) ) + abs ( fvecp(i) ) )
+ end if
+
+ err(i) = 1.0D+00
+
+ if ( epsmch < temp .and. temp < eps ) then
+ err(i) = ( log10 ( temp ) - epslog ) / epslog
+ end if
+
+ if ( eps <= temp ) then
+ err(i) = 0.0D+00
+ end if
+
+ end do
+
+ end if
+
+ return
+end
+subroutine dogleg ( n, r, lr, diag, qtb, delta, x )
+
+!*****************************************************************************80
+!
+!! DOGLEG finds the minimizing combination of Gauss-Newton and gradient steps.
+!
+! Discussion:
+!
+! Given an M by N matrix A, an N by N nonsingular diagonal
+! matrix D, an M-vector B, and a positive number DELTA, the
+! problem is to determine the convex combination X of the
+! Gauss-Newton and scaled gradient directions that minimizes
+! (A*X - B) in the least squares sense, subject to the
+! restriction that the euclidean norm of D*X be at most DELTA.
+!
+! This subroutine completes the solution of the problem
+! if it is provided with the necessary information from the
+! QR factorization of A. That is, if A = Q*R, where Q has
+! orthogonal columns and R is an upper triangular matrix,
+! then DOGLEG expects the full upper triangle of R and
+! the first N components of Q'*B.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, integer ( kind = 4 ) N, the order of the matrix R.
+!
+! Input, real ( kind = 8 ) R(LR), the upper triangular matrix R stored
+! by rows.
+!
+! Input, integer ( kind = 4 ) LR, the size of the R array, which must be
+! no less than (N*(N+1))/2.
+!
+! Input, real ( kind = 8 ) DIAG(N), the diagonal elements of the matrix D.
+!
+! Input, real ( kind = 8 ) QTB(N), the first N elements of the vector Q'* B.
+!
+! Input, real ( kind = 8 ) DELTA, is a positive upper bound on the
+! euclidean norm of D*X(1:N).
+!
+! Output, real ( kind = 8 ) X(N), the desired convex combination of the
+! Gauss-Newton direction and the scaled gradient direction.
+!
+ implicit none
+
+ integer ( kind = 4 ) lr
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) alpha
+ real ( kind = 8 ) bnorm
+ real ( kind = 8 ) delta
+ real ( kind = 8 ) diag(n)
+ real ( kind = 8 ) enorm
+ real ( kind = 8 ) epsmch
+ real ( kind = 8 ) gnorm
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) j
+ integer ( kind = 4 ) jj
+ integer ( kind = 4 ) k
+ integer ( kind = 4 ) l
+ real ( kind = 8 ) qnorm
+ real ( kind = 8 ) qtb(n)
+ real ( kind = 8 ) r(lr)
+ real ( kind = 8 ) sgnorm
+ real ( kind = 8 ) sum2
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) wa1(n)
+ real ( kind = 8 ) wa2(n)
+ real ( kind = 8 ) x(n)
+
+ epsmch = epsilon ( epsmch )
+!
+! Calculate the Gauss-Newton direction.
+!
+ jj = ( n * ( n + 1 ) ) / 2 + 1
+
+ do k = 1, n
+
+ j = n - k + 1
+ jj = jj - k
+ l = jj + 1
+ sum2 = 0.0D+00
+
+ do i = j + 1, n
+ sum2 = sum2 + r(l) * x(i)
+ l = l + 1
+ end do
+
+ temp = r(jj)
+
+ if ( temp == 0.0D+00 ) then
+
+ l = j
+ do i = 1, j
+ temp = max ( temp, abs ( r(l)) )
+ l = l + n - i
+ end do
+
+ if ( temp == 0.0D+00 ) then
+ temp = epsmch
+ else
+ temp = epsmch * temp
+ end if
+
+ end if
+
+ x(j) = ( qtb(j) - sum2 ) / temp
+
+ end do
+!
+! Test whether the Gauss-Newton direction is acceptable.
+!
+ wa1(1:n) = 0.0D+00
+ wa2(1:n) = diag(1:n) * x(1:n)
+ qnorm = enorm ( n, wa2 )
+
+ if ( qnorm <= delta ) then
+ return
+ end if
+!
+! The Gauss-Newton direction is not acceptable.
+! Calculate the scaled gradient direction.
+!
+ l = 1
+ do j = 1, n
+ temp = qtb(j)
+ do i = j, n
+ wa1(i) = wa1(i) + r(l) * temp
+ l = l + 1
+ end do
+ wa1(j) = wa1(j) / diag(j)
+ end do
+!
+! Calculate the norm of the scaled gradient.
+! Test for the special case in which the scaled gradient is zero.
+!
+ gnorm = enorm ( n, wa1 )
+ sgnorm = 0.0D+00
+ alpha = delta / qnorm
+
+ if ( gnorm /= 0.0D+00 ) then
+!
+! Calculate the point along the scaled gradient which minimizes the quadratic.
+!
+ wa1(1:n) = ( wa1(1:n) / gnorm ) / diag(1:n)
+
+ l = 1
+ do j = 1, n
+ sum2 = 0.0D+00
+ do i = j, n
+ sum2 = sum2 + r(l) * wa1(i)
+ l = l + 1
+ end do
+ wa2(j) = sum2
+ end do
+
+ temp = enorm ( n, wa2 )
+ sgnorm = ( gnorm / temp ) / temp
+!
+! Test whether the scaled gradient direction is acceptable.
+!
+ alpha = 0.0D+00
+!
+! The scaled gradient direction is not acceptable.
+! Calculate the point along the dogleg at which the quadratic is minimized.
+!
+ if ( sgnorm < delta ) then
+
+ bnorm = enorm ( n, qtb )
+ temp = ( bnorm / gnorm ) * ( bnorm / qnorm ) * ( sgnorm / delta )
+ temp = temp - ( delta / qnorm ) * ( sgnorm / delta) ** 2 &
+ + sqrt ( ( temp - ( delta / qnorm ) ) ** 2 &
+ + ( 1.0D+00 - ( delta / qnorm ) ** 2 ) &
+ * ( 1.0D+00 - ( sgnorm / delta ) ** 2 ) )
+
+ alpha = ( ( delta / qnorm ) * ( 1.0D+00 - ( sgnorm / delta ) ** 2 ) ) &
+ / temp
+
+ end if
+
+ end if
+!
+! Form appropriate convex combination of the Gauss-Newton
+! direction and the scaled gradient direction.
+!
+ temp = ( 1.0D+00 - alpha ) * min ( sgnorm, delta )
+
+ x(1:n) = temp * wa1(1:n) + alpha * x(1:n)
+
+ return
+end
+function enorm ( n, x )
+
+!*****************************************************************************80
+!
+!! ENORM computes the Euclidean norm of a vector.
+!
+! Discussion:
+!
+! This is an extremely simplified version of the original ENORM
+! routine, which has been renamed to "ENORM2".
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, integer ( kind = 4 ) N, is the length of the vector.
+!
+! Input, real ( kind = 8 ) X(N), the vector whose norm is desired.
+!
+! Output, real ( kind = 8 ) ENORM, the Euclidean norm of the vector.
+!
+ implicit none
+
+ integer ( kind = 4 ) n
+ real ( kind = 8 ) x(n)
+ real ( kind = 8 ) enorm
+
+ enorm = sqrt ( sum ( x(1:n) ** 2 ))
+
+ return
+end
+function enorm2 ( n, x )
+
+!*****************************************************************************80
+!
+!! ENORM2 computes the Euclidean norm of a vector.
+!
+! Discussion:
+!
+! This routine was named ENORM. It has been renamed "ENORM2",
+! and a simplified routine has been substituted.
+!
+! The Euclidean norm is computed by accumulating the sum of
+! squares in three different sums. The sums of squares for the
+! small and large components are scaled so that no overflows
+! occur. Non-destructive underflows are permitted. Underflows
+! and overflows do not occur in the computation of the unscaled
+! sum of squares for the intermediate components.
+!
+! The definitions of small, intermediate and large components
+! depend on two constants, RDWARF and RGIANT. The main
+! restrictions on these constants are that RDWARF^2 not
+! underflow and RGIANT^2 not overflow.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1
+! Argonne National Laboratory,
+! Argonne, Illinois.
+!
+! Parameters:
+!
+! Input, integer ( kind = 4 ) N, is the length of the vector.
+!
+! Input, real ( kind = 8 ) X(N), the vector whose norm is desired.
+!
+! Output, real ( kind = 8 ) ENORM2, the Euclidean norm of the vector.
+!
+ implicit none
+
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) agiant
+ real ( kind = 8 ) enorm2
+ integer ( kind = 4 ) i
+ real ( kind = 8 ) rdwarf
+ real ( kind = 8 ) rgiant
+ real ( kind = 8 ) s1
+ real ( kind = 8 ) s2
+ real ( kind = 8 ) s3
+ real ( kind = 8 ) x(n)
+ real ( kind = 8 ) xabs
+ real ( kind = 8 ) x1max
+ real ( kind = 8 ) x3max
+
+ rdwarf = sqrt ( tiny ( rdwarf ) )
+ rgiant = sqrt ( huge ( rgiant ) )
+
+ s1 = 0.0D+00
+ s2 = 0.0D+00
+ s3 = 0.0D+00
+ x1max = 0.0D+00
+ x3max = 0.0D+00
+ agiant = rgiant / real ( n, kind = 8 )
+
+ do i = 1, n
+
+ xabs = abs ( x(i) )
+
+ if ( xabs <= rdwarf ) then
+
+ if ( x3max < xabs ) then
+ s3 = 1.0D+00 + s3 * ( x3max / xabs ) ** 2
+ x3max = xabs
+ else if ( xabs /= 0.0D+00 ) then
+ s3 = s3 + ( xabs / x3max ) ** 2
+ end if
+
+ else if ( agiant <= xabs ) then
+
+ if ( x1max < xabs ) then
+ s1 = 1.0D+00 + s1 * ( x1max / xabs ) ** 2
+ x1max = xabs
+ else
+ s1 = s1 + ( xabs / x1max ) ** 2
+ end if
+
+ else
+
+ s2 = s2 + xabs ** 2
+
+ end if
+
+ end do
+!
+! Calculation of norm.
+!
+ if ( s1 /= 0.0D+00 ) then
+
+ enorm2 = x1max * sqrt ( s1 + ( s2 / x1max ) / x1max )
+
+ else if ( s2 /= 0.0D+00 ) then
+
+ if ( x3max <= s2 ) then
+ enorm2 = sqrt ( s2 * ( 1.0D+00 + ( x3max / s2 ) * ( x3max * s3 ) ) )
+ else
+ enorm2 = sqrt ( x3max * ( ( s2 / x3max ) + ( x3max * s3 ) ) )
+ end if
+
+ else
+
+ enorm2 = x3max * sqrt ( s3 )
+
+ end if
+
+ return
+end
+subroutine fdjac1 ( fcn, n, x, fvec, fjac, ldfjac, iflag, ml, mu, epsfcn )
+
+!*****************************************************************************80
+!
+!! FDJAC1 estimates an N by N jacobian matrix using forward differences.
+!
+! Discussion:
+!
+! This subroutine computes a forward-difference approximation
+! to the N by N jacobian matrix associated with a specified
+! problem of N functions in N variables. If the jacobian has
+! a banded form, then function evaluations are saved by only
+! approximating the nonzero terms.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, external FCN, the name of the user-supplied subroutine which
+! calculates the functions. The routine should have the form:
+! subroutine fcn ( n, x, fvec, iflag )
+! integer ( kind = 4 ) n
+! real ( kind = 8 ) fvec(n)
+! integer ( kind = 4 ) iflag
+! real ( kind = 8 ) x(n)
+! If IFLAG = 0 on input, then FCN is only being called to allow the user
+! to print out the current iterate.
+! If IFLAG = 1 on input, FCN should calculate the functions at X and
+! return this vector in FVEC.
+! To terminate the algorithm, FCN may set IFLAG negative on return.
+!
+! Input, integer ( kind = 4 ) N, the number of functions and variables.
+!
+! Input, real ( kind = 8 ) X(N), the point where the jacobian is evaluated.
+!
+! Input, real ( kind = 8 ) FVEC(N), the functions evaluated at X.
+!
+! Output, real ( kind = 8 ) FJAC(LDFJAC,N), the N by N approximate
+! jacobian matrix.
+!
+! Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC, which
+! must not be less than N.
+!
+! Output, integer ( kind = 4 ) IFLAG, is an error flag returned by FCN.
+! If FCN returns a nonzero value of IFLAG, then this routine returns
+! immediately to the calling program, with the value of IFLAG.
+!
+! Input, integer ( kind = 4 ) ML, MU, specify the number of subdiagonals and
+! superdiagonals within the band of the jacobian matrix. If the
+! jacobian is not banded, set ML and MU to N-1.
+!
+! Input, real ( kind = 8 ) EPSFCN, is used in determining a suitable step
+! length for the forward-difference approximation. This approximation
+! assumes that the relative errors in the functions are of the order of
+! EPSFCN. If EPSFCN is less than the machine precision, it is assumed that
+! the relative errors in the functions are of the order of the machine
+! precision.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldfjac
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) eps
+ real ( kind = 8 ) epsfcn
+ real ( kind = 8 ) epsmch
+ external fcn
+ real ( kind = 8 ) fjac(ldfjac,n)
+ real ( kind = 8 ) fvec(n)
+ real ( kind = 8 ) h
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) iflag
+ integer ( kind = 4 ) j
+ integer ( kind = 4 ) k
+ integer ( kind = 4 ) ml
+ integer ( kind = 4 ) msum
+ integer ( kind = 4 ) mu
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) wa1(n)
+ real ( kind = 8 ) wa2(n)
+ real ( kind = 8 ) x(n)
+
+ epsmch = epsilon ( epsmch )
+
+ eps = sqrt ( max ( epsfcn, epsmch ) )
+ msum = ml + mu + 1
+!
+! Computation of dense approximate jacobian.
+!
+ if ( n <= msum ) then
+
+ do j = 1, n
+
+ temp = x(j)
+ h = eps * abs ( temp )
+ if ( h == 0.0D+00 ) then
+ h = eps
+ end if
+
+ iflag = 1
+ x(j) = temp + h
+ call fcn ( n, x, wa1, iflag )
+
+ if ( iflag < 0 ) then
+ exit
+ end if
+
+ x(j) = temp
+ fjac(1:n,j) = ( wa1(1:n) - fvec(1:n) ) / h
+
+ end do
+
+ else
+!
+! Computation of banded approximate jacobian.
+!
+ do k = 1, msum
+
+ do j = k, n, msum
+ wa2(j) = x(j)
+ h = eps * abs ( wa2(j) )
+ if ( h == 0.0D+00 ) then
+ h = eps
+ end if
+ x(j) = wa2(j) + h
+ end do
+
+ iflag = 1
+ call fcn ( n, x, wa1, iflag )
+
+ if ( iflag < 0 ) then
+ exit
+ end if
+
+ do j = k, n, msum
+
+ x(j) = wa2(j)
+
+ h = eps * abs ( wa2(j) )
+ if ( h == 0.0D+00 ) then
+ h = eps
+ end if
+
+ fjac(1:n,j) = 0.0D+00
+
+ do i = 1, n
+ if ( j - mu <= i .and. i <= j + ml ) then
+ fjac(i,j) = ( wa1(i) - fvec(i) ) / h
+ end if
+ end do
+
+ end do
+
+ end do
+
+ end if
+
+ return
+end
+subroutine fdjac2 ( fcn, m, n, x, fvec, fjac, ldfjac, iflag, epsfcn )
+
+!*****************************************************************************80
+!
+!! FDJAC2 estimates an M by N jacobian matrix using forward differences.
+!
+! Discussion:
+!
+! This subroutine computes a forward-difference approximation
+! to the M by N jacobian matrix associated with a specified
+! problem of M functions in N variables.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, external FCN, the name of the user-supplied subroutine which
+! calculates the functions. The routine should have the form:
+! subroutine fcn ( m, n, x, fvec, iflag )
+! integer ( kind = 4 ) n
+! real ( kind = 8 ) fvec(m)
+! integer ( kind = 4 ) iflag
+! real ( kind = 8 ) x(n)
+!
+! If IFLAG = 0 on input, then FCN is only being called to allow the user
+! to print out the current iterate.
+! If IFLAG = 1 on input, FCN should calculate the functions at X and
+! return this vector in FVEC.
+! To terminate the algorithm, FCN may set IFLAG negative on return.
+!
+! Input, integer ( kind = 4 ) M, is the number of functions.
+!
+! Input, integer ( kind = 4 ) N, is the number of variables.
+! N must not exceed M.
+!
+! Input, real ( kind = 8 ) X(N), the point where the jacobian is evaluated.
+!
+! Input, real ( kind = 8 ) FVEC(M), the functions evaluated at X.
+!
+! Output, real ( kind = 8 ) FJAC(LDFJAC,N), the M by N approximate
+! jacobian matrix.
+!
+! Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC,
+! which must not be less than M.
+!
+! Output, integer ( kind = 4 ) IFLAG, is an error flag returned by FCN.
+! If FCN returns a nonzero value of IFLAG, then this routine returns
+! immediately to the calling program, with the value of IFLAG.
+!
+! Input, real ( kind = 8 ) EPSFCN, is used in determining a suitable
+! step length for the forward-difference approximation. This approximation
+! assumes that the relative errors in the functions are of the order of
+! EPSFCN. If EPSFCN is less than the machine precision, it is assumed that
+! the relative errors in the functions are of the order of the machine
+! precision.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldfjac
+ integer ( kind = 4 ) m
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) eps
+ real ( kind = 8 ) epsfcn
+ real ( kind = 8 ) epsmch
+ external fcn
+ real ( kind = 8 ) fjac(ldfjac,n)
+ real ( kind = 8 ) fvec(m)
+ real ( kind = 8 ) h
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) iflag
+ integer ( kind = 4 ) j
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) wa(m)
+ real ( kind = 8 ) x(n)
+
+ epsmch = epsilon ( epsmch )
+
+ eps = sqrt ( max ( epsfcn, epsmch ) )
+
+ do j = 1, n
+
+ temp = x(j)
+ h = eps * abs ( temp )
+ if ( h == 0.0D+00 ) then
+ h = eps
+ end if
+
+ iflag = 1
+ x(j) = temp + h
+ call fcn ( m, n, x, wa, iflag )
+
+ if ( iflag < 0 ) then
+ exit
+ end if
+
+ x(j) = temp
+ fjac(1:m,j) = ( wa(1:m) - fvec(1:m) ) / h
+
+ end do
+
+ return
+end
+subroutine hybrd ( fcn, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, diag, mode, &
+ factor, nprint, info, nfev, fjac, ldfjac, r, lr, qtf )
+
+!*****************************************************************************80
+!
+!! HYBRD seeks a zero of N nonlinear equations in N variables.
+!
+! Discussion:
+!
+! HYBRD finds a zero of a system of N nonlinear functions in N variables
+! by a modification of the Powell hybrid method. The user must provide a
+! subroutine which calculates the functions. The jacobian is
+! then calculated by a forward-difference approximation.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, external FCN, the name of the user-supplied subroutine which
+! calculates the functions. The routine should have the form:
+! subroutine fcn ( n, x, fvec, iflag )
+! integer ( kind = 4 ) n
+! real ( kind = 8 ) fvec(n)
+! integer ( kind = 4 ) iflag
+! real ( kind = 8 ) x(n)
+!
+! If IFLAG = 0 on input, then FCN is only being called to allow the user
+! to print out the current iterate.
+! If IFLAG = 1 on input, FCN should calculate the functions at X and
+! return this vector in FVEC.
+! To terminate the algorithm, FCN may set IFLAG negative on return.
+!
+! Input, integer ( kind = 4 ) N, the number of functions and variables.
+!
+! Input/output, real ( kind = 8 ) X(N). On input, X must contain an initial
+! estimate of the solution vector. On output X contains the final
+! estimate of the solution vector.
+!
+! Output, real ( kind = 8 ) FVEC(N), the functions evaluated at the output X.
+!
+! Input, real ( kind = 8 ) XTOL. Termination occurs when the relative error
+! between two consecutive iterates is at most XTOL. XTOL should be
+! nonnegative.
+!
+! Input, integer ( kind = 4 ) MAXFEV. Termination occurs when the number of
+! calls to FCN is at least MAXFEV by the end of an iteration.
+!
+! Input, integer ( kind = 4 ) ML, MU, specify the number of subdiagonals and
+! superdiagonals within the band of the jacobian matrix. If the jacobian
+! is not banded, set ML and MU to at least n - 1.
+!
+! Input, real ( kind = 8 ) EPSFCN, is used in determining a suitable step
+! length for the forward-difference approximation. This approximation
+! assumes that the relative errors in the functions are of the order of
+! EPSFCN. If EPSFCN is less than the machine precision, it is assumed that
+! the relative errors in the functions are of the order of the machine
+! precision.
+!
+! Input/output, real ( kind = 8 ) DIAG(N). If MODE = 1, then DIAG is set
+! internally. If MODE = 2, then DIAG must contain positive entries that
+! serve as multiplicative scale factors for the variables.
+!
+! Input, integer ( kind = 4 ) MODE, scaling option.
+! 1, variables will be scaled internally.
+! 2, scaling is specified by the input DIAG vector.
+!
+! Input, real ( kind = 8 ) FACTOR, determines the initial step bound. This
+! bound is set to the product of FACTOR and the euclidean norm of DIAG*X if
+! nonzero, or else to FACTOR itself. In most cases, FACTOR should lie
+! in the interval (0.1, 100) with 100 the recommended value.
+!
+! Input, integer ( kind = 4 ) NPRINT, enables controlled printing of
+! iterates if it is positive. In this case, FCN is called with IFLAG = 0 at
+! the beginning of the first iteration and every NPRINT iterations thereafter
+! and immediately prior to return, with X and FVEC available
+! for printing. If NPRINT is not positive, no special calls
+! of FCN with IFLAG = 0 are made.
+!
+! Output, integer ( kind = 4 ) INFO, error flag. If the user has terminated
+! execution, INFO is set to the (negative) value of IFLAG.
+! See the description of FCN.
+! Otherwise, INFO is set as follows:
+! 0, improper input parameters.
+! 1, relative error between two consecutive iterates is at most XTOL.
+! 2, number of calls to FCN has reached or exceeded MAXFEV.
+! 3, XTOL is too small. No further improvement in the approximate
+! solution X is possible.
+! 4, iteration is not making good progress, as measured by the improvement
+! from the last five jacobian evaluations.
+! 5, iteration is not making good progress, as measured by the improvement
+! from the last ten iterations.
+!
+! Output, integer ( kind = 4 ) NFEV, the number of calls to FCN.
+!
+! Output, real ( kind = 8 ) FJAC(LDFJAC,N), an N by N array which contains
+! the orthogonal matrix Q produced by the QR factorization of the final
+! approximate jacobian.
+!
+! Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC.
+! LDFJAC must be at least N.
+!
+! Output, real ( kind = 8 ) R(LR), the upper triangular matrix produced by
+! the QR factorization of the final approximate jacobian, stored rowwise.
+!
+! Input, integer ( kind = 4 ) LR, the size of the R array, which must be no
+! less than (N*(N+1))/2.
+!
+! Output, real ( kind = 8 ) QTF(N), contains the vector Q'*FVEC.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldfjac
+ integer ( kind = 4 ) lr
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) actred
+ real ( kind = 8 ) delta
+ real ( kind = 8 ) diag(n)
+ real ( kind = 8 ) enorm
+ real ( kind = 8 ) epsfcn
+ real ( kind = 8 ) epsmch
+ real ( kind = 8 ) factor
+ external fcn
+ real ( kind = 8 ) fjac(ldfjac,n)
+ real ( kind = 8 ) fnorm
+ real ( kind = 8 ) fnorm1
+ real ( kind = 8 ) fvec(n)
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) iflag
+ integer ( kind = 4 ) info
+ integer ( kind = 4 ) iter
+ integer ( kind = 4 ) iwa(1)
+ integer ( kind = 4 ) j
+ logical jeval
+ integer ( kind = 4 ) l
+ integer ( kind = 4 ) maxfev
+ integer ( kind = 4 ) ml
+ integer ( kind = 4 ) mode
+ integer ( kind = 4 ) msum
+ integer ( kind = 4 ) mu
+ integer ( kind = 4 ) ncfail
+ integer ( kind = 4 ) nslow1
+ integer ( kind = 4 ) nslow2
+ integer ( kind = 4 ) ncsuc
+ integer ( kind = 4 ) nfev
+ integer ( kind = 4 ) nprint
+ logical pivot
+ real ( kind = 8 ) pnorm
+ real ( kind = 8 ) prered
+ real ( kind = 8 ) qtf(n)
+ real ( kind = 8 ) r(lr)
+ real ( kind = 8 ) ratio
+ logical sing
+ real ( kind = 8 ) sum2
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) wa1(n)
+ real ( kind = 8 ) wa2(n)
+ real ( kind = 8 ) wa3(n)
+ real ( kind = 8 ) wa4(n)
+ real ( kind = 8 ) x(n)
+ real ( kind = 8 ) xnorm
+ real ( kind = 8 ) xtol
+
+ epsmch = epsilon ( epsmch )
+
+ info = 0
+ iflag = 0
+ nfev = 0
+!
+! Check the input parameters for errors.
+!
+ if ( n <= 0 ) then
+ return
+ else if ( xtol < 0.0D+00 ) then
+ return
+ else if ( maxfev <= 0 ) then
+ return
+ else if ( ml < 0 ) then
+ return
+ else if ( mu < 0 ) then
+ return
+ else if ( factor <= 0.0D+00 ) then
+ return
+ else if ( ldfjac < n ) then
+ return
+ else if ( lr < ( n * ( n + 1 ) ) / 2 ) then
+ return
+ end if
+
+ if ( mode == 2 ) then
+
+ do j = 1, n
+ if ( diag(j) <= 0.0D+00 ) then
+ go to 300
+ end if
+ end do
+
+ end if
+!
+! Evaluate the function at the starting point
+! and calculate its norm.
+!
+ iflag = 1
+ call fcn ( n, x, fvec, iflag )
+ nfev = 1
+
+ if ( iflag < 0 ) then
+ go to 300
+ end if
+
+ fnorm = enorm ( n, fvec )
+!
+! Determine the number of calls to FCN needed to compute the jacobian matrix.
+!
+ msum = min ( ml + mu + 1, n )
+!
+! Initialize iteration counter and monitors.
+!
+ iter = 1
+ ncsuc = 0
+ ncfail = 0
+ nslow1 = 0
+ nslow2 = 0
+!
+! Beginning of the outer loop.
+!
+30 continue
+
+ jeval = .true.
+!
+! Calculate the jacobian matrix.
+!
+ iflag = 2
+ call fdjac1 ( fcn, n, x, fvec, fjac, ldfjac, iflag, ml, mu, epsfcn )
+
+ nfev = nfev + msum
+
+ if ( iflag < 0 ) then
+ go to 300
+ end if
+!
+! Compute the QR factorization of the jacobian.
+!
+ pivot = .false.
+ call qrfac ( n, n, fjac, ldfjac, pivot, iwa, 1, wa1, wa2 )
+!
+! On the first iteration, if MODE is 1, scale according
+! to the norms of the columns of the initial jacobian.
+!
+ if ( iter == 1 ) then
+
+ if ( mode /= 2 ) then
+
+ diag(1:n) = wa2(1:n)
+ do j = 1, n
+ if ( wa2(j) == 0.0D+00 ) then
+ diag(j) = 1.0D+00
+ end if
+ end do
+
+ end if
+!
+! On the first iteration, calculate the norm of the scaled X
+! and initialize the step bound DELTA.
+!
+ wa3(1:n) = diag(1:n) * x(1:n)
+ xnorm = enorm ( n, wa3 )
+ delta = factor * xnorm
+ if ( delta == 0.0D+00 ) then
+ delta = factor
+ end if
+
+ end if
+!
+! Form Q' * FVEC and store in QTF.
+!
+ qtf(1:n) = fvec(1:n)
+
+ do j = 1, n
+
+ if ( fjac(j,j) /= 0.0D+00 ) then
+ temp = - dot_product ( qtf(j:n), fjac(j:n,j) ) / fjac(j,j)
+ qtf(j:n) = qtf(j:n) + fjac(j:n,j) * temp
+ end if
+
+ end do
+!
+! Copy the triangular factor of the QR factorization into R.
+!
+ sing = .false.
+
+ do j = 1, n
+ l = j
+ do i = 1, j - 1
+ r(l) = fjac(i,j)
+ l = l + n - i
+ end do
+ r(l) = wa1(j)
+ if ( wa1(j) == 0.0D+00 ) then
+ sing = .true.
+ end if
+ end do
+!
+! Accumulate the orthogonal factor in FJAC.
+!
+ call qform ( n, n, fjac, ldfjac )
+!
+! Rescale if necessary.
+!
+ if ( mode /= 2 ) then
+ do j = 1, n
+ diag(j) = max ( diag(j), wa2(j) )
+ end do
+ end if
+!
+! Beginning of the inner loop.
+!
+180 continue
+!
+! If requested, call FCN to enable printing of iterates.
+!
+ if ( 0 < nprint ) then
+ iflag = 0
+ if ( mod ( iter - 1, nprint ) == 0 ) then
+ call fcn ( n, x, fvec, iflag )
+ end if
+ if ( iflag < 0 ) then
+ go to 300
+ end if
+ end if
+!
+! Determine the direction P.
+!
+ call dogleg ( n, r, lr, diag, qtf, delta, wa1 )
+!
+! Store the direction P and X + P.
+! Calculate the norm of P.
+!
+ wa1(1:n) = - wa1(1:n)
+ wa2(1:n) = x(1:n) + wa1(1:n)
+ wa3(1:n) = diag(1:n) * wa1(1:n)
+
+ pnorm = enorm ( n, wa3 )
+!
+! On the first iteration, adjust the initial step bound.
+!
+ if ( iter == 1 ) then
+ delta = min ( delta, pnorm )
+ end if
+!
+! Evaluate the function at X + P and calculate its norm.
+!
+ iflag = 1
+ call fcn ( n, wa2, wa4, iflag )
+ nfev = nfev + 1
+
+ if ( iflag < 0 ) then
+ go to 300
+ end if
+
+ fnorm1 = enorm ( n, wa4 )
+!
+! Compute the scaled actual reduction.
+!
+ actred = -1.0D+00
+ if ( fnorm1 < fnorm ) then
+ actred = 1.0D+00 - ( fnorm1 / fnorm ) ** 2
+ endif
+!
+! Compute the scaled predicted reduction.
+!
+ l = 1
+ do i = 1, n
+ sum2 = 0.0D+00
+ do j = i, n
+ sum2 = sum2 + r(l) * wa1(j)
+ l = l + 1
+ end do
+ wa3(i) = qtf(i) + sum2
+ end do
+
+ temp = enorm ( n, wa3 )
+ prered = 0.0D+00
+ if ( temp < fnorm ) then
+ prered = 1.0D+00 - ( temp / fnorm ) ** 2
+ end if
+!
+! Compute the ratio of the actual to the predicted reduction.
+!
+ ratio = 0.0D+00
+ if ( 0.0D+00 < prered ) then
+ ratio = actred / prered
+ end if
+!
+! Update the step bound.
+!
+ if ( ratio < 0.1D+00 ) then
+
+ ncsuc = 0
+ ncfail = ncfail + 1
+ delta = 0.5D+00 * delta
+
+ else
+
+ ncfail = 0
+ ncsuc = ncsuc + 1
+
+ if ( 0.5D+00 <= ratio .or. 1 < ncsuc ) then
+ delta = max ( delta, pnorm / 0.5D+00 )
+ end if
+
+ if ( abs ( ratio - 1.0D+00 ) <= 0.1D+00 ) then
+ delta = pnorm / 0.5D+00
+ end if
+
+ end if
+!
+! Test for successful iteration.
+!
+! Successful iteration.
+! Update X, FVEC, and their norms.
+!
+ if ( 0.0001D+00 <= ratio ) then
+ x(1:n) = wa2(1:n)
+ wa2(1:n) = diag(1:n) * x(1:n)
+ fvec(1:n) = wa4(1:n)
+ xnorm = enorm ( n, wa2 )
+ fnorm = fnorm1
+ iter = iter + 1
+ end if
+!
+! Determine the progress of the iteration.
+!
+ nslow1 = nslow1 + 1
+ if ( 0.001D+00 <= actred ) then
+ nslow1 = 0
+ end if
+
+ if ( jeval ) then
+ nslow2 = nslow2 + 1
+ end if
+
+ if ( 0.1D+00 <= actred ) then
+ nslow2 = 0
+ end if
+!
+! Test for convergence.
+!
+ if ( delta <= xtol * xnorm .or. fnorm == 0.0D+00 ) then
+ info = 1
+ end if
+
+ if ( info /= 0 ) then
+ go to 300
+ end if
+!
+! Tests for termination and stringent tolerances.
+!
+ if ( maxfev <= nfev ) then
+ info = 2
+ end if
+
+ if ( 0.1D+00 * max ( 0.1D+00 * delta, pnorm ) <= epsmch * xnorm ) then
+ info = 3
+ end if
+
+ if ( nslow2 == 5 ) then
+ info = 4
+ end if
+
+ if ( nslow1 == 10 ) then
+ info = 5
+ end if
+
+ if ( info /= 0 ) then
+ go to 300
+ end if
+!
+! Criterion for recalculating jacobian approximation
+! by forward differences.
+!
+ if ( ncfail == 2 ) then
+ go to 290
+ end if
+!
+! Calculate the rank one modification to the jacobian
+! and update QTF if necessary.
+!
+ do j = 1, n
+ sum2 = dot_product ( wa4(1:n), fjac(1:n,j) )
+ wa2(j) = ( sum2 - wa3(j) ) / pnorm
+ wa1(j) = diag(j) * ( ( diag(j) * wa1(j) ) / pnorm )
+ if ( 0.0001D+00 <= ratio ) then
+ qtf(j) = sum2
+ end if
+ end do
+!
+! Compute the QR factorization of the updated jacobian.
+!
+ call r1updt ( n, n, r, lr, wa1, wa2, wa3, sing )
+ call r1mpyq ( n, n, fjac, ldfjac, wa2, wa3 )
+ call r1mpyq ( 1, n, qtf, 1, wa2, wa3 )
+!
+! End of the inner loop.
+!
+ jeval = .false.
+ go to 180
+
+ 290 continue
+!
+! End of the outer loop.
+!
+ go to 30
+
+ 300 continue
+!
+! Termination, either normal or user imposed.
+!
+ if ( iflag < 0 ) then
+ info = iflag
+ end if
+
+ iflag = 0
+
+ if ( 0 < nprint ) then
+ call fcn ( n, x, fvec, iflag )
+ end if
+
+ return
+end
+subroutine hybrd1 ( fcn, n, x, fvec, tol, info )
+
+!*****************************************************************************80
+!
+!! HYBRD1 seeks a zero of N nonlinear equations in N variables.
+!
+! Discussion:
+!
+! HYBRD1 finds a zero of a system of N nonlinear functions in N variables
+! by a modification of the Powell hybrid method. This is done by using the
+! more general nonlinear equation solver HYBRD. The user must provide a
+! subroutine which calculates the functions. The jacobian is then
+! calculated by a forward-difference approximation.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 19 August 2016
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, external FCN, the name of the user-supplied subroutine which
+! calculates the functions. The routine should have the form:
+! subroutine fcn ( n, x, fvec, iflag )
+! integer ( kind = 4 ) n
+! real ( kind = 8 ) fvec(n)
+! integer ( kind = 4 ) iflag
+! real ( kind = 8 ) x(n)
+! If IFLAG = 0 on input, then FCN is only being called to allow the user
+! to print out the current iterate.
+! If IFLAG = 1 on input, FCN should calculate the functions at X and
+! return this vector in FVEC.
+! To terminate the algorithm, FCN may set IFLAG negative on return.
+!
+! Input, integer ( kind = 4 ) N, the number of functions and variables.
+!
+! Input/output, real ( kind = 8 ) X(N). On input, X must contain an initial
+! estimate of the solution vector. On output X contains the final
+! estimate of the solution vector.
+!
+! Output, real ( kind = 8 ) FVEC(N), the functions evaluated at the output X.
+!
+! Input, real ( kind = 8 ) TOL. Termination occurs when the algorithm
+! estimates that the relative error between X and the solution is at
+! most TOL. TOL should be nonnegative.
+!
+! Output, integer ( kind = 4 ) INFO, error flag. If the user has terminated
+! execution, INFO is set to the (negative) value of IFLAG. See the
+! description of FCN.
+! Otherwise, INFO is set as follows:
+! 0, improper input parameters.
+! 1, algorithm estimates that the relative error between X and the
+! solution is at most TOL.
+! 2, number of calls to FCN has reached or exceeded 200*(N+1).
+! 3, TOL is too small. No further improvement in the approximate
+! solution X is possible.
+! 4, the iteration is not making good progress.
+!
+ implicit none
+
+ integer ( kind = 4 ) lwa
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) diag(n)
+ real ( kind = 8 ) epsfcn
+ real ( kind = 8 ) factor
+ external fcn
+ real ( kind = 8 ) fjac(n,n)
+ real ( kind = 8 ) fvec(n)
+ integer ( kind = 4 ) info
+ integer ( kind = 4 ) j
+ integer ( kind = 4 ) ldfjac
+ integer ( kind = 4 ) lr
+ integer ( kind = 4 ) maxfev
+ integer ( kind = 4 ) ml
+ integer ( kind = 4 ) mode
+ integer ( kind = 4 ) mu
+ integer ( kind = 4 ) nfev
+ integer ( kind = 4 ) nprint
+ real ( kind = 8 ) qtf(n)
+ real ( kind = 8 ) r((n*(n+1))/2)
+ real ( kind = 8 ) tol
+ real ( kind = 8 ) x(n)
+ real ( kind = 8 ) xtol
+
+ if ( n <= 0 ) then
+ info = 0
+ return
+ end if
+
+ if ( tol < 0.0D+00 ) then
+ info = 0
+ return
+ end if
+
+ xtol = tol
+ maxfev = 200 * ( n + 1 )
+ ml = n - 1
+ mu = n - 1
+ epsfcn = 0.0D+00
+ diag(1:n) = 1.0D+00
+ mode = 2
+ factor = 100.0D+00
+ nprint = 0
+ info = 0
+ nfev = 0
+ fjac(1:n,1:n) = 0.0D+00
+ ldfjac = n
+ r(1:(n*(n+1))/2) = 0.0D+00
+ lr = ( n * ( n + 1 ) ) / 2
+ qtf(1:n) = 0.0D+00
+
+ call hybrd ( fcn, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, diag, mode, &
+ factor, nprint, info, nfev, fjac, ldfjac, r, lr, qtf )
+
+ if ( info == 5 ) then
+ info = 4
+ end if
+
+ return
+end
+subroutine hybrj ( fcn, n, x, fvec, fjac, ldfjac, xtol, maxfev, diag, mode, &
+ factor, nprint, info, nfev, njev, r, lr, qtf )
+
+!*****************************************************************************80
+!
+!! HYBRJ seeks a zero of N nonlinear equations in N variables.
+!
+! Discussion:
+!
+! HYBRJ finds a zero of a system of N nonlinear functions in N variables
+! by a modification of the Powell hybrid method. The user must provide a
+! subroutine which calculates the functions and the jacobian.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, external FCN, the name of the user-supplied subroutine which
+! calculates the functions and the jacobian. FCN should have the form:
+!
+! subroutine fcn ( n, x, fvec, fjac, ldfjac, iflag )
+! integer ( kind = 4 ) ldfjac
+! integer ( kind = 4 ) n
+! real ( kind = 8 ) fjac(ldfjac,n)
+! real ( kind = 8 ) fvec(n)
+! integer ( kind = 4 ) iflag
+! real ( kind = 8 ) x(n)
+!
+! If IFLAG = 0 on input, then FCN is only being called to allow the user
+! to print out the current iterate.
+! If IFLAG = 1 on input, FCN should calculate the functions at X and
+! return this vector in FVEC.
+! If IFLAG = 2 on input, FCN should calculate the jacobian at X and
+! return this matrix in FJAC.
+! To terminate the algorithm, FCN may set IFLAG negative on return.
+!
+! Input, integer ( kind = 4 ) N, the number of functions and variables.
+!
+! Input/output, real ( kind = 8 ) X(N). On input, X must contain an initial
+! estimate of the solution vector. On output X contains the final
+! estimate of the solution vector.
+!
+! Output, real ( kind = 8 ) FVEC(N), the functions evaluated at the output X.
+!
+! Output, real ( kind = 8 ) FJAC(LDFJAC,N), an N by N matrix, containing
+! the orthogonal matrix Q produced by the QR factorization
+! of the final approximate jacobian.
+!
+! Input, integer ( kind = 4 ) LDFJAC, the leading dimension of the
+! array FJAC. LDFJAC must be at least N.
+!
+! Input, real ( kind = 8 ) XTOL. Termination occurs when the relative error
+! between two consecutive iterates is at most XTOL. XTOL should be
+! nonnegative.
+!
+! Input, integer ( kind = 4 ) MAXFEV. Termination occurs when the number of
+! calls to FCN is at least MAXFEV by the end of an iteration.
+!
+! Input/output, real ( kind = 8 ) DIAG(N). If MODE = 1, then DIAG is set
+! internally. If MODE = 2, then DIAG must contain positive entries that
+! serve as multiplicative scale factors for the variables.
+!
+! Input, integer ( kind = 4 ) MODE, scaling option.
+! 1, variables will be scaled internally.
+! 2, scaling is specified by the input DIAG vector.
+!
+! Input, real ( kind = 8 ) FACTOR, determines the initial step bound. This
+! bound is set to the product of FACTOR and the euclidean norm of DIAG*X if
+! nonzero, or else to FACTOR itself. In most cases, FACTOR should lie
+! in the interval (0.1, 100) with 100 the recommended value.
+!
+! Input, integer ( kind = 4 ) NPRINT, enables controlled printing of iterates
+! if it is positive. In this case, FCN is called with IFLAG = 0 at the
+! beginning of the first iteration and every NPRINT iterations thereafter
+! and immediately prior to return, with X and FVEC available
+! for printing. If NPRINT is not positive, no special calls
+! of FCN with IFLAG = 0 are made.
+!
+! Output, integer ( kind = 4 ) INFO, error flag. If the user has terminated
+! execution, INFO is set to the (negative) value of IFLAG.
+! See the description of FCN. Otherwise, INFO is set as follows:
+! 0, improper input parameters.
+! 1, relative error between two consecutive iterates is at most XTOL.
+! 2, number of calls to FCN with IFLAG = 1 has reached MAXFEV.
+! 3, XTOL is too small. No further improvement in
+! the approximate solution X is possible.
+! 4, iteration is not making good progress, as measured by the
+! improvement from the last five jacobian evaluations.
+! 5, iteration is not making good progress, as measured by the
+! improvement from the last ten iterations.
+!
+! Output, integer ( kind = 4 ) NFEV, the number of calls to FCN
+! with IFLAG = 1.
+!
+! Output, integer ( kind = 4 ) NJEV, the number of calls to FCN
+! with IFLAG = 2.
+!
+! Output, real ( kind = 8 ) R(LR), the upper triangular matrix produced
+! by the QR factorization of the final approximate jacobian, stored rowwise.
+!
+! Input, integer ( kind = 4 ) LR, the size of the R array, which must
+! be no less than (N*(N+1))/2.
+!
+! Output, real ( kind = 8 ) QTF(N), contains the vector Q'*FVEC.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldfjac
+ integer ( kind = 4 ) lr
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) actred
+ real ( kind = 8 ) delta
+ real ( kind = 8 ) diag(n)
+ real ( kind = 8 ) enorm
+ real ( kind = 8 ) epsmch
+ real ( kind = 8 ) factor
+ external fcn
+ real ( kind = 8 ) fjac(ldfjac,n)
+ real ( kind = 8 ) fnorm
+ real ( kind = 8 ) fnorm1
+ real ( kind = 8 ) fvec(n)
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) iflag
+ integer ( kind = 4 ) info
+ integer ( kind = 4 ) iter
+ integer ( kind = 4 ) iwa(1)
+ integer ( kind = 4 ) j
+ logical jeval
+ integer ( kind = 4 ) l
+ integer ( kind = 4 ) maxfev
+ integer ( kind = 4 ) mode
+ integer ( kind = 4 ) ncfail
+ integer ( kind = 4 ) nslow1
+ integer ( kind = 4 ) nslow2
+ integer ( kind = 4 ) ncsuc
+ integer ( kind = 4 ) nfev
+ integer ( kind = 4 ) njev
+ integer ( kind = 4 ) nprint
+ logical pivot
+ real ( kind = 8 ) pnorm
+ real ( kind = 8 ) prered
+ real ( kind = 8 ) qtf(n)
+ real ( kind = 8 ) r(lr)
+ real ( kind = 8 ) ratio
+ logical sing
+ real ( kind = 8 ) sum2
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) wa1(n)
+ real ( kind = 8 ) wa2(n)
+ real ( kind = 8 ) wa3(n)
+ real ( kind = 8 ) wa4(n)
+ real ( kind = 8 ) x(n)
+ real ( kind = 8 ) xnorm
+ real ( kind = 8 ) xtol
+
+ epsmch = epsilon ( epsmch )
+
+ info = 0
+ iflag = 0
+ nfev = 0
+ njev = 0
+!
+! Check the input parameters for errors.
+!
+ if ( n <= 0 ) then
+ if ( iflag < 0 ) then
+ info = iflag
+ end if
+ iflag = 0
+ if ( 0 < nprint ) then
+ call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+ end if
+ return
+ end if
+
+ if ( ldfjac < n .or. &
+ xtol < 0.0D+00 .or. &
+ maxfev <= 0 .or. &
+ factor <= 0.0D+00 .or. &
+ lr < ( n * ( n + 1 ) ) / 2 ) then
+ if ( iflag < 0 ) then
+ info = iflag
+ end if
+ iflag = 0
+ if ( 0 < nprint ) then
+ call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+ end if
+ return
+ end if
+
+ if ( mode == 2 ) then
+ do j = 1, n
+ if ( diag(j) <= 0.0D+00 ) then
+ if ( iflag < 0 ) then
+ info = iflag
+ end if
+ iflag = 0
+ if ( 0 < nprint ) then
+ call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+ end if
+ return
+ end if
+ end do
+ end if
+!
+! Evaluate the function at the starting point and calculate its norm.
+!
+ iflag = 1
+ call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+ nfev = 1
+
+ if ( iflag < 0 ) then
+ if ( iflag < 0 ) then
+ info = iflag
+ end if
+ iflag = 0
+ if ( 0 < nprint ) then
+ call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+ end if
+ return
+ end if
+
+ fnorm = enorm ( n, fvec )
+!
+! Initialize iteration counter and monitors.
+!
+ iter = 1
+ ncsuc = 0
+ ncfail = 0
+ nslow1 = 0
+ nslow2 = 0
+!
+! Beginning of the outer loop.
+!
+ do
+
+ jeval = .true.
+!
+! Calculate the jacobian matrix.
+!
+ iflag = 2
+ call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+ njev = njev + 1
+
+ if ( iflag < 0 ) then
+ info = iflag
+ iflag = 0
+ if ( 0 < nprint ) then
+ call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+ end if
+ return
+ end if
+!
+! Compute the QR factorization of the jacobian.
+!
+ pivot = .false.
+ call qrfac ( n, n, fjac, ldfjac, pivot, iwa, 1, wa1, wa2 )
+!
+! On the first iteration, if MODE is 1, scale according
+! to the norms of the columns of the initial jacobian.
+!
+ if ( iter == 1 ) then
+
+ if ( mode /= 2 ) then
+ diag(1:n) = wa2(1:n)
+ do j = 1, n
+ if ( wa2(j) == 0.0D+00 ) then
+ diag(j) = 1.0D+00
+ end if
+ end do
+ end if
+!
+! On the first iteration, calculate the norm of the scaled X
+! and initialize the step bound DELTA.
+!
+ wa3(1:n) = diag(1:n) * x(1:n)
+ xnorm = enorm ( n, wa3 )
+ delta = factor * xnorm
+ if ( delta == 0.0D+00 ) then
+ delta = factor
+ end if
+
+ end if
+!
+! Form Q'*FVEC and store in QTF.
+!
+ qtf(1:n) = fvec(1:n)
+
+ do j = 1, n
+ if ( fjac(j,j) /= 0.0D+00 ) then
+ sum2 = 0.0D+00
+ do i = j, n
+ sum2 = sum2 + fjac(i,j) * qtf(i)
+ end do
+ temp = - sum2 / fjac(j,j)
+ do i = j, n
+ qtf(i) = qtf(i) + fjac(i,j) * temp
+ end do
+ end if
+ end do
+!
+! Copy the triangular factor of the QR factorization into R.
+!
+ sing = .false.
+
+ do j = 1, n
+ l = j
+ do i = 1, j - 1
+ r(l) = fjac(i,j)
+ l = l + n - i
+ end do
+ r(l) = wa1(j)
+ if ( wa1(j) == 0.0D+00 ) then
+ sing = .true.
+ end if
+ end do
+!
+! Accumulate the orthogonal factor in FJAC.
+!
+ call qform ( n, n, fjac, ldfjac )
+!
+! Rescale if necessary.
+!
+ if ( mode /= 2 ) then
+ do j = 1, n
+ diag(j) = max ( diag(j), wa2(j) )
+ end do
+ end if
+!
+! Beginning of the inner loop.
+!
+ do
+!
+! If requested, call FCN to enable printing of iterates.
+!
+ if ( 0 < nprint ) then
+
+ iflag = 0
+ if ( mod ( iter - 1, nprint ) == 0 ) then
+ call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+ end if
+
+ if ( iflag < 0 ) then
+ info = iflag
+ iflag = 0
+ if ( 0 < nprint ) then
+ call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+ end if
+ return
+ end if
+
+ end if
+!
+! Determine the direction P.
+!
+ call dogleg ( n, r, lr, diag, qtf, delta, wa1 )
+!
+! Store the direction P and X + P.
+! Calculate the norm of P.
+!
+ wa1(1:n) = - wa1(1:n)
+ wa2(1:n) = x(1:n) + wa1(1:n)
+ wa3(1:n) = diag(1:n) * wa1(1:n)
+ pnorm = enorm ( n, wa3 )
+!
+! On the first iteration, adjust the initial step bound.
+!
+ if ( iter == 1 ) then
+ delta = min ( delta, pnorm )
+ end if
+!
+! Evaluate the function at X + P and calculate its norm.
+!
+ iflag = 1
+ call fcn ( n, wa2, wa4, fjac, ldfjac, iflag )
+ nfev = nfev + 1
+
+ if ( iflag < 0 ) then
+ info = iflag
+ iflag = 0
+ if ( 0 < nprint ) then
+ call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+ end if
+ return
+ end if
+
+ fnorm1 = enorm ( n, wa4 )
+!
+! Compute the scaled actual reduction.
+!
+ actred = -1.0D+00
+ if ( fnorm1 < fnorm ) then
+ actred = 1.0D+00 - ( fnorm1 / fnorm ) ** 2
+ end if
+!
+! Compute the scaled predicted reduction.
+!
+ l = 1
+ do i = 1, n
+ sum2 = 0.0D+00
+ do j = i, n
+ sum2 = sum2 + r(l) * wa1(j)
+ l = l + 1
+ end do
+ wa3(i) = qtf(i) + sum2
+ end do
+
+ temp = enorm ( n, wa3 )
+ prered = 0.0D+00
+ if ( temp < fnorm ) then
+ prered = 1.0D+00 - ( temp / fnorm ) ** 2
+ end if
+!
+! Compute the ratio of the actual to the predicted reduction.
+!
+ if ( 0.0D+00 < prered ) then
+ ratio = actred / prered
+ else
+ ratio = 0.0D+00
+ end if
+!
+! Update the step bound.
+!
+ if ( ratio < 0.1D+00 ) then
+
+ ncsuc = 0
+ ncfail = ncfail + 1
+ delta = 0.5D+00 * delta
+
+ else
+
+ ncfail = 0
+ ncsuc = ncsuc + 1
+
+ if ( 0.5D+00 <= ratio .or. 1 < ncsuc ) then
+ delta = max ( delta, pnorm / 0.5D+00 )
+ end if
+
+ if ( abs ( ratio - 1.0D+00 ) <= 0.1D+00 ) then
+ delta = pnorm / 0.5D+00
+ end if
+
+ end if
+!
+! Test for successful iteration.
+!
+
+!
+! Successful iteration.
+! Update X, FVEC, and their norms.
+!
+ if ( 0.0001D+00 <= ratio ) then
+ x(1:n) = wa2(1:n)
+ wa2(1:n) = diag(1:n) * x(1:n)
+ fvec(1:n) = wa4(1:n)
+ xnorm = enorm ( n, wa2 )
+ fnorm = fnorm1
+ iter = iter + 1
+ end if
+!
+! Determine the progress of the iteration.
+!
+ nslow1 = nslow1 + 1
+ if ( 0.001D+00 <= actred ) then
+ nslow1 = 0
+ end if
+
+ if ( jeval ) then
+ nslow2 = nslow2 + 1
+ end if
+
+ if ( 0.1D+00 <= actred ) then
+ nslow2 = 0
+ end if
+!
+! Test for convergence.
+!
+ if ( delta <= xtol * xnorm .or. fnorm == 0.0D+00 ) then
+ info = 1
+ end if
+
+ if ( info /= 0 ) then
+ iflag = 0
+ if ( 0 < nprint ) then
+ call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+ end if
+ return
+ end if
+!
+! Tests for termination and stringent tolerances.
+!
+ if ( maxfev <= nfev ) then
+ info = 2
+ end if
+
+ if ( 0.1D+00 * max ( 0.1D+00 * delta, pnorm ) <= epsmch * xnorm ) then
+ info = 3
+ end if
+
+ if ( nslow2 == 5 ) then
+ info = 4
+ end if
+
+ if ( nslow1 == 10 ) then
+ info = 5
+ end if
+
+ if ( info /= 0 ) then
+ iflag = 0
+ if ( 0 < nprint ) then
+ call fcn ( n, x, fvec, fjac, ldfjac, iflag )
+ end if
+ return
+ end if
+!
+! Criterion for recalculating jacobian.
+!
+ if ( ncfail == 2 ) then
+ exit
+ end if
+!
+! Calculate the rank one modification to the jacobian
+! and update QTF if necessary.
+!
+ do j = 1, n
+ sum2 = dot_product ( wa4(1:n), fjac(1:n,j) )
+ wa2(j) = ( sum2 - wa3(j) ) / pnorm
+ wa1(j) = diag(j) * ( ( diag(j) * wa1(j) ) / pnorm )
+ if ( 0.0001D+00 <= ratio ) then
+ qtf(j) = sum2
+ end if
+ end do
+!
+! Compute the QR factorization of the updated jacobian.
+!
+ call r1updt ( n, n, r, lr, wa1, wa2, wa3, sing )
+ call r1mpyq ( n, n, fjac, ldfjac, wa2, wa3 )
+ call r1mpyq ( 1, n, qtf, 1, wa2, wa3 )
+!
+! End of the inner loop.
+!
+ jeval = .false.
+
+ end do
+!
+! End of the outer loop.
+!
+ end do
+
+end
+subroutine hybrj1 ( fcn, n, x, fvec, fjac, ldfjac, tol, info )
+
+!*****************************************************************************80
+!
+!! HYBRJ1 seeks a zero of N equations in N variables by Powell's method.
+!
+! Discussion:
+!
+! HYBRJ1 finds a zero of a system of N nonlinear functions in N variables
+! by a modification of the Powell hybrid method. This is done by using the
+! more general nonlinear equation solver HYBRJ. The user
+! must provide a subroutine which calculates the functions
+! and the jacobian.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, external FCN, the name of the user-supplied subroutine which
+! calculates the functions and the jacobian. FCN should have the form:
+! subroutine fcn ( n, x, fvec, fjac, ldfjac, iflag )
+! integer ( kind = 4 ) ldfjac
+! integer ( kind = 4 ) n
+! real ( kind = 8 ) fjac(ldfjac,n)
+! real ( kind = 8 ) fvec(n)
+! integer ( kind = 4 ) iflag
+! real ( kind = 8 ) x(n)
+!
+! If IFLAG = 0 on input, then FCN is only being called to allow the user
+! to print out the current iterate.
+! If IFLAG = 1 on input, FCN should calculate the functions at X and
+! return this vector in FVEC.
+! If IFLAG = 2 on input, FCN should calculate the jacobian at X and
+! return this matrix in FJAC.
+! To terminate the algorithm, FCN may set IFLAG negative on return.
+!
+! Input, integer ( kind = 4 ) N, the number of functions and variables.
+!
+! Input/output, real ( kind = 8 ) X(N). On input, X must contain an initial
+! estimate of the solution vector. On output X contains the final
+! estimate of the solution vector.
+!
+! Output, real ( kind = 8 ) FVEC(N), the functions evaluated at the output X.
+!
+! Output, real ( kind = 8 ) FJAC(LDFJAC,N), an N by N array which contains
+! the orthogonal matrix Q produced by the QR factorization of the final
+! approximate jacobian.
+!
+! Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC.
+! LDFJAC must be at least N.
+!
+! Input, real ( kind = 8 ) TOL. Termination occurs when the algorithm
+! estimates that the relative error between X and the solution is at most
+! TOL. TOL should be nonnegative.
+!
+! Output, integer ( kind = 4 ) INFO, error flag. If the user has terminated
+! execution, INFO is set to the (negative) value of IFLAG. See description
+! of FCN. Otherwise, INFO is set as follows:
+! 0, improper input parameters.
+! 1, algorithm estimates that the relative error between X and the
+! solution is at most TOL.
+! 2, number of calls to FCN with IFLAG = 1 has reached 100*(N+1).
+! 3, TOL is too small. No further improvement in the approximate
+! solution X is possible.
+! 4, iteration is not making good progress.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldfjac
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) diag(n)
+ real ( kind = 8 ) factor
+ external fcn
+ real ( kind = 8 ) fjac(ldfjac,n)
+ real ( kind = 8 ) fvec(n)
+ integer ( kind = 4 ) info
+ integer ( kind = 4 ) j
+ integer ( kind = 4 ) lr
+ integer ( kind = 4 ) maxfev
+ integer ( kind = 4 ) mode
+ integer ( kind = 4 ) nfev
+ integer ( kind = 4 ) njev
+ integer ( kind = 4 ) nprint
+ real ( kind = 8 ) qtf(n)
+ real ( kind = 8 ) r((n*(n+1))/2)
+ real ( kind = 8 ) tol
+ real ( kind = 8 ) x(n)
+ real ( kind = 8 ) xtol
+
+ info = 0
+
+ if ( n <= 0 ) then
+ return
+ else if ( ldfjac < n ) then
+ return
+ else if ( tol < 0.0D+00 ) then
+ return
+ end if
+
+ maxfev = 100 * ( n + 1 )
+ xtol = tol
+ mode = 2
+ diag(1:n) = 1.0D+00
+ factor = 100.0D+00
+ nprint = 0
+ lr = ( n * ( n + 1 ) ) / 2
+
+ call hybrj ( fcn, n, x, fvec, fjac, ldfjac, xtol, maxfev, diag, mode, &
+ factor, nprint, info, nfev, njev, r, lr, qtf )
+
+ if ( info == 5 ) then
+ info = 4
+ end if
+
+ return
+end
+subroutine lmder ( fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, &
+ diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf )
+
+!*****************************************************************************80
+!
+!! LMDER minimizes M functions in N variables by the Levenberg-Marquardt method.
+!
+! Discussion:
+!
+! LMDER minimizes the sum of the squares of M nonlinear functions in
+! N variables by a modification of the Levenberg-Marquardt algorithm.
+! The user must provide a subroutine which calculates the functions
+! and the jacobian.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, external FCN, the name of the user-supplied subroutine which
+! calculates the functions and the jacobian. FCN should have the form:
+! subroutine fcn ( m, n, x, fvec, fjac, ldfjac, iflag )
+! integer ( kind = 4 ) ldfjac
+! integer ( kind = 4 ) n
+! real ( kind = 8 ) fjac(ldfjac,n)
+! real ( kind = 8 ) fvec(m)
+! integer ( kind = 4 ) iflag
+! real ( kind = 8 ) x(n)
+!
+! If IFLAG = 0 on input, then FCN is only being called to allow the user
+! to print out the current iterate.
+! If IFLAG = 1 on input, FCN should calculate the functions at X and
+! return this vector in FVEC.
+! If IFLAG = 2 on input, FCN should calculate the jacobian at X and
+! return this matrix in FJAC.
+! To terminate the algorithm, FCN may set IFLAG negative on return.
+!
+! Input, integer ( kind = 4 ) M, is the number of functions.
+!
+! Input, integer ( kind = 4 ) N, is the number of variables.
+! N must not exceed M.
+!
+! Input/output, real ( kind = 8 ) X(N). On input, X must contain an initial
+! estimate of the solution vector. On output X contains the final
+! estimate of the solution vector.
+!
+! Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X.
+!
+! Output, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array. The upper
+! N by N submatrix of FJAC contains an upper triangular matrix R with
+! diagonal elements of nonincreasing magnitude such that
+! P' * ( JAC' * JAC ) * P = R' * R,
+! where P is a permutation matrix and JAC is the final calculated jacobian.
+! Column J of P is column IPVT(J) of the identity matrix. The lower
+! trapezoidal part of FJAC contains information generated during
+! the computation of R.
+!
+! Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC.
+! LDFJAC must be at least M.
+!
+! Input, real ( kind = 8 ) FTOL. Termination occurs when both the actual
+! and predicted relative reductions in the sum of squares are at most FTOL.
+! Therefore, FTOL measures the relative error desired in the sum of
+! squares. FTOL should be nonnegative.
+!
+! Input, real ( kind = 8 ) XTOL. Termination occurs when the relative error
+! between two consecutive iterates is at most XTOL. XTOL should be
+! nonnegative.
+!
+! Input, real ( kind = 8 ) GTOL. Termination occurs when the cosine of the
+! angle between FVEC and any column of the jacobian is at most GTOL in
+! absolute value. Therefore, GTOL measures the orthogonality desired
+! between the function vector and the columns of the jacobian. GTOL should
+! be nonnegative.
+!
+! Input, integer ( kind = 4 ) MAXFEV. Termination occurs when the number of
+! calls to FCN with IFLAG = 1 is at least MAXFEV by the end of an iteration.
+!
+! Input/output, real ( kind = 8 ) DIAG(N). If MODE = 1, then DIAG is set
+! internally. If MODE = 2, then DIAG must contain positive entries that
+! serve as multiplicative scale factors for the variables.
+!
+! Input, integer ( kind = 4 ) MODE, scaling option.
+! 1, variables will be scaled internally.
+! 2, scaling is specified by the input DIAG vector.
+!
+! Input, real ( kind = 8 ) FACTOR, determines the initial step bound. This
+! bound is set to the product of FACTOR and the euclidean norm of DIAG*X if
+! nonzero, or else to FACTOR itself. In most cases, FACTOR should lie
+! in the interval (0.1, 100) with 100 the recommended value.
+!
+! Input, integer ( kind = 4 ) NPRINT, enables controlled printing of iterates
+! if it is positive. In this case, FCN is called with IFLAG = 0 at the
+! beginning of the first iteration and every NPRINT iterations thereafter
+! and immediately prior to return, with X and FVEC available
+! for printing. If NPRINT is not positive, no special calls
+! of FCN with IFLAG = 0 are made.
+!
+! Output, integer ( kind = 4 ) INFO, error flag. If the user has terminated
+! execution, INFO is set to the (negative) value of IFLAG. See description
+! of FCN. Otherwise, INFO is set as follows:
+! 0, improper input parameters.
+! 1, both actual and predicted relative reductions in the sum of
+! squares are at most FTOL.
+! 2, relative error between two consecutive iterates is at most XTOL.
+! 3, conditions for INFO = 1 and INFO = 2 both hold.
+! 4, the cosine of the angle between FVEC and any column of the jacobian
+! is at most GTOL in absolute value.
+! 5, number of calls to FCN with IFLAG = 1 has reached MAXFEV.
+! 6, FTOL is too small. No further reduction in the sum of squares
+! is possible.
+! 7, XTOL is too small. No further improvement in the approximate
+! solution X is possible.
+! 8, GTOL is too small. FVEC is orthogonal to the columns of the
+! jacobian to machine precision.
+!
+! Output, integer ( kind = 4 ) NFEV, the number of calls to FCN with
+! IFLAG = 1.
+!
+! Output, integer ( kind = 4 ) NJEV, the number of calls to FCN with
+! IFLAG = 2.
+!
+! Output, integer ( kind = 4 ) IPVT(N), defines a permutation matrix P
+! such that JAC*P = Q*R, where JAC is the final calculated jacobian, Q is
+! orthogonal (not stored), and R is upper triangular with diagonal
+! elements of nonincreasing magnitude. Column J of P is column
+! IPVT(J) of the identity matrix.
+!
+! Output, real ( kind = 8 ) QTF(N), contains the first N elements of Q'*FVEC.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldfjac
+ integer ( kind = 4 ) m
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) actred
+ real ( kind = 8 ) delta
+ real ( kind = 8 ) diag(n)
+ real ( kind = 8 ) dirder
+ real ( kind = 8 ) enorm
+ real ( kind = 8 ) epsmch
+ real ( kind = 8 ) factor
+ external fcn
+ real ( kind = 8 ) fjac(ldfjac,n)
+ real ( kind = 8 ) fnorm
+ real ( kind = 8 ) fnorm1
+ real ( kind = 8 ) ftol
+ real ( kind = 8 ) fvec(m)
+ real ( kind = 8 ) gnorm
+ real ( kind = 8 ) gtol
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) iflag
+ integer ( kind = 4 ) info
+ integer ( kind = 4 ) ipvt(n)
+ integer ( kind = 4 ) iter
+ integer ( kind = 4 ) j
+ integer ( kind = 4 ) l
+ integer ( kind = 4 ) maxfev
+ integer ( kind = 4 ) mode
+ integer ( kind = 4 ) nfev
+ integer ( kind = 4 ) njev
+ integer ( kind = 4 ) nprint
+ real ( kind = 8 ) par
+ logical pivot
+ real ( kind = 8 ) pnorm
+ real ( kind = 8 ) prered
+ real ( kind = 8 ) qtf(n)
+ real ( kind = 8 ) ratio
+ real ( kind = 8 ) sum2
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) temp1
+ real ( kind = 8 ) temp2
+ real ( kind = 8 ) wa1(n)
+ real ( kind = 8 ) wa2(n)
+ real ( kind = 8 ) wa3(n)
+ real ( kind = 8 ) wa4(m)
+ real ( kind = 8 ) xnorm
+ real ( kind = 8 ) x(n)
+ real ( kind = 8 ) xtol
+
+ epsmch = epsilon ( epsmch )
+
+ info = 0
+ iflag = 0
+ nfev = 0
+ njev = 0
+!
+! Check the input parameters for errors.
+!
+ if ( n <= 0 ) then
+ go to 300
+ end if
+
+ if ( m < n ) then
+ go to 300
+ end if
+
+ if ( ldfjac < m &
+ .or. ftol < 0.0D+00 .or. xtol < 0.0D+00 .or. gtol < 0.0D+00 &
+ .or. maxfev <= 0 .or. factor <= 0.0D+00 ) then
+ go to 300
+ end if
+
+ if ( mode == 2 ) then
+ do j = 1, n
+ if ( diag(j) <= 0.0D+00 ) then
+ go to 300
+ end if
+ end do
+ end if
+!
+! Evaluate the function at the starting point and calculate its norm.
+!
+ iflag = 1
+ call fcn ( m, n, x, fvec, fjac, ldfjac, iflag )
+ nfev = 1
+ if ( iflag < 0 ) then
+ go to 300
+ end if
+
+ fnorm = enorm ( m, fvec )
+!
+! Initialize Levenberg-Marquardt parameter and iteration counter.
+!
+ par = 0.0D+00
+ iter = 1
+!
+! Beginning of the outer loop.
+!
+30 continue
+!
+! Calculate the jacobian matrix.
+!
+ iflag = 2
+ call fcn ( m, n, x, fvec, fjac, ldfjac, iflag )
+
+ njev = njev + 1
+
+ if ( iflag < 0 ) then
+ go to 300
+ end if
+!
+! If requested, call FCN to enable printing of iterates.
+!
+ if ( 0 < nprint ) then
+ iflag = 0
+ if ( mod ( iter - 1, nprint ) == 0 ) then
+ call fcn ( m, n, x, fvec, fjac, ldfjac, iflag )
+ end if
+ if ( iflag < 0 ) then
+ go to 300
+ end if
+ end if
+!
+! Compute the QR factorization of the jacobian.
+!
+ pivot = .true.
+ call qrfac ( m, n, fjac, ldfjac, pivot, ipvt, n, wa1, wa2 )
+!
+! On the first iteration and if mode is 1, scale according
+! to the norms of the columns of the initial jacobian.
+!
+ if ( iter == 1 ) then
+
+ if ( mode /= 2 ) then
+ diag(1:n) = wa2(1:n)
+ do j = 1, n
+ if ( wa2(j) == 0.0D+00 ) then
+ diag(j) = 1.0D+00
+ end if
+ end do
+ end if
+!
+! On the first iteration, calculate the norm of the scaled X
+! and initialize the step bound DELTA.
+!
+ wa3(1:n) = diag(1:n) * x(1:n)
+
+ xnorm = enorm ( n, wa3 )
+ delta = factor * xnorm
+ if ( delta == 0.0D+00 ) then
+ delta = factor
+ end if
+
+ end if
+!
+! Form Q'*FVEC and store the first N components in QTF.
+!
+ wa4(1:m) = fvec(1:m)
+
+ do j = 1, n
+
+ if ( fjac(j,j) /= 0.0D+00 ) then
+ sum2 = dot_product ( wa4(j:m), fjac(j:m,j) )
+ temp = - sum2 / fjac(j,j)
+ wa4(j:m) = wa4(j:m) + fjac(j:m,j) * temp
+ end if
+
+ fjac(j,j) = wa1(j)
+ qtf(j) = wa4(j)
+
+ end do
+!
+! Compute the norm of the scaled gradient.
+!
+ gnorm = 0.0D+00
+
+ if ( fnorm /= 0.0D+00 ) then
+
+ do j = 1, n
+ l = ipvt(j)
+ if ( wa2(l) /= 0.0D+00 ) then
+ sum2 = dot_product ( qtf(1:j), fjac(1:j,j) ) / fnorm
+ gnorm = max ( gnorm, abs ( sum2 / wa2(l) ) )
+ end if
+ end do
+
+ end if
+!
+! Test for convergence of the gradient norm.
+!
+ if ( gnorm <= gtol ) then
+ info = 4
+ go to 300
+ end if
+!
+! Rescale if necessary.
+!
+ if ( mode /= 2 ) then
+ do j = 1, n
+ diag(j) = max ( diag(j), wa2(j) )
+ end do
+ end if
+!
+! Beginning of the inner loop.
+!
+200 continue
+!
+! Determine the Levenberg-Marquardt parameter.
+!
+ call lmpar ( n, fjac, ldfjac, ipvt, diag, qtf, delta, par, wa1, wa2 )
+!
+! Store the direction p and x + p. calculate the norm of p.
+!
+ wa1(1:n) = - wa1(1:n)
+ wa2(1:n) = x(1:n) + wa1(1:n)
+ wa3(1:n) = diag(1:n) * wa1(1:n)
+
+ pnorm = enorm ( n, wa3 )
+!
+! On the first iteration, adjust the initial step bound.
+!
+ if ( iter == 1 ) then
+ delta = min ( delta, pnorm )
+ end if
+!
+! Evaluate the function at x + p and calculate its norm.
+!
+ iflag = 1
+ call fcn ( m, n, wa2, wa4, fjac, ldfjac, iflag )
+
+ nfev = nfev + 1
+
+ if ( iflag < 0 ) then
+ go to 300
+ end if
+
+ fnorm1 = enorm ( m, wa4 )
+!
+! Compute the scaled actual reduction.
+!
+ actred = -1.0D+00
+ if ( 0.1D+00 * fnorm1 < fnorm ) then
+ actred = 1.0D+00 - ( fnorm1 / fnorm ) ** 2
+ end if
+!
+! Compute the scaled predicted reduction and
+! the scaled directional derivative.
+!
+ do j = 1, n
+ wa3(j) = 0.0D+00
+ l = ipvt(j)
+ temp = wa1(l)
+ wa3(1:j) = wa3(1:j) + fjac(1:j,j) * temp
+ end do
+
+ temp1 = enorm ( n, wa3 ) / fnorm
+ temp2 = ( sqrt ( par ) * pnorm ) / fnorm
+ prered = temp1 ** 2 + temp2 ** 2 / 0.5D+00
+ dirder = - ( temp1 ** 2 + temp2 ** 2 )
+!
+! Compute the ratio of the actual to the predicted reduction.
+!
+ if ( prered /= 0.0D+00 ) then
+ ratio = actred / prered
+ else
+ ratio = 0.0D+00
+ end if
+!
+! Update the step bound.
+!
+ if ( ratio <= 0.25D+00 ) then
+
+ if ( 0.0D+00 <= actred ) then
+ temp = 0.5D+00
+ end if
+
+ if ( actred < 0.0D+00 ) then
+ temp = 0.5D+00 * dirder / ( dirder + 0.5D+00 * actred )
+ end if
+
+ if ( 0.1D+00 * fnorm1 >= fnorm .or. temp < 0.1D+00 ) then
+ temp = 0.1D+00
+ end if
+
+ delta = temp * min ( delta, pnorm / 0.1D+00 )
+ par = par / temp
+
+ else
+
+ if ( par == 0.0D+00 .or. ratio >= 0.75D+00 ) then
+ delta = 2.0D+00 * pnorm
+ par = 0.5D+00 * par
+ end if
+
+ end if
+!
+! Successful iteration.
+!
+! Update X, FVEC, and their norms.
+!
+ if ( 0.0001D+00 <= ratio ) then
+ x(1:n) = wa2(1:n)
+ wa2(1:n) = diag(1:n) * x(1:n)
+ fvec(1:m) = wa4(1:m)
+ xnorm = enorm ( n, wa2 )
+ fnorm = fnorm1
+ iter = iter + 1
+ end if
+!
+! Tests for convergence.
+!
+ if ( abs ( actred) <= ftol .and. &
+ prered <= ftol .and. &
+ 0.5D+00 * ratio <= 1.0D+00 ) then
+ info = 1
+ end if
+
+ if ( delta <= xtol * xnorm ) then
+ info = 2
+ end if
+
+ if ( abs ( actred) <= ftol .and. prered <= ftol &
+ .and. 0.5D+00 * ratio <= 1.0D+00 .and. info == 2 ) then
+ info = 3
+ end if
+
+ if ( info /= 0 ) then
+ go to 300
+ end if
+!
+! Tests for termination and stringent tolerances.
+!
+ if ( nfev >= maxfev ) then
+ info = 5
+ end if
+
+ if ( abs ( actred ) <= epsmch .and. prered <= epsmch &
+ .and. 0.5D+00 * ratio <= 1.0D+00 ) then
+ info = 6
+ end if
+
+ if ( delta <= epsmch * xnorm ) then
+ info = 7
+ end if
+
+ if ( gnorm <= epsmch ) then
+ info = 8
+ end if
+
+ if ( info /= 0 ) then
+ go to 300
+ end if
+!
+! End of the inner loop. repeat if iteration unsuccessful.
+!
+ if ( ratio < 0.0001D+00 ) then
+ go to 200
+ end if
+!
+! End of the outer loop.
+!
+ go to 30
+
+ 300 continue
+!
+! Termination, either normal or user imposed.
+!
+ if ( iflag < 0 ) then
+ info = iflag
+ end if
+
+ iflag = 0
+
+ if ( 0 < nprint ) then
+ call fcn ( m, n, x, fvec, fjac, ldfjac, iflag )
+ end if
+
+ return
+end
+subroutine lmder1 ( fcn, m, n, x, fvec, fjac, ldfjac, tol, info )
+
+!*****************************************************************************80
+!
+!! LMDER1 minimizes M functions in N variables by Levenberg-Marquardt method.
+!
+! Discussion:
+!
+! LMDER1 minimizes the sum of the squares of M nonlinear functions in
+! N variables by a modification of the Levenberg-Marquardt algorithm.
+! This is done by using the more general least-squares solver LMDER.
+! The user must provide a subroutine which calculates the functions
+! and the jacobian.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, external FCN, the name of the user-supplied subroutine which
+! calculates the functions and the jacobian. FCN should have the form:
+! subroutine fcn ( m, n, x, fvec, fjac, ldfjac, iflag )
+! integer ( kind = 4 ) ldfjac
+! integer ( kind = 4 ) n
+! real ( kind = 8 ) fjac(ldfjac,n)
+! real ( kind = 8 ) fvec(m)
+! integer ( kind = 4 ) iflag
+! real ( kind = 8 ) x(n)
+!
+! If IFLAG = 0 on input, then FCN is only being called to allow the user
+! to print out the current iterate.
+! If IFLAG = 1 on input, FCN should calculate the functions at X and
+! return this vector in FVEC.
+! If IFLAG = 2 on input, FCN should calculate the jacobian at X and
+! return this matrix in FJAC.
+! To terminate the algorithm, FCN may set IFLAG negative on return.
+!
+! Input, integer ( kind = 4 ) M, the number of functions.
+!
+! Input, integer ( kind = 4 ) N, is the number of variables.
+! N must not exceed M.
+!
+! Input/output, real ( kind = 8 ) X(N). On input, X must contain an initial
+! estimate of the solution vector. On output X contains the final
+! estimate of the solution vector.
+!
+! Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X.
+!
+! Output, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array. The upper
+! N by N submatrix contains an upper triangular matrix R with
+! diagonal elements of nonincreasing magnitude such that
+! P' * ( JAC' * JAC ) * P = R' * R,
+! where P is a permutation matrix and JAC is the final calculated
+! jacobian. Column J of P is column IPVT(J) of the identity matrix.
+! The lower trapezoidal part of FJAC contains information generated during
+! the computation of R.
+!
+! Input, integer ( kind = 4 ) LDFJAC, is the leading dimension of FJAC,
+! which must be no less than M.
+!
+! Input, real ( kind = 8 ) TOL. Termination occurs when the algorithm
+! estimates either that the relative error in the sum of squares is at
+! most TOL or that the relative error between X and the solution is at
+! most TOL.
+!
+! Output, integer ( kind = 4 ) INFO, error flag. If the user has terminated
+! execution, INFO is set to the (negative) value of IFLAG. See description
+! of FCN. Otherwise, INFO is set as follows:
+! 0, improper input parameters.
+! 1, algorithm estimates that the relative error in the sum of squares
+! is at most TOL.
+! 2, algorithm estimates that the relative error between X and the
+! solution is at most TOL.
+! 3, conditions for INFO = 1 and INFO = 2 both hold.
+! 4, FVEC is orthogonal to the columns of the jacobian to machine precision.
+! 5, number of calls to FCN with IFLAG = 1 has reached 100*(N+1).
+! 6, TOL is too small. No further reduction in the sum of squares is
+! possible.
+! 7, TOL is too small. No further improvement in the approximate
+! solution X is possible.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldfjac
+ integer ( kind = 4 ) m
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) diag(n)
+ real ( kind = 8 ) factor
+ external fcn
+ real ( kind = 8 ) fjac(ldfjac,n)
+ real ( kind = 8 ) ftol
+ real ( kind = 8 ) fvec(m)
+ real ( kind = 8 ) gtol
+ integer ( kind = 4 ) info
+ integer ( kind = 4 ) ipvt(n)
+ integer ( kind = 4 ) maxfev
+ integer ( kind = 4 ) mode
+ integer ( kind = 4 ) nfev
+ integer ( kind = 4 ) njev
+ integer ( kind = 4 ) nprint
+ real ( kind = 8 ) qtf(n)
+ real ( kind = 8 ) tol
+ real ( kind = 8 ) x(n)
+ real ( kind = 8 ) xtol
+
+ info = 0
+
+ if ( n <= 0 ) then
+ return
+ else if ( m < n ) then
+ return
+ else if ( ldfjac < m ) then
+ return
+ else if ( tol < 0.0D+00 ) then
+ return
+ end if
+
+ factor = 100.0D+00
+ maxfev = 100 * ( n + 1 )
+ ftol = tol
+ xtol = tol
+ gtol = 0.0D+00
+ mode = 1
+ nprint = 0
+
+ call lmder ( fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, &
+ diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf )
+
+ if ( info == 8 ) then
+ info = 4
+ end if
+
+ return
+end
+subroutine lmdif ( fcn, m, n, x, fvec, ftol, xtol, gtol, maxfev, epsfcn, &
+ diag, mode, factor, nprint, info, nfev, fjac, ldfjac, ipvt, qtf )
+
+!*****************************************************************************80
+!
+!! LMDIF minimizes M functions in N variables by the Levenberg-Marquardt method.
+!
+! Discussion:
+!
+! LMDIF minimizes the sum of the squares of M nonlinear functions in
+! N variables by a modification of the Levenberg-Marquardt algorithm.
+! The user must provide a subroutine which calculates the functions.
+! The jacobian is then calculated by a forward-difference approximation.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, external FCN, the name of the user-supplied subroutine which
+! calculates the functions. The routine should have the form:
+! subroutine fcn ( m, n, x, fvec, iflag )
+! integer ( kind = 4 ) m
+! integer ( kind = 4 ) n
+! real ( kind = 8 ) fvec(m)
+! integer ( kind = 4 ) iflag
+! real ( kind = 8 ) x(n)
+! If IFLAG = 0 on input, then FCN is only being called to allow the user
+! to print out the current iterate.
+! If IFLAG = 1 on input, FCN should calculate the functions at X and
+! return this vector in FVEC.
+! To terminate the algorithm, FCN may set IFLAG negative on return.
+!
+! Input, integer ( kind = 4 ) M, the number of functions.
+!
+! Input, integer ( kind = 4 ) N, the number of variables.
+! N must not exceed M.
+!
+! Input/output, real ( kind = 8 ) X(N). On input, X must contain an initial
+! estimate of the solution vector. On output X contains the final
+! estimate of the solution vector.
+!
+! Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X.
+!
+! Input, real ( kind = 8 ) FTOL. Termination occurs when both the actual
+! and predicted relative reductions in the sum of squares are at most FTOL.
+! Therefore, FTOL measures the relative error desired in the sum of
+! squares. FTOL should be nonnegative.
+!
+! Input, real ( kind = 8 ) XTOL. Termination occurs when the relative error
+! between two consecutive iterates is at most XTOL. Therefore, XTOL
+! measures the relative error desired in the approximate solution. XTOL
+! should be nonnegative.
+!
+! Input, real ( kind = 8 ) GTOL. termination occurs when the cosine of the
+! angle between FVEC and any column of the jacobian is at most GTOL in
+! absolute value. Therefore, GTOL measures the orthogonality desired
+! between the function vector and the columns of the jacobian. GTOL should
+! be nonnegative.
+!
+! Input, integer ( kind = 4 ) MAXFEV. Termination occurs when the number of
+! calls to FCN is at least MAXFEV by the end of an iteration.
+!
+! Input, real ( kind = 8 ) EPSFCN, is used in determining a suitable step
+! length for the forward-difference approximation. This approximation
+! assumes that the relative errors in the functions are of the order of
+! EPSFCN. If EPSFCN is less than the machine precision, it is assumed that
+! the relative errors in the functions are of the order of the machine
+! precision.
+!
+! Input/output, real ( kind = 8 ) DIAG(N). If MODE = 1, then DIAG is set
+! internally. If MODE = 2, then DIAG must contain positive entries that
+! serve as multiplicative scale factors for the variables.
+!
+! Input, integer ( kind = 4 ) MODE, scaling option.
+! 1, variables will be scaled internally.
+! 2, scaling is specified by the input DIAG vector.
+!
+! Input, real ( kind = 8 ) FACTOR, determines the initial step bound.
+! This bound is set to the product of FACTOR and the euclidean norm of
+! DIAG*X if nonzero, or else to FACTOR itself. In most cases, FACTOR should
+! lie in the interval (0.1, 100) with 100 the recommended value.
+!
+! Input, integer ( kind = 4 ) NPRINT, enables controlled printing of iterates
+! if it is positive. In this case, FCN is called with IFLAG = 0 at the
+! beginning of the first iteration and every NPRINT iterations thereafter
+! and immediately prior to return, with X and FVEC available
+! for printing. If NPRINT is not positive, no special calls
+! of FCN with IFLAG = 0 are made.
+!
+! Output, integer ( kind = 4 ) INFO, error flag. If the user has terminated
+! execution, INFO is set to the (negative) value of IFLAG. See description
+! of FCN. Otherwise, INFO is set as follows:
+! 0, improper input parameters.
+! 1, both actual and predicted relative reductions in the sum of squares
+! are at most FTOL.
+! 2, relative error between two consecutive iterates is at most XTOL.
+! 3, conditions for INFO = 1 and INFO = 2 both hold.
+! 4, the cosine of the angle between FVEC and any column of the jacobian
+! is at most GTOL in absolute value.
+! 5, number of calls to FCN has reached or exceeded MAXFEV.
+! 6, FTOL is too small. No further reduction in the sum of squares
+! is possible.
+! 7, XTOL is too small. No further improvement in the approximate
+! solution X is possible.
+! 8, GTOL is too small. FVEC is orthogonal to the columns of the
+! jacobian to machine precision.
+!
+! Output, integer ( kind = 4 ) NFEV, the number of calls to FCN.
+!
+! Output, real ( kind = 8 ) FJAC(LDFJAC,N), an M by N array. The upper
+! N by N submatrix of FJAC contains an upper triangular matrix R with
+! diagonal elements of nonincreasing magnitude such that
+!
+! P' * ( JAC' * JAC ) * P = R' * R,
+!
+! where P is a permutation matrix and JAC is the final calculated jacobian.
+! Column J of P is column IPVT(J) of the identity matrix. The lower
+! trapezoidal part of FJAC contains information generated during
+! the computation of R.
+!
+! Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC.
+! LDFJAC must be at least M.
+!
+! Output, integer ( kind = 4 ) IPVT(N), defines a permutation matrix P such
+! that JAC * P = Q * R, where JAC is the final calculated jacobian, Q is
+! orthogonal (not stored), and R is upper triangular with diagonal
+! elements of nonincreasing magnitude. Column J of P is column IPVT(J)
+! of the identity matrix.
+!
+! Output, real ( kind = 8 ) QTF(N), the first N elements of Q'*FVEC.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldfjac
+ integer ( kind = 4 ) m
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) actred
+ real ( kind = 8 ) delta
+ real ( kind = 8 ) diag(n)
+ real ( kind = 8 ) dirder
+ real ( kind = 8 ) enorm
+ real ( kind = 8 ) epsfcn
+ real ( kind = 8 ) epsmch
+ real ( kind = 8 ) factor
+ external fcn
+ real ( kind = 8 ) fjac(ldfjac,n)
+ real ( kind = 8 ) fnorm
+ real ( kind = 8 ) fnorm1
+ real ( kind = 8 ) ftol
+ real ( kind = 8 ) fvec(m)
+ real ( kind = 8 ) gnorm
+ real ( kind = 8 ) gtol
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) iflag
+ integer ( kind = 4 ) iter
+ integer ( kind = 4 ) info
+ integer ( kind = 4 ) ipvt(n)
+ integer ( kind = 4 ) j
+ integer ( kind = 4 ) l
+ integer ( kind = 4 ) maxfev
+ integer ( kind = 4 ) mode
+ integer ( kind = 4 ) nfev
+ integer ( kind = 4 ) nprint
+ real ( kind = 8 ) par
+ logical pivot
+ real ( kind = 8 ) pnorm
+ real ( kind = 8 ) prered
+ real ( kind = 8 ) qtf(n)
+ real ( kind = 8 ) ratio
+ real ( kind = 8 ) sum2
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) temp1
+ real ( kind = 8 ) temp2
+ real ( kind = 8 ) wa1(n)
+ real ( kind = 8 ) wa2(n)
+ real ( kind = 8 ) wa3(n)
+ real ( kind = 8 ) wa4(m)
+ real ( kind = 8 ) x(n)
+ real ( kind = 8 ) xnorm
+ real ( kind = 8 ) xtol
+
+ epsmch = epsilon ( epsmch )
+
+ info = 0
+ iflag = 0
+ nfev = 0
+
+ if ( n <= 0 ) then
+ go to 300
+ else if ( m < n ) then
+ go to 300
+ else if ( ldfjac < m ) then
+ go to 300
+ else if ( ftol < 0.0D+00 ) then
+ go to 300
+ else if ( xtol < 0.0D+00 ) then
+ go to 300
+ else if ( gtol < 0.0D+00 ) then
+ go to 300
+ else if ( maxfev <= 0 ) then
+ go to 300
+ else if ( factor <= 0.0D+00 ) then
+ go to 300
+ end if
+
+ if ( mode == 2 ) then
+ do j = 1, n
+ if ( diag(j) <= 0.0D+00 ) then
+ go to 300
+ end if
+ end do
+ end if
+!
+! Evaluate the function at the starting point and calculate its norm.
+!
+ iflag = 1
+ call fcn ( m, n, x, fvec, iflag )
+ nfev = 1
+
+ if ( iflag < 0 ) then
+ go to 300
+ end if
+
+ fnorm = enorm ( m, fvec )
+!
+! Initialize Levenberg-Marquardt parameter and iteration counter.
+!
+ par = 0.0D+00
+ iter = 1
+!
+! Beginning of the outer loop.
+!
+30 continue
+!
+! Calculate the jacobian matrix.
+!
+ iflag = 2
+ call fdjac2 ( fcn, m, n, x, fvec, fjac, ldfjac, iflag, epsfcn )
+ nfev = nfev + n
+
+ if ( iflag < 0 ) then
+ go to 300
+ end if
+!
+! If requested, call FCN to enable printing of iterates.
+!
+ if ( 0 < nprint ) then
+ iflag = 0
+ if ( mod ( iter - 1, nprint ) == 0 ) then
+ call fcn ( m, n, x, fvec, iflag )
+ end if
+ if ( iflag < 0 ) then
+ go to 300
+ end if
+ end if
+!
+! Compute the QR factorization of the jacobian.
+!
+ pivot = .true.
+ call qrfac ( m, n, fjac, ldfjac, pivot, ipvt, n, wa1, wa2 )
+!
+! On the first iteration and if MODE is 1, scale according
+! to the norms of the columns of the initial jacobian.
+!
+ if ( iter == 1 ) then
+
+ if ( mode /= 2 ) then
+ diag(1:n) = wa2(1:n)
+ do j = 1, n
+ if ( wa2(j) == 0.0D+00 ) then
+ diag(j) = 1.0D+00
+ end if
+ end do
+ end if
+!
+! On the first iteration, calculate the norm of the scaled X
+! and initialize the step bound DELTA.
+!
+ wa3(1:n) = diag(1:n) * x(1:n)
+ xnorm = enorm ( n, wa3 )
+ delta = factor * xnorm
+ if ( delta == 0.0D+00 ) then
+ delta = factor
+ end if
+ end if
+!
+! Form Q' * FVEC and store the first N components in QTF.
+!
+ wa4(1:m) = fvec(1:m)
+
+ do j = 1, n
+
+ if ( fjac(j,j) /= 0.0D+00 ) then
+ sum2 = dot_product ( wa4(j:m), fjac(j:m,j) )
+ temp = - sum2 / fjac(j,j)
+ wa4(j:m) = wa4(j:m) + fjac(j:m,j) * temp
+ end if
+
+ fjac(j,j) = wa1(j)
+ qtf(j) = wa4(j)
+
+ end do
+!
+! Compute the norm of the scaled gradient.
+!
+ gnorm = 0.0D+00
+
+ if ( fnorm /= 0.0D+00 ) then
+
+ do j = 1, n
+
+ l = ipvt(j)
+
+ if ( wa2(l) /= 0.0D+00 ) then
+ sum2 = 0.0D+00
+ do i = 1, j
+ sum2 = sum2 + fjac(i,j) * ( qtf(i) / fnorm )
+ end do
+ gnorm = max ( gnorm, abs ( sum2 / wa2(l) ) )
+ end if
+
+ end do
+
+ end if
+!
+! Test for convergence of the gradient norm.
+!
+ if ( gnorm <= gtol ) then
+ info = 4
+ go to 300
+ end if
+!
+! Rescale if necessary.
+!
+ if ( mode /= 2 ) then
+ do j = 1, n
+ diag(j) = max ( diag(j), wa2(j) )
+ end do
+ end if
+!
+! Beginning of the inner loop.
+!
+200 continue
+!
+! Determine the Levenberg-Marquardt parameter.
+!
+ call lmpar ( n, fjac, ldfjac, ipvt, diag, qtf, delta, par, wa1, wa2 )
+!
+! Store the direction P and X + P.
+! Calculate the norm of P.
+!
+ wa1(1:n) = -wa1(1:n)
+ wa2(1:n) = x(1:n) + wa1(1:n)
+ wa3(1:n) = diag(1:n) * wa1(1:n)
+
+ pnorm = enorm ( n, wa3 )
+!
+! On the first iteration, adjust the initial step bound.
+!
+ if ( iter == 1 ) then
+ delta = min ( delta, pnorm )
+ end if
+!
+! Evaluate the function at X + P and calculate its norm.
+!
+ iflag = 1
+ call fcn ( m, n, wa2, wa4, iflag )
+ nfev = nfev + 1
+ if ( iflag < 0 ) then
+ go to 300
+ end if
+ fnorm1 = enorm ( m, wa4 )
+!
+! Compute the scaled actual reduction.
+!
+ if ( 0.1D+00 * fnorm1 < fnorm ) then
+ actred = 1.0D+00 - ( fnorm1 / fnorm ) ** 2
+ else
+ actred = -1.0D+00
+ end if
+!
+! Compute the scaled predicted reduction and the scaled directional derivative.
+!
+ do j = 1, n
+ wa3(j) = 0.0D+00
+ l = ipvt(j)
+ temp = wa1(l)
+ wa3(1:j) = wa3(1:j) + fjac(1:j,j) * temp
+ end do
+
+ temp1 = enorm ( n, wa3 ) / fnorm
+ temp2 = ( sqrt ( par ) * pnorm ) / fnorm
+ prered = temp1 ** 2 + temp2 ** 2 / 0.5D+00
+ dirder = - ( temp1 ** 2 + temp2 ** 2 )
+!
+! Compute the ratio of the actual to the predicted reduction.
+!
+ ratio = 0.0D+00
+ if ( prered /= 0.0D+00 ) then
+ ratio = actred / prered
+ end if
+!
+! Update the step bound.
+!
+ if ( ratio <= 0.25D+00 ) then
+
+ if ( actred >= 0.0D+00 ) then
+ temp = 0.5D+00
+ endif
+
+ if ( actred < 0.0D+00 ) then
+ temp = 0.5D+00 * dirder / ( dirder + 0.5D+00 * actred )
+ end if
+
+ if ( 0.1D+00 * fnorm1 >= fnorm .or. temp < 0.1D+00 ) then
+ temp = 0.1D+00
+ end if
+
+ delta = temp * min ( delta, pnorm / 0.1D+00 )
+ par = par / temp
+
+ else
+
+ if ( par == 0.0D+00 .or. ratio >= 0.75D+00 ) then
+ delta = 2.0D+00 * pnorm
+ par = 0.5D+00 * par
+ end if
+
+ end if
+!
+! Test for successful iteration.
+!
+
+!
+! Successful iteration. update X, FVEC, and their norms.
+!
+ if ( 0.0001D+00 <= ratio ) then
+ x(1:n) = wa2(1:n)
+ wa2(1:n) = diag(1:n) * x(1:n)
+ fvec(1:m) = wa4(1:m)
+ xnorm = enorm ( n, wa2 )
+ fnorm = fnorm1
+ iter = iter + 1
+ end if
+!
+! Tests for convergence.
+!
+ if ( abs ( actred) <= ftol .and. prered <= ftol &
+ .and. 0.5D+00 * ratio <= 1.0D+00 ) then
+ info = 1
+ end if
+
+ if ( delta <= xtol * xnorm ) then
+ info = 2
+ end if
+
+ if ( abs ( actred) <= ftol .and. prered <= ftol &
+ .and. 0.5D+00 * ratio <= 1.0D+00 .and. info == 2 ) info = 3
+
+ if ( info /= 0 ) then
+ go to 300
+ end if
+!
+! Tests for termination and stringent tolerances.
+!
+ if ( maxfev <= nfev ) then
+ info = 5
+ end if
+
+ if ( abs ( actred) <= epsmch .and. prered <= epsmch &
+ .and. 0.5D+00 * ratio <= 1.0D+00 ) then
+ info = 6
+ end if
+
+ if ( delta <= epsmch * xnorm ) then
+ info = 7
+ end if
+
+ if ( gnorm <= epsmch ) then
+ info = 8
+ end if
+
+ if ( info /= 0 ) then
+ go to 300
+ end if
+!
+! End of the inner loop. Repeat if iteration unsuccessful.
+!
+ if ( ratio < 0.0001D+00 ) then
+ go to 200
+ end if
+!
+! End of the outer loop.
+!
+ go to 30
+
+300 continue
+!
+! Termination, either normal or user imposed.
+!
+ if ( iflag < 0 ) then
+ info = iflag
+ end if
+
+ iflag = 0
+
+ if ( 0 < nprint ) then
+ call fcn ( m, n, x, fvec, iflag )
+ end if
+
+ return
+end
+subroutine lmdif1 ( fcn, m, n, x, fvec, tol, info )
+
+!*****************************************************************************80
+!
+!! LMDIF1 minimizes M functions in N variables using Levenberg-Marquardt method.
+!
+! Discussion:
+!
+! LMDIF1 minimizes the sum of the squares of M nonlinear functions in
+! N variables by a modification of the Levenberg-Marquardt algorithm.
+! This is done by using the more general least-squares solver LMDIF.
+! The user must provide a subroutine which calculates the functions.
+! The jacobian is then calculated by a forward-difference approximation.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, external FCN, the name of the user-supplied subroutine which
+! calculates the functions. The routine should have the form:
+! subroutine fcn ( m, n, x, fvec, iflag )
+! integer ( kind = 4 ) n
+! real ( kind = 8 ) fvec(m)
+! integer ( kind = 4 ) iflag
+! real ( kind = 8 ) x(n)
+!
+! If IFLAG = 0 on input, then FCN is only being called to allow the user
+! to print out the current iterate.
+! If IFLAG = 1 on input, FCN should calculate the functions at X and
+! return this vector in FVEC.
+! To terminate the algorithm, FCN may set IFLAG negative on return.
+!
+! Input, integer ( kind = 4 ) M, the number of functions.
+!
+! Input, integer ( kind = 4 ) N, the number of variables.
+! N must not exceed M.
+!
+! Input/output, real ( kind = 8 ) X(N). On input, X must contain an initial
+! estimate of the solution vector. On output X contains the final
+! estimate of the solution vector.
+!
+! Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X.
+!
+! Input, real ( kind = 8 ) TOL. Termination occurs when the algorithm
+! estimates either that the relative error in the sum of squares is at
+! most TOL or that the relative error between X and the solution is at
+! most TOL. TOL should be nonnegative.
+!
+! Output, integer ( kind = 4 ) INFO, error flag. If the user has terminated
+! execution, INFO is set to the (negative) value of IFLAG. See description
+! of FCN. Otherwise, INFO is set as follows:
+! 0, improper input parameters.
+! 1, algorithm estimates that the relative error in the sum of squares
+! is at most TOL.
+! 2, algorithm estimates that the relative error between X and the
+! solution is at most TOL.
+! 3, conditions for INFO = 1 and INFO = 2 both hold.
+! 4, FVEC is orthogonal to the columns of the jacobian to machine precision.
+! 5, number of calls to FCN has reached or exceeded 200*(N+1).
+! 6, TOL is too small. No further reduction in the sum of squares
+! is possible.
+! 7, TOL is too small. No further improvement in the approximate
+! solution X is possible.
+!
+ implicit none
+
+ integer ( kind = 4 ) m
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) diag(n)
+ real ( kind = 8 ) epsfcn
+ real ( kind = 8 ) factor
+ external fcn
+ real ( kind = 8 ) fjac(m,n)
+ real ( kind = 8 ) ftol
+ real ( kind = 8 ) fvec(m)
+ real ( kind = 8 ) gtol
+ integer ( kind = 4 ) info
+ integer ( kind = 4 ) ipvt(n)
+ integer ( kind = 4 ) ldfjac
+ integer ( kind = 4 ) maxfev
+ integer ( kind = 4 ) mode
+ integer ( kind = 4 ) nfev
+ integer ( kind = 4 ) nprint
+ real ( kind = 8 ) qtf(n)
+ real ( kind = 8 ) tol
+ real ( kind = 8 ) x(n)
+ real ( kind = 8 ) xtol
+
+ info = 0
+
+ if ( n <= 0 ) then
+ return
+ else if ( m < n ) then
+ return
+ else if ( tol < 0.0D+00 ) then
+ return
+ end if
+
+ ! *** BVIE BEGIN ***
+ !factor = 100.0D+00
+ factor = 0.1D+00
+ ! *** BVIE END ***
+ maxfev = 200 * ( n + 1 )
+ ftol = tol
+ xtol = tol
+ gtol = 0.0D+00
+ epsfcn = 0.0D+00
+ mode = 1
+ nprint = 0
+ ldfjac = m
+
+ call lmdif ( fcn, m, n, x, fvec, ftol, xtol, gtol, maxfev, epsfcn, &
+ diag, mode, factor, nprint, info, nfev, fjac, ldfjac, ipvt, qtf )
+
+ if ( info == 8 ) then
+ info = 4
+ end if
+
+ return
+end
+subroutine lmpar ( n, r, ldr, ipvt, diag, qtb, delta, par, x, sdiag )
+
+!*****************************************************************************80
+!
+!! LMPAR computes a parameter for the Levenberg-Marquardt method.
+!
+! Discussion:
+!
+! Given an M by N matrix A, an N by N nonsingular diagonal
+! matrix D, an M-vector B, and a positive number DELTA,
+! the problem is to determine a value for the parameter
+! PAR such that if X solves the system
+!
+! A*X = B,
+! sqrt ( PAR ) * D * X = 0,
+!
+! in the least squares sense, and DXNORM is the euclidean
+! norm of D*X, then either PAR is zero and
+!
+! ( DXNORM - DELTA ) <= 0.1 * DELTA,
+!
+! or PAR is positive and
+!
+! abs ( DXNORM - DELTA) <= 0.1 * DELTA.
+!
+! This subroutine completes the solution of the problem
+! if it is provided with the necessary information from the
+! QR factorization, with column pivoting, of A. That is, if
+! A*P = Q*R, where P is a permutation matrix, Q has orthogonal
+! columns, and R is an upper triangular matrix with diagonal
+! elements of nonincreasing magnitude, then LMPAR expects
+! the full upper triangle of R, the permutation matrix P,
+! and the first N components of Q'*B. On output
+! LMPAR also provides an upper triangular matrix S such that
+!
+! P' * ( A' * A + PAR * D * D ) * P = S'* S.
+!
+! S is employed within LMPAR and may be of separate interest.
+!
+! Only a few iterations are generally needed for convergence
+! of the algorithm. If, however, the limit of 10 iterations
+! is reached, then the output PAR will contain the best
+! value obtained so far.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 24 January 2014
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, integer ( kind = 4 ) N, the order of R.
+!
+! Input/output, real ( kind = 8 ) R(LDR,N),the N by N matrix. The full
+! upper triangle must contain the full upper triangle of the matrix R.
+! On output the full upper triangle is unaltered, and the strict lower
+! triangle contains the strict upper triangle (transposed) of the upper
+! triangular matrix S.
+!
+! Input, integer ( kind = 4 ) LDR, the leading dimension of R. LDR must be
+! no less than N.
+!
+! Input, integer ( kind = 4 ) IPVT(N), defines the permutation matrix P
+! such that A*P = Q*R. Column J of P is column IPVT(J) of the
+! identity matrix.
+!
+! Input, real ( kind = 8 ) DIAG(N), the diagonal elements of the matrix D.
+!
+! Input, real ( kind = 8 ) QTB(N), the first N elements of the vector Q'*B.
+!
+! Input, real ( kind = 8 ) DELTA, an upper bound on the euclidean norm
+! of D*X. DELTA should be positive.
+!
+! Input/output, real ( kind = 8 ) PAR. On input an initial estimate of the
+! Levenberg-Marquardt parameter. On output the final estimate.
+! PAR should be nonnegative.
+!
+! Output, real ( kind = 8 ) X(N), the least squares solution of the system
+! A*X = B, sqrt(PAR)*D*X = 0, for the output value of PAR.
+!
+! Output, real ( kind = 8 ) SDIAG(N), the diagonal elements of the upper
+! triangular matrix S.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldr
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) delta
+ real ( kind = 8 ) diag(n)
+ real ( kind = 8 ) dwarf
+ real ( kind = 8 ) dxnorm
+ real ( kind = 8 ) enorm
+ real ( kind = 8 ) gnorm
+ real ( kind = 8 ) fp
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) ipvt(n)
+ integer ( kind = 4 ) iter
+ integer ( kind = 4 ) j
+ integer ( kind = 4 ) k
+ integer ( kind = 4 ) l
+ integer ( kind = 4 ) nsing
+ real ( kind = 8 ) par
+ real ( kind = 8 ) parc
+ real ( kind = 8 ) parl
+ real ( kind = 8 ) paru
+ real ( kind = 8 ) qnorm
+ real ( kind = 8 ) qtb(n)
+ real ( kind = 8 ) r(ldr,n)
+ real ( kind = 8 ) sdiag(n)
+ real ( kind = 8 ) sum2
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) wa1(n)
+ real ( kind = 8 ) wa2(n)
+ real ( kind = 8 ) x(n)
+!
+! DWARF is the smallest positive magnitude.
+!
+ dwarf = tiny ( dwarf )
+!
+! Compute and store in X the Gauss-Newton direction.
+!
+! If the jacobian is rank-deficient, obtain a least squares solution.
+!
+ nsing = n
+
+ do j = 1, n
+ wa1(j) = qtb(j)
+ if ( r(j,j) == 0.0D+00 .and. nsing == n ) then
+ nsing = j - 1
+ end if
+ if ( nsing < n ) then
+ wa1(j) = 0.0D+00
+ end if
+ end do
+
+ do k = 1, nsing
+ j = nsing - k + 1
+ wa1(j) = wa1(j) / r(j,j)
+ temp = wa1(j)
+ wa1(1:j-1) = wa1(1:j-1) - r(1:j-1,j) * temp
+ end do
+
+ do j = 1, n
+ l = ipvt(j)
+ x(l) = wa1(j)
+ end do
+!
+! Initialize the iteration counter.
+! Evaluate the function at the origin, and test
+! for acceptance of the Gauss-Newton direction.
+!
+ iter = 0
+ wa2(1:n) = diag(1:n) * x(1:n)
+ dxnorm = enorm ( n, wa2 )
+ fp = dxnorm - delta
+
+ if ( fp <= 0.1D+00 * delta ) then
+ if ( iter == 0 ) then
+ par = 0.0D+00
+ end if
+ return
+ end if
+!
+! If the jacobian is not rank deficient, the Newton
+! step provides a lower bound, PARL, for the zero of
+! the function.
+!
+! Otherwise set this bound to zero.
+!
+ parl = 0.0D+00
+
+ if ( n <= nsing ) then
+
+ do j = 1, n
+ l = ipvt(j)
+ wa1(j) = diag(l) * ( wa2(l) / dxnorm )
+ end do
+
+ do j = 1, n
+ sum2 = dot_product ( wa1(1:j-1), r(1:j-1,j) )
+ wa1(j) = ( wa1(j) - sum2 ) / r(j,j)
+ end do
+
+ temp = enorm ( n, wa1 )
+ parl = ( ( fp / delta ) / temp ) / temp
+
+ end if
+!
+! Calculate an upper bound, PARU, for the zero of the function.
+!
+ do j = 1, n
+ sum2 = dot_product ( qtb(1:j), r(1:j,j) )
+ l = ipvt(j)
+ wa1(j) = sum2 / diag(l)
+ end do
+
+ gnorm = enorm ( n, wa1 )
+ paru = gnorm / delta
+
+ if ( paru == 0.0D+00 ) then
+ paru = dwarf / min ( delta, 0.1D+00 )
+ end if
+!
+! If the input PAR lies outside of the interval (PARL, PARU),
+! set PAR to the closer endpoint.
+!
+ par = max ( par, parl )
+ par = min ( par, paru )
+ if ( par == 0.0D+00 ) then
+ par = gnorm / dxnorm
+ end if
+!
+! Beginning of an iteration.
+!
+ do
+
+ iter = iter + 1
+!
+! Evaluate the function at the current value of PAR.
+!
+ if ( par == 0.0D+00 ) then
+ par = max ( dwarf, 0.001D+00 * paru )
+ end if
+
+ wa1(1:n) = sqrt ( par ) * diag(1:n)
+
+ call qrsolv ( n, r, ldr, ipvt, wa1, qtb, x, sdiag )
+
+ wa2(1:n) = diag(1:n) * x(1:n)
+ dxnorm = enorm ( n, wa2 )
+ temp = fp
+ fp = dxnorm - delta
+!
+! If the function is small enough, accept the current value of PAR.
+!
+ if ( abs ( fp ) <= 0.1D+00 * delta ) then
+ exit
+ end if
+!
+! Test for the exceptional cases where PARL
+! is zero or the number of iterations has reached 10.
+!
+ if ( parl == 0.0D+00 .and. fp <= temp .and. temp < 0.0D+00 ) then
+ exit
+ else if ( iter == 10 ) then
+ exit
+ end if
+!
+! Compute the Newton correction.
+!
+ do j = 1, n
+ l = ipvt(j)
+ wa1(j) = diag(l) * ( wa2(l) / dxnorm )
+ end do
+
+ do j = 1, n
+ wa1(j) = wa1(j) / sdiag(j)
+ temp = wa1(j)
+ wa1(j+1:n) = wa1(j+1:n) - r(j+1:n,j) * temp
+ end do
+
+ temp = enorm ( n, wa1 )
+ parc = ( ( fp / delta ) / temp ) / temp
+!
+! Depending on the sign of the function, update PARL or PARU.
+!
+ if ( 0.0D+00 < fp ) then
+ parl = max ( parl, par )
+ else if ( fp < 0.0D+00 ) then
+ paru = min ( paru, par )
+ end if
+!
+! Compute an improved estimate for PAR.
+!
+ par = max ( parl, par + parc )
+!
+! End of an iteration.
+!
+ end do
+!
+! Termination.
+!
+ if ( iter == 0 ) then
+ par = 0.0D+00
+ end if
+
+ return
+end
+subroutine lmstr ( fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, &
+ diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf )
+
+!*****************************************************************************80
+!
+!! LMSTR minimizes M functions in N variables using Levenberg-Marquardt method.
+!
+! Discussion:
+!
+! LMSTR minimizes the sum of the squares of M nonlinear functions in
+! N variables by a modification of the Levenberg-Marquardt algorithm
+! which uses minimal storage.
+!
+! The user must provide a subroutine which calculates the functions and
+! the rows of the jacobian.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, external FCN, the name of the user-supplied subroutine which
+! calculates the functions and the rows of the jacobian.
+! FCN should have the form:
+! subroutine fcn ( m, n, x, fvec, fjrow, iflag )
+! integer ( kind = 4 ) m
+! integer ( kind = 4 ) n
+! real ( kind = 8 ) fjrow(n)
+! real ( kind = 8 ) fvec(m)
+! integer ( kind = 4 ) iflag
+! real ( kind = 8 ) x(n)
+! If IFLAG = 0 on input, then FCN is only being called to allow the user
+! to print out the current iterate.
+! If IFLAG = 1 on input, FCN should calculate the functions at X and
+! return this vector in FVEC.
+! If the input value of IFLAG is I > 1, calculate the (I-1)-st row of
+! the jacobian at X, and return this vector in FJROW.
+! To terminate the algorithm, set the output value of IFLAG negative.
+!
+! Input, integer ( kind = 4 ) M, the number of functions.
+!
+! Input, integer ( kind = 4 ) N, the number of variables.
+! N must not exceed M.
+!
+! Input/output, real ( kind = 8 ) X(N). On input, X must contain an initial
+! estimate of the solution vector. On output X contains the final
+! estimate of the solution vector.
+!
+! Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X.
+!
+! Output, real ( kind = 8 ) FJAC(LDFJAC,N), an N by N array. The upper
+! triangle of FJAC contains an upper triangular matrix R such that
+!
+! P' * ( JAC' * JAC ) * P = R' * R,
+!
+! where P is a permutation matrix and JAC is the final calculated jacobian.
+! Column J of P is column IPVT(J) of the identity matrix. The lower
+! triangular part of FJAC contains information generated during
+! the computation of R.
+!
+! Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC.
+! LDFJAC must be at least N.
+!
+! Input, real ( kind = 8 ) FTOL. Termination occurs when both the actual and
+! predicted relative reductions in the sum of squares are at most FTOL.
+! Therefore, FTOL measures the relative error desired in the sum of
+! squares. FTOL should be nonnegative.
+!
+! Input, real ( kind = 8 ) XTOL. Termination occurs when the relative error
+! between two consecutive iterates is at most XTOL. XTOL should be
+! nonnegative.
+!
+! Input, real ( kind = 8 ) GTOL. termination occurs when the cosine of the
+! angle between FVEC and any column of the jacobian is at most GTOL in
+! absolute value. Therefore, GTOL measures the orthogonality desired
+! between the function vector and the columns of the jacobian. GTOL should
+! be nonnegative.
+!
+! Input, integer ( kind = 4 ) MAXFEV. Termination occurs when the number
+! of calls to FCN with IFLAG = 1 is at least MAXFEV by the end of
+! an iteration.
+!
+! Input/output, real ( kind = 8 ) DIAG(N). If MODE = 1, then DIAG is set
+! internally. If MODE = 2, then DIAG must contain positive entries that
+! serve as multiplicative scale factors for the variables.
+!
+! Input, integer ( kind = 4 ) MODE, scaling option.
+! 1, variables will be scaled internally.
+! 2, scaling is specified by the input DIAG vector.
+!
+! Input, real ( kind = 8 ) FACTOR, determines the initial step bound. This
+! bound is set to the product of FACTOR and the euclidean norm of DIAG*X if
+! nonzero, or else to FACTOR itself. In most cases, FACTOR should lie
+! in the interval (0.1, 100) with 100 the recommended value.
+!
+! Input, integer ( kind = 4 ) NPRINT, enables controlled printing of iterates
+! if it is positive. In this case, FCN is called with IFLAG = 0 at the
+! beginning of the first iteration and every NPRINT iterations thereafter
+! and immediately prior to return, with X and FVEC available
+! for printing. If NPRINT is not positive, no special calls
+! of FCN with IFLAG = 0 are made.
+!
+! Output, integer ( kind = 4 ) INFO, error flag. If the user has terminated
+! execution, INFO is set to the (negative) value of IFLAG. See the
+! description of FCN. Otherwise, INFO is set as follows:
+! 0, improper input parameters.
+! 1, both actual and predicted relative reductions in the sum of squares
+! are at most FTOL.
+! 2, relative error between two consecutive iterates is at most XTOL.
+! 3, conditions for INFO = 1 and INFO = 2 both hold.
+! 4, the cosine of the angle between FVEC and any column of the jacobian
+! is at most GTOL in absolute value.
+! 5, number of calls to FCN with IFLAG = 1 has reached MAXFEV.
+! 6, FTOL is too small. No further reduction in the sum of squares is
+! possible.
+! 7, XTOL is too small. No further improvement in the approximate
+! solution X is possible.
+! 8, GTOL is too small. FVEC is orthogonal to the columns of the
+! jacobian to machine precision.
+!
+! Output, integer ( kind = 4 ) NFEV, the number of calls to FCN
+! with IFLAG = 1.
+!
+! Output, integer ( kind = 4 ) NJEV, the number of calls to FCN
+! with IFLAG = 2.
+!
+! Output, integer ( kind = 4 ) IPVT(N), defines a permutation matrix P such
+! that JAC * P = Q * R, where JAC is the final calculated jacobian, Q is
+! orthogonal (not stored), and R is upper triangular.
+! Column J of P is column IPVT(J) of the identity matrix.
+!
+! Output, real ( kind = 8 ) QTF(N), contains the first N elements of Q'*FVEC.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldfjac
+ integer ( kind = 4 ) m
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) actred
+ real ( kind = 8 ) delta
+ real ( kind = 8 ) diag(n)
+ real ( kind = 8 ) dirder
+ real ( kind = 8 ) enorm
+ real ( kind = 8 ) epsmch
+ real ( kind = 8 ) factor
+ external fcn
+ real ( kind = 8 ) fjac(ldfjac,n)
+ real ( kind = 8 ) fnorm
+ real ( kind = 8 ) fnorm1
+ real ( kind = 8 ) ftol
+ real ( kind = 8 ) fvec(m)
+ real ( kind = 8 ) gnorm
+ real ( kind = 8 ) gtol
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) iflag
+ integer ( kind = 4 ) info
+ integer ( kind = 4 ) ipvt(n)
+ integer ( kind = 4 ) iter
+ integer ( kind = 4 ) j
+ integer ( kind = 4 ) l
+ integer ( kind = 4 ) maxfev
+ integer ( kind = 4 ) mode
+ integer ( kind = 4 ) nfev
+ integer ( kind = 4 ) njev
+ integer ( kind = 4 ) nprint
+ real ( kind = 8 ) par
+ logical pivot
+ real ( kind = 8 ) pnorm
+ real ( kind = 8 ) prered
+ real ( kind = 8 ) qtf(n)
+ real ( kind = 8 ) ratio
+ logical sing
+ real ( kind = 8 ) sum2
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) temp1
+ real ( kind = 8 ) temp2
+ real ( kind = 8 ) wa1(n)
+ real ( kind = 8 ) wa2(n)
+ real ( kind = 8 ) wa3(n)
+ real ( kind = 8 ) wa4(m)
+ real ( kind = 8 ) x(n)
+ real ( kind = 8 ) xnorm
+ real ( kind = 8 ) xtol
+
+ epsmch = epsilon ( epsmch )
+
+ info = 0
+ iflag = 0
+ nfev = 0
+ njev = 0
+!
+! Check the input parameters for errors.
+!
+ if ( n <= 0 ) then
+ go to 340
+ else if ( m < n ) then
+ go to 340
+ else if ( ldfjac < n ) then
+ go to 340
+ else if ( ftol < 0.0D+00 ) then
+ go to 340
+ else if ( xtol < 0.0D+00 ) then
+ go to 340
+ else if ( gtol < 0.0D+00 ) then
+ go to 340
+ else if ( maxfev <= 0 ) then
+ go to 340
+ else if ( factor <= 0.0D+00 ) then
+ go to 340
+ end if
+
+ if ( mode == 2 ) then
+ do j = 1, n
+ if ( diag(j) <= 0.0D+00 ) then
+ go to 340
+ end if
+ end do
+ end if
+!
+! Evaluate the function at the starting point and calculate its norm.
+!
+ iflag = 1
+ call fcn ( m, n, x, fvec, wa3, iflag )
+ nfev = 1
+
+ if ( iflag < 0 ) then
+ go to 340
+ end if
+
+ fnorm = enorm ( m, fvec )
+!
+! Initialize Levenberg-Marquardt parameter and iteration counter.
+!
+ par = 0.0D+00
+ iter = 1
+!
+! Beginning of the outer loop.
+!
+ 30 continue
+!
+! If requested, call FCN to enable printing of iterates.
+!
+ if ( 0 < nprint ) then
+ iflag = 0
+ if ( mod ( iter-1, nprint ) == 0 ) then
+ call fcn ( m, n, x, fvec, wa3, iflag )
+ end if
+ if ( iflag < 0 ) then
+ go to 340
+ end if
+ end if
+!
+! Compute the QR factorization of the jacobian matrix calculated one row
+! at a time, while simultaneously forming Q'* FVEC and storing
+! the first N components in QTF.
+!
+ qtf(1:n) = 0.0D+00
+ fjac(1:n,1:n) = 0.0D+00
+ iflag = 2
+
+ do i = 1, m
+ call fcn ( m, n, x, fvec, wa3, iflag )
+ if ( iflag < 0 ) then
+ go to 340
+ end if
+ temp = fvec(i)
+ call rwupdt ( n, fjac, ldfjac, wa3, qtf, temp, wa1, wa2 )
+ iflag = iflag + 1
+ end do
+
+ njev = njev + 1
+!
+! If the jacobian is rank deficient, call QRFAC to
+! reorder its columns and update the components of QTF.
+!
+ sing = .false.
+ do j = 1, n
+ if ( fjac(j,j) == 0.0D+00 ) then
+ sing = .true.
+ end if
+ ipvt(j) = j
+ wa2(j) = enorm ( j, fjac(1,j) )
+ end do
+
+ if ( sing ) then
+
+ pivot = .true.
+ call qrfac ( n, n, fjac, ldfjac, pivot, ipvt, n, wa1, wa2 )
+
+ do j = 1, n
+
+ if ( fjac(j,j) /= 0.0D+00 ) then
+
+ sum2 = dot_product ( qtf(j:n), fjac(j:n,j) )
+ temp = - sum2 / fjac(j,j)
+ qtf(j:n) = qtf(j:n) + fjac(j:n,j) * temp
+
+ end if
+
+ fjac(j,j) = wa1(j)
+
+ end do
+
+ end if
+!
+! On the first iteration
+! if mode is 1,
+! scale according to the norms of the columns of the initial jacobian.
+! calculate the norm of the scaled X,
+! initialize the step bound delta.
+!
+ if ( iter == 1 ) then
+
+ if ( mode /= 2 ) then
+
+ diag(1:n) = wa2(1:n)
+ do j = 1, n
+ if ( wa2(j) == 0.0D+00 ) then
+ diag(j) = 1.0D+00
+ end if
+ end do
+
+ end if
+
+ wa3(1:n) = diag(1:n) * x(1:n)
+ xnorm = enorm ( n, wa3 )
+ delta = factor * xnorm
+ if ( delta == 0.0D+00 ) then
+ delta = factor
+ end if
+
+ end if
+!
+! Compute the norm of the scaled gradient.
+!
+ gnorm = 0.0D+00
+
+ if ( fnorm /= 0.0D+00 ) then
+
+ do j = 1, n
+ l = ipvt(j)
+ if ( wa2(l) /= 0.0D+00 ) then
+ sum2 = dot_product ( qtf(1:j), fjac(1:j,j) ) / fnorm
+ gnorm = max ( gnorm, abs ( sum2 / wa2(l) ) )
+ end if
+ end do
+
+ end if
+!
+! Test for convergence of the gradient norm.
+!
+ if ( gnorm <= gtol ) then
+ info = 4
+ go to 340
+ end if
+!
+! Rescale if necessary.
+!
+ if ( mode /= 2 ) then
+ do j = 1, n
+ diag(j) = max ( diag(j), wa2(j) )
+ end do
+ end if
+!
+! Beginning of the inner loop.
+!
+240 continue
+!
+! Determine the Levenberg-Marquardt parameter.
+!
+ call lmpar ( n, fjac, ldfjac, ipvt, diag, qtf, delta, par, wa1, wa2 )
+!
+! Store the direction P and X + P.
+! Calculate the norm of P.
+!
+ wa1(1:n) = -wa1(1:n)
+ wa2(1:n) = x(1:n) + wa1(1:n)
+ wa3(1:n) = diag(1:n) * wa1(1:n)
+ pnorm = enorm ( n, wa3 )
+!
+! On the first iteration, adjust the initial step bound.
+!
+ if ( iter == 1 ) then
+ delta = min ( delta, pnorm )
+ end if
+!
+! Evaluate the function at X + P and calculate its norm.
+!
+ iflag = 1
+ call fcn ( m, n, wa2, wa4, wa3, iflag )
+ nfev = nfev + 1
+ if ( iflag < 0 ) then
+ go to 340
+ end if
+ fnorm1 = enorm ( m, wa4 )
+!
+! Compute the scaled actual reduction.
+!
+ if ( 0.1D+00 * fnorm1 < fnorm ) then
+ actred = 1.0D+00 - ( fnorm1 / fnorm ) ** 2
+ else
+ actred = -1.0D+00
+ end if
+!
+! Compute the scaled predicted reduction and
+! the scaled directional derivative.
+!
+ do j = 1, n
+ wa3(j) = 0.0D+00
+ l = ipvt(j)
+ temp = wa1(l)
+ wa3(1:j) = wa3(1:j) + fjac(1:j,j) * temp
+ end do
+
+ temp1 = enorm ( n, wa3 ) / fnorm
+ temp2 = ( sqrt(par) * pnorm ) / fnorm
+ prered = temp1 ** 2 + temp2 ** 2 / 0.5D+00
+ dirder = - ( temp1 ** 2 + temp2 ** 2 )
+!
+! Compute the ratio of the actual to the predicted reduction.
+!
+ if ( prered /= 0.0D+00 ) then
+ ratio = actred / prered
+ else
+ ratio = 0.0D+00
+ end if
+!
+! Update the step bound.
+!
+ if ( ratio <= 0.25D+00 ) then
+
+ if ( actred >= 0.0D+00 ) then
+ temp = 0.5D+00
+ else
+ temp = 0.5D+00 * dirder / ( dirder + 0.5D+00 * actred )
+ end if
+
+ if ( 0.1D+00 * fnorm1 >= fnorm .or. temp < 0.1D+00 ) then
+ temp = 0.1D+00
+ end if
+
+ delta = temp * min ( delta, pnorm / 0.1D+00 )
+ par = par / temp
+
+ else
+
+ if ( par == 0.0D+00 .or. ratio >= 0.75D+00 ) then
+ delta = pnorm / 0.5D+00
+ par = 0.5D+00 * par
+ end if
+
+ end if
+!
+! Test for successful iteration.
+!
+ if ( ratio >= 0.0001D+00 ) then
+ x(1:n) = wa2(1:n)
+ wa2(1:n) = diag(1:n) * x(1:n)
+ fvec(1:m) = wa4(1:m)
+ xnorm = enorm ( n, wa2 )
+ fnorm = fnorm1
+ iter = iter + 1
+ end if
+!
+! Tests for convergence, termination and stringent tolerances.
+!
+ if ( abs ( actred ) <= ftol .and. prered <= ftol &
+ .and. 0.5D+00 * ratio <= 1.0D+00 ) then
+ info = 1
+ end if
+
+ if ( delta <= xtol * xnorm ) then
+ info = 2
+ end if
+
+ if ( abs ( actred ) <= ftol .and. prered <= ftol &
+ .and. 0.5D+00 * ratio <= 1.0D+00 .and. info == 2 ) then
+ info = 3
+ end if
+
+ if ( info /= 0 ) then
+ go to 340
+ end if
+
+ if ( nfev >= maxfev) then
+ info = 5
+ end if
+
+ if ( abs ( actred ) <= epsmch .and. prered <= epsmch &
+ .and. 0.5D+00 * ratio <= 1.0D+00 ) then
+ info = 6
+ end if
+
+ if ( delta <= epsmch * xnorm ) then
+ info = 7
+ end if
+
+ if ( gnorm <= epsmch ) then
+ info = 8
+ end if
+
+ if ( info /= 0 ) then
+ go to 340
+ end if
+!
+! End of the inner loop. Repeat if iteration unsuccessful.
+!
+ if ( ratio < 0.0001D+00 ) then
+ go to 240
+ end if
+!
+! End of the outer loop.
+!
+ go to 30
+
+ 340 continue
+!
+! Termination, either normal or user imposed.
+!
+ if ( iflag < 0 ) then
+ info = iflag
+ end if
+
+ iflag = 0
+
+ if ( 0 < nprint ) then
+ call fcn ( m, n, x, fvec, wa3, iflag )
+ end if
+
+ return
+end
+subroutine lmstr1 ( fcn, m, n, x, fvec, fjac, ldfjac, tol, info )
+
+!*****************************************************************************80
+!
+!! LMSTR1 minimizes M functions in N variables using Levenberg-Marquardt method.
+!
+! Discussion:
+!
+! LMSTR1 minimizes the sum of the squares of M nonlinear functions in
+! N variables by a modification of the Levenberg-Marquardt algorithm
+! which uses minimal storage.
+!
+! This is done by using the more general least-squares solver
+! LMSTR. The user must provide a subroutine which calculates
+! the functions and the rows of the jacobian.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 19 August 2016
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, external FCN, the name of the user-supplied subroutine which
+! calculates the functions and the rows of the jacobian.
+! FCN should have the form:
+! subroutine fcn ( m, n, x, fvec, fjrow, iflag )
+! integer ( kind = 4 ) m
+! integer ( kind = 4 ) n
+! real ( kind = 8 ) fjrow(n)
+! real ( kind = 8 ) fvec(m)
+! integer ( kind = 4 ) iflag
+! real ( kind = 8 ) x(n)
+! If IFLAG = 0 on input, then FCN is only being called to allow the user
+! to print out the current iterate.
+! If IFLAG = 1 on input, FCN should calculate the functions at X and
+! return this vector in FVEC.
+! If the input value of IFLAG is I > 1, calculate the (I-1)-st row of
+! the jacobian at X, and return this vector in FJROW.
+! To terminate the algorithm, set the output value of IFLAG negative.
+!
+! Input, integer ( kind = 4 ) M, the number of functions.
+!
+! Input, integer ( kind = 4 ) N, the number of variables.
+! N must not exceed M.
+!
+! Input/output, real ( kind = 8 ) X(N). On input, X must contain an initial
+! estimate of the solution vector. On output X contains the final
+! estimate of the solution vector.
+!
+! Output, real ( kind = 8 ) FVEC(M), the functions evaluated at the output X.
+!
+! Output, real ( kind = 8 ) FJAC(LDFJAC,N), an N by N array. The upper
+! triangle contains an upper triangular matrix R such that
+!
+! P' * ( JAC' * JAC ) * P = R' * R,
+!
+! where P is a permutation matrix and JAC is the final calculated
+! jacobian. Column J of P is column IPVT(J) of the identity matrix.
+! The lower triangular part of FJAC contains information generated
+! during the computation of R.
+!
+! Input, integer ( kind = 4 ) LDFJAC, the leading dimension of FJAC.
+! LDFJAC must be at least N.
+!
+! Input, real ( kind = 8 ) TOL. Termination occurs when the algorithm
+! estimates either that the relative error in the sum of squares is at
+! most TOL or that the relative error between X and the solution is at
+! most TOL. TOL should be nonnegative.
+!
+! Output, integer ( kind = 4 ) INFO, error flag. If the user has terminated
+! execution, INFO is set to the (negative) value of IFLAG. See description
+! of FCN. Otherwise, INFO is set as follows:
+! 0, improper input parameters.
+! 1, algorithm estimates that the relative error in the sum of squares
+! is at most TOL.
+! 2, algorithm estimates that the relative error between X and the
+! solution is at most TOL.
+! 3, conditions for INFO = 1 and INFO = 2 both hold.
+! 4, FVEC is orthogonal to the columns of the jacobian to machine precision.
+! 5, number of calls to FCN with IFLAG = 1 has reached 100*(N+1).
+! 6, TOL is too small. No further reduction in the sum of squares
+! is possible.
+! 7, TOL is too small. No further improvement in the approximate
+! solution X is possible.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldfjac
+ integer ( kind = 4 ) m
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) diag(n)
+ real ( kind = 8 ) factor
+ external fcn
+ real ( kind = 8 ) fjac(ldfjac,n)
+ real ( kind = 8 ) ftol
+ real ( kind = 8 ) fvec(m)
+ real ( kind = 8 ) gtol
+ integer ( kind = 4 ) info
+ integer ( kind = 4 ) ipvt(n)
+ integer ( kind = 4 ) maxfev
+ integer ( kind = 4 ) mode
+ integer ( kind = 4 ) nfev
+ integer ( kind = 4 ) njev
+ integer ( kind = 4 ) nprint
+ real ( kind = 8 ) qtf(n)
+ real ( kind = 8 ) tol
+ real ( kind = 8 ) x(n)
+ real ( kind = 8 ) xtol
+
+ if ( n <= 0 ) then
+ info = 0
+ return
+ end if
+
+ if ( m < n ) then
+ info = 0
+ return
+ end if
+
+ if ( ldfjac < n ) then
+ info = 0
+ return
+ end if
+
+ if ( tol < 0.0D+00 ) then
+ info = 0
+ return
+ end if
+
+ fvec(1:n) = 0.0D+00
+ fjac(1:ldfjac,1:n) = 0.0D+00
+ ftol = tol
+ xtol = tol
+ gtol = 0.0D+00
+ maxfev = 100 * ( n + 1 )
+ diag(1:n) = 0.0D+00
+ mode = 1
+ factor = 100.0D+00
+ nprint = 0
+ info = 0
+ nfev = 0
+ njev = 0
+ ipvt(1:n) = 0
+ qtf(1:n) = 0.0D+00
+
+ call lmstr ( fcn, m, n, x, fvec, fjac, ldfjac, ftol, xtol, gtol, maxfev, &
+ diag, mode, factor, nprint, info, nfev, njev, ipvt, qtf )
+
+ if ( info == 8 ) then
+ info = 4
+ end if
+
+ return
+end
+subroutine qform ( m, n, q, ldq )
+
+!*****************************************************************************80
+!
+!! QFORM produces the explicit QR factorization of a matrix.
+!
+! Discussion:
+!
+! The QR factorization of a matrix is usually accumulated in implicit
+! form, that is, as a series of orthogonal transformations of the
+! original matrix. This routine carries out those transformations,
+! to explicitly exhibit the factorization constructed by QRFAC.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, integer ( kind = 4 ) M, is a positive integer input variable set
+! to the number of rows of A and the order of Q.
+!
+! Input, integer ( kind = 4 ) N, is a positive integer input variable set
+! to the number of columns of A.
+!
+! Input/output, real ( kind = 8 ) Q(LDQ,M). Q is an M by M array.
+! On input the full lower trapezoid in the first min(M,N) columns of Q
+! contains the factored form.
+! On output, Q has been accumulated into a square matrix.
+!
+! Input, integer ( kind = 4 ) LDQ, is a positive integer input variable
+! not less than M which specifies the leading dimension of the array Q.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldq
+ integer ( kind = 4 ) m
+ integer ( kind = 4 ) n
+
+ integer ( kind = 4 ) j
+ integer ( kind = 4 ) k
+ integer ( kind = 4 ) l
+ integer ( kind = 4 ) minmn
+ real ( kind = 8 ) q(ldq,m)
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) wa(m)
+
+ minmn = min ( m, n )
+
+ do j = 2, minmn
+ q(1:j-1,j) = 0.0D+00
+ end do
+!
+! Initialize remaining columns to those of the identity matrix.
+!
+ q(1:m,n+1:m) = 0.0D+00
+
+ do j = n+1, m
+ q(j,j) = 1.0D+00
+ end do
+!
+! Accumulate Q from its factored form.
+!
+ do l = 1, minmn
+
+ k = minmn - l + 1
+
+ wa(k:m) = q(k:m,k)
+
+ q(k:m,k) = 0.0D+00
+ q(k,k) = 1.0D+00
+
+ if ( wa(k) /= 0.0D+00 ) then
+
+ do j = k, m
+ temp = dot_product ( wa(k:m), q(k:m,j) ) / wa(k)
+ q(k:m,j) = q(k:m,j) - temp * wa(k:m)
+ end do
+
+ end if
+
+ end do
+
+ return
+end
+subroutine qrfac ( m, n, a, lda, pivot, ipvt, lipvt, rdiag, acnorm )
+
+!*****************************************************************************80
+!
+!! QRFAC computes a QR factorization using Householder transformations.
+!
+! Discussion:
+!
+! This subroutine uses Householder transformations with column
+! pivoting (optional) to compute a QR factorization of the
+! M by N matrix A. That is, QRFAC determines an orthogonal
+! matrix Q, a permutation matrix P, and an upper trapezoidal
+! matrix R with diagonal elements of nonincreasing magnitude,
+! such that A*P = Q*R. The Householder transformation for
+! column K, K = 1,2,...,min(M,N), is of the form
+!
+! I - ( 1 / U(K) ) * U * U'
+!
+! where U has zeros in the first K-1 positions. The form of
+! this transformation and the method of pivoting first
+! appeared in the corresponding LINPACK subroutine.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, integer ( kind = 4 ) M, the number of rows of A.
+!
+! Input, integer ( kind = 4 ) N, the number of columns of A.
+!
+! Input/output, real ( kind = 8 ) A(LDA,N), the M by N array.
+! On input, A contains the matrix for which the QR factorization is to
+! be computed. On output, the strict upper trapezoidal part of A contains
+! the strict upper trapezoidal part of R, and the lower trapezoidal
+! part of A contains a factored form of Q (the non-trivial elements of
+! the U vectors described above).
+!
+! Input, integer ( kind = 4 ) LDA, the leading dimension of A, which must
+! be no less than M.
+!
+! Input, logical PIVOT, is TRUE if column pivoting is to be carried out.
+!
+! Output, integer ( kind = 4 ) IPVT(LIPVT), defines the permutation matrix P
+! such that A*P = Q*R. Column J of P is column IPVT(J) of the identity
+! matrix. If PIVOT is false, IPVT is not referenced.
+!
+! Input, integer ( kind = 4 ) LIPVT, the dimension of IPVT, which should
+! be N if pivoting is used.
+!
+! Output, real ( kind = 8 ) RDIAG(N), contains the diagonal elements of R.
+!
+! Output, real ( kind = 8 ) ACNORM(N), the norms of the corresponding
+! columns of the input matrix A. If this information is not needed,
+! then ACNORM can coincide with RDIAG.
+!
+ implicit none
+
+ integer ( kind = 4 ) lda
+ integer ( kind = 4 ) lipvt
+ integer ( kind = 4 ) m
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) a(lda,n)
+ real ( kind = 8 ) acnorm(n)
+ real ( kind = 8 ) ajnorm
+ real ( kind = 8 ) enorm
+ real ( kind = 8 ) epsmch
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) i4_temp
+ integer ( kind = 4 ) ipvt(lipvt)
+ integer ( kind = 4 ) j
+ integer ( kind = 4 ) k
+ integer ( kind = 4 ) kmax
+ integer ( kind = 4 ) minmn
+ logical pivot
+ real ( kind = 8 ) r8_temp(m)
+ real ( kind = 8 ) rdiag(n)
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) wa(n)
+
+ epsmch = epsilon ( epsmch )
+!
+! Compute the initial column norms and initialize several arrays.
+!
+ do j = 1, n
+ acnorm(j) = enorm ( m, a(1:m,j) )
+ end do
+
+ rdiag(1:n) = acnorm(1:n)
+ wa(1:n) = acnorm(1:n)
+
+ if ( pivot ) then
+ do j = 1, n
+ ipvt(j) = j
+ end do
+ end if
+!
+! Reduce A to R with Householder transformations.
+!
+ minmn = min ( m, n )
+
+ do j = 1, minmn
+!
+! Bring the column of largest norm into the pivot position.
+!
+ if ( pivot ) then
+
+ kmax = j
+
+ do k = j, n
+ if ( rdiag(kmax) < rdiag(k) ) then
+ kmax = k
+ end if
+ end do
+
+ if ( kmax /= j ) then
+
+ r8_temp(1:m) = a(1:m,j)
+ a(1:m,j) = a(1:m,kmax)
+ a(1:m,kmax) = r8_temp(1:m)
+
+ rdiag(kmax) = rdiag(j)
+ wa(kmax) = wa(j)
+
+ i4_temp = ipvt(j)
+ ipvt(j) = ipvt(kmax)
+ ipvt(kmax) = i4_temp
+
+ end if
+
+ end if
+!
+! Compute the Householder transformation to reduce the
+! J-th column of A to a multiple of the J-th unit vector.
+!
+ ajnorm = enorm ( m-j+1, a(j,j) )
+
+ if ( ajnorm /= 0.0D+00 ) then
+
+ if ( a(j,j) < 0.0D+00 ) then
+ ajnorm = -ajnorm
+ end if
+
+ a(j:m,j) = a(j:m,j) / ajnorm
+ a(j,j) = a(j,j) + 1.0D+00
+!
+! Apply the transformation to the remaining columns and update the norms.
+!
+ do k = j + 1, n
+
+ temp = dot_product ( a(j:m,j), a(j:m,k) ) / a(j,j)
+
+ a(j:m,k) = a(j:m,k) - temp * a(j:m,j)
+
+ if ( pivot .and. rdiag(k) /= 0.0D+00 ) then
+
+ temp = a(j,k) / rdiag(k)
+ rdiag(k) = rdiag(k) * sqrt ( max ( 0.0D+00, 1.0D+00-temp ** 2 ) )
+
+ if ( 0.05D+00 * ( rdiag(k) / wa(k) ) ** 2 <= epsmch ) then
+ rdiag(k) = enorm ( m-j, a(j+1,k) )
+ wa(k) = rdiag(k)
+ end if
+
+ end if
+
+ end do
+
+ end if
+
+ rdiag(j) = - ajnorm
+
+ end do
+
+ return
+end
+subroutine qrsolv ( n, r, ldr, ipvt, diag, qtb, x, sdiag )
+
+!*****************************************************************************80
+!
+!! QRSOLV solves a rectangular linear system A*x=b in the least squares sense.
+!
+! Discussion:
+!
+! Given an M by N matrix A, an N by N diagonal matrix D,
+! and an M-vector B, the problem is to determine an X which
+! solves the system
+!
+! A*X = B
+! D*X = 0
+!
+! in the least squares sense.
+!
+! This subroutine completes the solution of the problem
+! if it is provided with the necessary information from the
+! QR factorization, with column pivoting, of A. That is, if
+! Q*P = Q*R, where P is a permutation matrix, Q has orthogonal
+! columns, and R is an upper triangular matrix with diagonal
+! elements of nonincreasing magnitude, then QRSOLV expects
+! the full upper triangle of R, the permutation matrix p,
+! and the first N components of Q'*B.
+!
+! The system is then equivalent to
+!
+! R*Z = Q'*B
+! P'*D*P*Z = 0
+!
+! where X = P*Z. If this system does not have full rank,
+! then a least squares solution is obtained. On output QRSOLV
+! also provides an upper triangular matrix S such that
+!
+! P'*(A'*A + D*D)*P = S'*S.
+!
+! S is computed within QRSOLV and may be of separate interest.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, integer ( kind = 4 ) N, the order of R.
+!
+! Input/output, real ( kind = 8 ) R(LDR,N), the N by N matrix.
+! On input the full upper triangle must contain the full upper triangle
+! of the matrix R. On output the full upper triangle is unaltered, and
+! the strict lower triangle contains the strict upper triangle
+! (transposed) of the upper triangular matrix S.
+!
+! Input, integer ( kind = 4 ) LDR, the leading dimension of R, which must be
+! at least N.
+!
+! Input, integer ( kind = 4 ) IPVT(N), defines the permutation matrix P such
+! that A*P = Q*R. Column J of P is column IPVT(J) of the identity matrix.
+!
+! Input, real ( kind = 8 ) DIAG(N), the diagonal elements of the matrix D.
+!
+! Input, real ( kind = 8 ) QTB(N), the first N elements of the vector Q'*B.
+!
+! Output, real ( kind = 8 ) X(N), the least squares solution.
+!
+! Output, real ( kind = 8 ) SDIAG(N), the diagonal elements of the upper
+! triangular matrix S.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldr
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) c
+ real ( kind = 8 ) cotan
+ real ( kind = 8 ) diag(n)
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) ipvt(n)
+ integer ( kind = 4 ) j
+ integer ( kind = 4 ) k
+ integer ( kind = 4 ) l
+ integer ( kind = 4 ) nsing
+ real ( kind = 8 ) qtb(n)
+ real ( kind = 8 ) qtbpj
+ real ( kind = 8 ) r(ldr,n)
+ real ( kind = 8 ) s
+ real ( kind = 8 ) sdiag(n)
+ real ( kind = 8 ) sum2
+ real ( kind = 8 ) t
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) wa(n)
+ real ( kind = 8 ) x(n)
+!
+! Copy R and Q'*B to preserve input and initialize S.
+!
+! In particular, save the diagonal elements of R in X.
+!
+ do j = 1, n
+ r(j:n,j) = r(j,j:n)
+ x(j) = r(j,j)
+ end do
+
+ wa(1:n) = qtb(1:n)
+!
+! Eliminate the diagonal matrix D using a Givens rotation.
+!
+ do j = 1, n
+!
+! Prepare the row of D to be eliminated, locating the
+! diagonal element using P from the QR factorization.
+!
+ l = ipvt(j)
+
+ if ( diag(l) /= 0.0D+00 ) then
+
+ sdiag(j:n) = 0.0D+00
+ sdiag(j) = diag(l)
+!
+! The transformations to eliminate the row of D
+! modify only a single element of Q'*B
+! beyond the first N, which is initially zero.
+!
+ qtbpj = 0.0D+00
+
+ do k = j, n
+!
+! Determine a Givens rotation which eliminates the
+! appropriate element in the current row of D.
+!
+ if ( sdiag(k) /= 0.0D+00 ) then
+
+ if ( abs ( r(k,k) ) < abs ( sdiag(k) ) ) then
+ cotan = r(k,k) / sdiag(k)
+ s = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * cotan ** 2 )
+ c = s * cotan
+ else
+ t = sdiag(k) / r(k,k)
+ c = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * t ** 2 )
+ s = c * t
+ end if
+!
+! Compute the modified diagonal element of R and
+! the modified element of (Q'*B,0).
+!
+ r(k,k) = c * r(k,k) + s * sdiag(k)
+ temp = c * wa(k) + s * qtbpj
+ qtbpj = - s * wa(k) + c * qtbpj
+ wa(k) = temp
+!
+! Accumulate the tranformation in the row of S.
+!
+ do i = k+1, n
+ temp = c * r(i,k) + s * sdiag(i)
+ sdiag(i) = - s * r(i,k) + c * sdiag(i)
+ r(i,k) = temp
+ end do
+
+ end if
+
+ end do
+
+ end if
+!
+! Store the diagonal element of S and restore
+! the corresponding diagonal element of R.
+!
+ sdiag(j) = r(j,j)
+ r(j,j) = x(j)
+
+ end do
+!
+! Solve the triangular system for Z. If the system is
+! singular, then obtain a least squares solution.
+!
+ nsing = n
+
+ do j = 1, n
+
+ if ( sdiag(j) == 0.0D+00 .and. nsing == n ) then
+ nsing = j - 1
+ end if
+
+ if ( nsing < n ) then
+ wa(j) = 0.0D+00
+ end if
+
+ end do
+
+ do j = nsing, 1, -1
+ sum2 = dot_product ( wa(j+1:nsing), r(j+1:nsing,j) )
+ wa(j) = ( wa(j) - sum2 ) / sdiag(j)
+ end do
+!
+! Permute the components of Z back to components of X.
+!
+ do j = 1, n
+ l = ipvt(j)
+ x(l) = wa(j)
+ end do
+
+ return
+end
+subroutine r1mpyq ( m, n, a, lda, v, w )
+
+!*****************************************************************************80
+!
+!! R1MPYQ computes A*Q, where Q is the product of Householder transformations.
+!
+! Discussion:
+!
+! Given an M by N matrix A, this subroutine computes A*Q where
+! Q is the product of 2*(N - 1) transformations
+!
+! GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
+!
+! and GV(I), GW(I) are Givens rotations in the (I,N) plane which
+! eliminate elements in the I-th and N-th planes, respectively.
+! Q itself is not given, rather the information to recover the
+! GV, GW rotations is supplied.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, integer ( kind = 4 ) M, the number of rows of A.
+!
+! Input, integer ( kind = 4 ) N, the number of columns of A.
+!
+! Input/output, real ( kind = 8 ) A(LDA,N), the M by N array.
+! On input, the matrix A to be postmultiplied by the orthogonal matrix Q.
+! On output, the value of A*Q.
+!
+! Input, integer ( kind = 4 ) LDA, the leading dimension of A, which must not
+! be less than M.
+!
+! Input, real ( kind = 8 ) V(N), W(N), contain the information necessary
+! to recover the Givens rotations GV and GW.
+!
+ implicit none
+
+ integer ( kind = 4 ) lda
+ integer ( kind = 4 ) m
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) a(lda,n)
+ real ( kind = 8 ) c
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) j
+ real ( kind = 8 ) s
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) v(n)
+ real ( kind = 8 ) w(n)
+!
+! Apply the first set of Givens rotations to A.
+!
+ do j = n - 1, 1, -1
+
+ if ( 1.0D+00 < abs ( v(j) ) ) then
+ c = 1.0D+00 / v(j)
+ s = sqrt ( 1.0D+00 - c ** 2 )
+ else
+ s = v(j)
+ c = sqrt ( 1.0D+00 - s ** 2 )
+ end if
+
+ do i = 1, m
+ temp = c * a(i,j) - s * a(i,n)
+ a(i,n) = s * a(i,j) + c * a(i,n)
+ a(i,j) = temp
+ end do
+
+ end do
+!
+! Apply the second set of Givens rotations to A.
+!
+ do j = 1, n - 1
+
+ if ( abs ( w(j) ) > 1.0D+00 ) then
+ c = 1.0D+00 / w(j)
+ s = sqrt ( 1.0D+00 - c ** 2 )
+ else
+ s = w(j)
+ c = sqrt ( 1.0D+00 - s ** 2 )
+ end if
+
+ do i = 1, m
+ temp = c * a(i,j) + s * a(i,n)
+ a(i,n) = - s * a(i,j) + c * a(i,n)
+ a(i,j) = temp
+ end do
+
+ end do
+
+ return
+end
+subroutine r1updt ( m, n, s, ls, u, v, w, sing )
+
+!*****************************************************************************80
+!
+!! R1UPDT re-triangularizes a matrix after a rank one update.
+!
+! Discussion:
+!
+! Given an M by N lower trapezoidal matrix S, an M-vector U, and an
+! N-vector V, the problem is to determine an orthogonal matrix Q such that
+!
+! (S + U * V' ) * Q
+!
+! is again lower trapezoidal.
+!
+! This subroutine determines Q as the product of 2 * (N - 1)
+! transformations
+!
+! GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
+!
+! where GV(I), GW(I) are Givens rotations in the (I,N) plane
+! which eliminate elements in the I-th and N-th planes,
+! respectively. Q itself is not accumulated, rather the
+! information to recover the GV and GW rotations is returned.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, integer ( kind = 4 ) M, the number of rows of S.
+!
+! Input, integer ( kind = 4 ) N, the number of columns of S.
+! N must not exceed M.
+!
+! Input/output, real ( kind = 8 ) S(LS). On input, the lower trapezoidal
+! matrix S stored by columns. On output S contains the lower trapezoidal
+! matrix produced as described above.
+!
+! Input, integer ( kind = 4 ) LS, the length of the S array. LS must be at
+! least (N*(2*M-N+1))/2.
+!
+! Input, real ( kind = 8 ) U(M), the U vector.
+!
+! Input/output, real ( kind = 8 ) V(N). On input, V must contain the
+! vector V. On output V contains the information necessary to recover the
+! Givens rotations GV described above.
+!
+! Output, real ( kind = 8 ) W(M), contains information necessary to
+! recover the Givens rotations GW described above.
+!
+! Output, logical SING, is set to TRUE if any of the diagonal elements
+! of the output S are zero. Otherwise SING is set FALSE.
+!
+ implicit none
+
+ integer ( kind = 4 ) ls
+ integer ( kind = 4 ) m
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) cos
+ real ( kind = 8 ) cotan
+ real ( kind = 8 ) giant
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) j
+ integer ( kind = 4 ) jj
+ integer ( kind = 4 ) l
+ real ( kind = 8 ) s(ls)
+ real ( kind = 8 ) sin
+ logical sing
+ real ( kind = 8 ) tan
+ real ( kind = 8 ) tau
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) u(m)
+ real ( kind = 8 ) v(n)
+ real ( kind = 8 ) w(m)
+!
+! GIANT is the largest magnitude.
+!
+ giant = huge ( giant )
+!
+! Initialize the diagonal element pointer.
+!
+ jj = ( n * ( 2 * m - n + 1 ) ) / 2 - ( m - n )
+!
+! Move the nontrivial part of the last column of S into W.
+!
+ l = jj
+ do i = n, m
+ w(i) = s(l)
+ l = l + 1
+ end do
+!
+! Rotate the vector V into a multiple of the N-th unit vector
+! in such a way that a spike is introduced into W.
+!
+ do j = n - 1, 1, -1
+
+ jj = jj - ( m - j + 1 )
+ w(j) = 0.0D+00
+
+ if ( v(j) /= 0.0D+00 ) then
+!
+! Determine a Givens rotation which eliminates the
+! J-th element of V.
+!
+ if ( abs ( v(n) ) < abs ( v(j) ) ) then
+ cotan = v(n) / v(j)
+ sin = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * cotan ** 2 )
+ cos = sin * cotan
+ tau = 1.0D+00
+ if ( abs ( cos ) * giant > 1.0D+00 ) then
+ tau = 1.0D+00 / cos
+ end if
+ else
+ tan = v(j) / v(n)
+ cos = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * tan ** 2 )
+ sin = cos * tan
+ tau = sin
+ end if
+!
+! Apply the transformation to V and store the information
+! necessary to recover the Givens rotation.
+!
+ v(n) = sin * v(j) + cos * v(n)
+ v(j) = tau
+!
+! Apply the transformation to S and extend the spike in W.
+!
+ l = jj
+ do i = j, m
+ temp = cos * s(l) - sin * w(i)
+ w(i) = sin * s(l) + cos * w(i)
+ s(l) = temp
+ l = l + 1
+ end do
+
+ end if
+
+ end do
+!
+! Add the spike from the rank 1 update to W.
+!
+ w(1:m) = w(1:m) + v(n) * u(1:m)
+!
+! Eliminate the spike.
+!
+ sing = .false.
+
+ do j = 1, n-1
+
+ if ( w(j) /= 0.0D+00 ) then
+!
+! Determine a Givens rotation which eliminates the
+! J-th element of the spike.
+!
+ if ( abs ( s(jj) ) < abs ( w(j) ) ) then
+
+ cotan = s(jj) / w(j)
+ sin = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * cotan ** 2 )
+ cos = sin * cotan
+
+ if ( 1.0D+00 < abs ( cos ) * giant ) then
+ tau = 1.0D+00 / cos
+ else
+ tau = 1.0D+00
+ end if
+
+ else
+
+ tan = w(j) / s(jj)
+ cos = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * tan ** 2 )
+ sin = cos * tan
+ tau = sin
+
+ end if
+!
+! Apply the transformation to S and reduce the spike in W.
+!
+ l = jj
+ do i = j, m
+ temp = cos * s(l) + sin * w(i)
+ w(i) = - sin * s(l) + cos * w(i)
+ s(l) = temp
+ l = l + 1
+ end do
+!
+! Store the information necessary to recover the Givens rotation.
+!
+ w(j) = tau
+
+ end if
+!
+! Test for zero diagonal elements in the output S.
+!
+ if ( s(jj) == 0.0D+00 ) then
+ sing = .true.
+ end if
+
+ jj = jj + ( m - j + 1 )
+
+ end do
+!
+! Move W back into the last column of the output S.
+!
+ l = jj
+ do i = n, m
+ s(l) = w(i)
+ l = l + 1
+ end do
+
+ if ( s(jj) == 0.0D+00 ) then
+ sing = .true.
+ end if
+
+ return
+end
+subroutine r8vec_print ( n, a, title )
+
+!*****************************************************************************80
+!
+!! R8VEC_PRINT prints an R8VEC.
+!
+! Discussion:
+!
+! An R8VEC is a vector of R8's.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 22 August 2000
+!
+! Author:
+!
+! John Burkardt
+!
+! Parameters:
+!
+! Input, integer ( kind = 4 ) N, the number of components of the vector.
+!
+! Input, real ( kind = 8 ) A(N), the vector to be printed.
+!
+! Input, character ( len = * ) TITLE, a title.
+!
+ implicit none
+
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) a(n)
+ integer ( kind = 4 ) i
+ character ( len = * ) title
+
+ write ( *, '(a)' ) ' '
+ write ( *, '(a)' ) trim ( title )
+ write ( *, '(a)' ) ' '
+ do i = 1, n
+ write ( *, '(2x,i8,2x,g16.8)' ) i, a(i)
+ end do
+
+ return
+end
+subroutine rwupdt ( n, r, ldr, w, b, alpha, c, s )
+
+!*****************************************************************************80
+!
+!! RWUPDT computes the decomposition of triangular matrix augmented by one row.
+!
+! Discussion:
+!
+! Given an N by N upper triangular matrix R, this subroutine
+! computes the QR decomposition of the matrix formed when a row
+! is added to R. If the row is specified by the vector W, then
+! RWUPDT determines an orthogonal matrix Q such that when the
+! N+1 by N matrix composed of R augmented by W is premultiplied
+! by Q', the resulting matrix is upper trapezoidal.
+! The matrix Q' is the product of N transformations
+!
+! G(N)*G(N-1)* ... *G(1)
+!
+! where G(I) is a Givens rotation in the (I,N+1) plane which eliminates
+! elements in the (N+1)-st plane. RWUPDT also computes the product
+! Q'*C where C is the (N+1)-vector (B,ALPHA). Q itself is not
+! accumulated, rather the information to recover the G rotations is
+! supplied.
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 06 April 2010
+!
+! Author:
+!
+! Original FORTRAN77 version by Jorge More, Burton Garbow, Kenneth Hillstrom.
+! FORTRAN90 version by John Burkardt.
+!
+! Reference:
+!
+! Jorge More, Burton Garbow, Kenneth Hillstrom,
+! User Guide for MINPACK-1,
+! Technical Report ANL-80-74,
+! Argonne National Laboratory, 1980.
+!
+! Parameters:
+!
+! Input, integer ( kind = 4 ) N, the order of R.
+!
+! Input/output, real ( kind = 8 ) R(LDR,N). On input the upper triangular
+! part of R must contain the matrix to be updated. On output R contains the
+! updated triangular matrix.
+!
+! Input, integer ( kind = 4 ) LDR, the leading dimension of the array R.
+! LDR must not be less than N.
+!
+! Input, real ( kind = 8 ) W(N), the row vector to be added to R.
+!
+! Input/output, real ( kind = 8 ) B(N). On input, the first N elements
+! of the vector C. On output the first N elements of the vector Q'*C.
+!
+! Input/output, real ( kind = 8 ) ALPHA. On input, the (N+1)-st element
+! of the vector C. On output the (N+1)-st element of the vector Q'*C.
+!
+! Output, real ( kind = 8 ) C(N), S(N), the cosines and sines of the
+! transforming Givens rotations.
+!
+ implicit none
+
+ integer ( kind = 4 ) ldr
+ integer ( kind = 4 ) n
+
+ real ( kind = 8 ) alpha
+ real ( kind = 8 ) b(n)
+ real ( kind = 8 ) c(n)
+ real ( kind = 8 ) cotan
+ integer ( kind = 4 ) i
+ integer ( kind = 4 ) j
+ real ( kind = 8 ) r(ldr,n)
+ real ( kind = 8 ) rowj
+ real ( kind = 8 ) s(n)
+ real ( kind = 8 ) tan
+ real ( kind = 8 ) temp
+ real ( kind = 8 ) w(n)
+
+ do j = 1, n
+
+ rowj = w(j)
+!
+! Apply the previous transformations to R(I,J), I=1,2,...,J-1, and to W(J).
+!
+ do i = 1, j - 1
+ temp = c(i) * r(i,j) + s(i) * rowj
+ rowj = - s(i) * r(i,j) + c(i) * rowj
+ r(i,j) = temp
+ end do
+!
+! Determine a Givens rotation which eliminates W(J).
+!
+ c(j) = 1.0D+00
+ s(j) = 0.0D+00
+
+ if ( rowj /= 0.0D+00 ) then
+
+ if ( abs ( r(j,j) ) < abs ( rowj ) ) then
+ cotan = r(j,j) / rowj
+ s(j) = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * cotan ** 2 )
+ c(j) = s(j) * cotan
+ else
+ tan = rowj / r(j,j)
+ c(j) = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * tan ** 2 )
+ s(j) = c(j) * tan
+ end if
+!
+! Apply the current transformation to R(J,J), B(J), and ALPHA.
+!
+ r(j,j) = c(j) * r(j,j) + s(j) * rowj
+ temp = c(j) * b(j) + s(j) * alpha
+ alpha = - s(j) * b(j) + c(j) * alpha
+ b(j) = temp
+
+ end if
+
+ end do
+
+ return
+end
+subroutine timestamp ( )
+
+!*****************************************************************************80
+!
+!! TIMESTAMP prints the current YMDHMS date as a time stamp.
+!
+! Example:
+!
+! 31 May 2001 9:45:54.872 AM
+!
+! Licensing:
+!
+! This code is distributed under the GNU LGPL license.
+!
+! Modified:
+!
+! 18 May 2013
+!
+! Author:
+!
+! John Burkardt
+!
+! Parameters:
+!
+! None
+!
+ implicit none
+
+ character ( len = 8 ) ampm
+ integer ( kind = 4 ) d
+ integer ( kind = 4 ) h
+ integer ( kind = 4 ) m
+ integer ( kind = 4 ) mm
+ character ( len = 9 ), parameter, dimension(12) :: month = (/ &
+ 'January ', 'February ', 'March ', 'April ', &
+ 'May ', 'June ', 'July ', 'August ', &
+ 'September', 'October ', 'November ', 'December ' /)
+ integer ( kind = 4 ) n
+ integer ( kind = 4 ) s
+ integer ( kind = 4 ) values(8)
+ integer ( kind = 4 ) y
+
+ call date_and_time ( values = values )
+
+ y = values(1)
+ m = values(2)
+ d = values(3)
+ h = values(5)
+ n = values(6)
+ s = values(7)
+ mm = values(8)
+
+ if ( h < 12 ) then
+ ampm = 'AM'
+ else if ( h == 12 ) then
+ if ( n == 0 .and. s == 0 ) then
+ ampm = 'Noon'
+ else
+ ampm = 'PM'
+ end if
+ else
+ h = h - 12
+ if ( h < 12 ) then
+ ampm = 'PM'
+ else if ( h == 12 ) then
+ if ( n == 0 .and. s == 0 ) then
+ ampm = 'Midnight'
+ else
+ ampm = 'AM'
+ end if
+ end if
+ end if
+
+ write ( *, '(i2.2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
+ d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )
+
+ return
+end
diff --git a/src/MNH/modd_nsv.f90 b/src/MNH/modd_nsv.f90
index 50e18d615472d2eed88be9656218996d6b2c0f08..eab6ea740770e30d0c56b4f848ac34e7d527be7b 100644
--- a/src/MNH/modd_nsv.f90
+++ b/src/MNH/modd_nsv.f90
@@ -29,6 +29,8 @@
!! Modification 01/2016 (JP Pinty) Add LIMA
!! V. Vionnet 07/17 add blowing snow
! P. Wautelet 10/03/2021: add CSVNAMES and CSVNAMES_A to store the name of all the scalar variables
+!! B. Vie 06/2021 Add prognostic supersaturation for LIMA
+!!
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
@@ -133,6 +135,7 @@ INTEGER,DIMENSION(JPMODELMAX)::NSV_LIMA_IFN_FREE_A = 0 ! First Free IFN conc.
INTEGER,DIMENSION(JPMODELMAX)::NSV_LIMA_IFN_NUCL_A = 0 ! First Nucl. IFN conc.
INTEGER,DIMENSION(JPMODELMAX)::NSV_LIMA_IMM_NUCL_A = 0 ! First Nucl. IMM conc.
INTEGER,DIMENSION(JPMODELMAX)::NSV_LIMA_HOM_HAZE_A = 0 ! Hom. freezing of CCN
+INTEGER,DIMENSION(JPMODELMAX)::NSV_LIMA_SPRO_A = 0 ! Supersaturation
!
#ifdef MNH_FOREFIRE
INTEGER,DIMENSION(JPMODELMAX)::NSV_FF_A = 0 ! number of ForeFire scalar variables
@@ -235,6 +238,7 @@ INTEGER :: NSV_LIMA_IFN_FREE !
INTEGER :: NSV_LIMA_IFN_NUCL !
INTEGER :: NSV_LIMA_IMM_NUCL !
INTEGER :: NSV_LIMA_HOM_HAZE !
+INTEGER :: NSV_LIMA_SPRO !
!
#ifdef MNH_FOREFIRE
INTEGER :: NSV_FF = 0 ! number of ForeFire scalar variables
diff --git a/src/MNH/modd_param_lima.f90 b/src/MNH/modd_param_lima.f90
index 6245699483a7465fafd690f360a99197229a0ef6..29904f2d9188424aba61393f310ca2a651648ee5 100644
--- a/src/MNH/modd_param_lima.f90
+++ b/src/MNH/modd_param_lima.f90
@@ -126,6 +126,8 @@ LOGICAL, SAVE :: LBOUND ! TRUE to enable the continuously replenishing
! lateral boundaries -> boundaries.f90
LOGICAL, SAVE :: LDEPOC ! Deposition of rc at 1st level above ground
LOGICAL, SAVE :: LACTTKE ! TRUE to take into account TKE in W for activation
+LOGICAL, SAVE :: LADJ ! TRUE for adjustment procedure + Smax (false for diagnostic supersaturation)
+LOGICAL, SAVE :: LSPRO ! TRUE for prognostic supersaturation
!
! 2.2 CCN initialisation
!
@@ -151,7 +153,7 @@ REAL,SAVE :: XALPHAR,XNUR, & ! Raindrop distribution parameters
!
CHARACTER(LEN=3),SAVE :: HPARAM_CCN = 'CPB' ! Parameterization of the CCN activation
CHARACTER(LEN=3),SAVE :: HINI_CCN ! Initialization type of CCN activation
-CHARACTER(LEN=1),DIMENSION(JPLIMACCNMAX),SAVE :: HTYPE_CCN ! 'M' or 'C' CCN type
+CHARACTER(LEN=10),DIMENSION(JPLIMACCNMAX),SAVE :: HTYPE_CCN ! 'M' or 'C' CCN type
REAL,SAVE :: XFSOLUB_CCN, & ! Fractionnal solubility of the CCN
XACTEMP_CCN, & ! Expected temperature of CCN activation
XAERDIFF, XAERHEIGHT ! For the vertical gradient of aerosol distribution
diff --git a/src/MNH/modd_param_lima_warm.f90 b/src/MNH/modd_param_lima_warm.f90
index 4d20c978934e33e1e4f0d8251f4c86a8062f5e8e..65a3d10279364cb382048f19ed657c7eca2d2c39 100644
--- a/src/MNH/modd_param_lima_warm.f90
+++ b/src/MNH/modd_param_lima_warm.f90
@@ -36,12 +36,12 @@ REAL,SAVE :: XAR,XBR,XCR,XDR,XF0R,XF1R, & ! Raindrop charact.
XAC,XBC,XCC,XDC,XF0C,XF2C,XC1C ! Cloud droplet charact.
!
!
-CHARACTER(LEN=JPSVNAMELGTMAX),DIMENSION(4),PARAMETER &
- :: CLIMA_WARM_NAMES=(/'CCLOUD ','CRAIN ','CCCNFREE','CCCNACTI'/)
+CHARACTER(LEN=JPSVNAMELGTMAX),DIMENSION(5),PARAMETER &
+ :: CLIMA_WARM_NAMES=(/'CCLOUD ','CRAIN ','CCCNFREE','CCCNACTI','SPRO '/)
! basenames of the SV articles stored
! in the binary files
-CHARACTER(LEN=JPSVNAMELGTMAX),DIMENSION(4),PARAMETER &
- :: CLIMA_WARM_CONC=(/'NC ','NR ','NFREE','NCCN '/)
+CHARACTER(LEN=JPSVNAMELGTMAX),DIMENSION(5),PARAMETER &
+ :: CLIMA_WARM_CONC=(/'NC ','NR ','NFREE','NCCN ','SS '/)
! ! basenames of the SV articles stored
! ! in the binary files for DIAG
!
@@ -76,7 +76,7 @@ INTEGER, SAVE :: NAHEN ! Number of value of the AHEN
REAL,SAVE :: XAHENINTP1, XAHENINTP2 ! Factors defining the
! temperatures in lin scale
REAL, DIMENSION(:), SAVE, ALLOCATABLE & !
- :: XAHENG,XPSI1, XPSI3, & ! Twomey-CPB98 and
+ :: XAHENG,XAHENG2,XAHENG3,XPSI1, XPSI3, & ! Twomey-CPB98 and
XAHENF,XAHENY ! Feingold-Heymsfield
! parameterization to compute Smax
REAL,SAVE :: XWCOEF_F1, XWCOEF_F2, XWCOEF_F3, & ! COEF_F of the polynomial temp.
diff --git a/src/MNH/modn_param_lima.f90 b/src/MNH/modn_param_lima.f90
index 0b3c41d5e4495c8839490c3f29dea7521ef67ef9..d718ddd1c0625a125608dca962c6b27118b0b71d 100644
--- a/src/MNH/modn_param_lima.f90
+++ b/src/MNH/modn_param_lima.f90
@@ -19,7 +19,8 @@ NAMELIST/NAM_PARAM_LIMA/LCOLD, LNUCL, LSEDI, LSNOW, LHAIL, LHHONI, LMEYERS,&
XALPHAI, XNUI, XALPHAS, XNUS, XALPHAG, XNUG, &
XFACTNUC_DEP, XFACTNUC_CON, NPHILLIPS, &
!
- LWARM, LACTI, LRAIN, LSEDC, LACTIT, LBOUND, &
+ LWARM, LACTI, LRAIN, LSEDC, LACTIT, LBOUND, LSPRO, &
+ LADJ, &
NMOD_CCN, XCCN_CONC, &
LCCN_HOM, CCCN_MODES, HINI_CCN, HTYPE_CCN, &
XALPHAC, XNUC, XALPHAR, XNUR, &
diff --git a/src/MNH/open_prc_files.f90 b/src/MNH/open_prc_files.f90
index bb02f6951579522024fcc1b29da9240a08de5a83..b1f8b1f9ed5186e1d581c319e3bc2d1cd7877f4c 100644
--- a/src/MNH/open_prc_files.f90
+++ b/src/MNH/open_prc_files.f90
@@ -11,7 +11,8 @@ INTERFACE
SUBROUTINE OPEN_PRC_FILES(TPPRE_REAL1FILE,HATMFILE,HATMFILETYPE,TPATMFILE, &
HCHEMFILE,HCHEMFILETYPE, &
HSURFFILE,HSURFFILETYPE, &
- HPGDFILE,TPPGDFILE)
+ HPGDFILE,TPPGDFILE, &
+ HCAMSFILE,HCAMSFILETYPE)
!
USE MODD_IO, ONLY: TFILEDATA
!
@@ -25,7 +26,8 @@ CHARACTER(LEN=28), INTENT(OUT) :: HSURFFILE ! name of the input surface file
CHARACTER(LEN=6), INTENT(OUT) :: HSURFFILETYPE! type of the input surface file
CHARACTER(LEN=28), INTENT(OUT) :: HPGDFILE ! name of the physiographic data file
TYPE(TFILEDATA),POINTER, INTENT(OUT) :: TPPGDFILE ! physiographic data file
-!
+CHARACTER(LEN=28), INTENT(OUT) :: HCAMSFILE ! name of the input CAMS file
+CHARACTER(LEN=6), INTENT(OUT) :: HCAMSFILETYPE! type of the input CAMS file
END SUBROUTINE OPEN_PRC_FILES
END INTERFACE
END MODULE MODI_OPEN_PRC_FILES
@@ -34,7 +36,8 @@ END MODULE MODI_OPEN_PRC_FILES
SUBROUTINE OPEN_PRC_FILES(TPPRE_REAL1FILE,HATMFILE,HATMFILETYPE,TPATMFILE, &
HCHEMFILE,HCHEMFILETYPE, &
HSURFFILE,HSURFFILETYPE, &
- HPGDFILE,TPPGDFILE)
+ HPGDFILE,TPPGDFILE, &
+ HCAMSFILE,HCAMSFILETYPE)
! ###############################################################
!
!!**** *OPEN_PRC_FILES* - openning of the files used in PREP_REAL_CASE
@@ -95,6 +98,7 @@ END MODULE MODI_OPEN_PRC_FILES
! P. Wautelet 07/02/2019: remove OPARALLELIO argument from open and close files subroutines
! (nsubfiles_ioz is now determined in IO_File_add2list)
! P. Wautelet 14/02/2019: remove CLUOUT/CLUOUT0 and associated variables
+!! B. Vie 06/2021 LIMA - CAMS coupling
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
@@ -136,6 +140,8 @@ CHARACTER(LEN=28), INTENT(OUT) :: HSURFFILE ! name of the input surface file
CHARACTER(LEN=6), INTENT(OUT) :: HSURFFILETYPE! type of the input surface file
CHARACTER(LEN=28), INTENT(OUT) :: HPGDFILE ! name of the physiographic data file
TYPE(TFILEDATA),POINTER, INTENT(OUT) :: TPPGDFILE ! physiographic data file
+CHARACTER(LEN=28), INTENT(OUT) :: HCAMSFILE ! name of the input CAMS file
+CHARACTER(LEN=6), INTENT(OUT) :: HCAMSFILETYPE! type of the input CAMS file
!
!* 0.2 Declaration of local variables
! ------------------------------
@@ -153,7 +159,8 @@ CHARACTER(LEN=28) :: CINIFILE ! re-declaration of this model variable for nameli
! ------------------------
!
NAMELIST/NAM_FILE_NAMES/ HATMFILE,HATMFILETYPE,HCHEMFILE,HCHEMFILETYPE, &
- HSURFFILE,HSURFFILETYPE,HPGDFILE,CINIFILE
+ HSURFFILE,HSURFFILETYPE,HPGDFILE,CINIFILE, &
+ HCAMSFILE,HCAMSFILETYPE
!-------------------------------------------------------------------------------
!
!* 1. SET DEFAULT NAMES
@@ -165,6 +172,8 @@ HCHEMFILE=' '
HCHEMFILETYPE='MESONH'
HSURFFILE=' '
HSURFFILETYPE='MESONH'
+HCAMSFILE=' '
+HCAMSFILETYPE='MESONH'
!
!-------------------------------------------------------------------------------
!
@@ -235,6 +244,15 @@ IF (LEN_TRIM(HCHEMFILE)>0 .AND. HATMFILETYPE/='GRIBEX') THEN
END IF
WRITE(ILUOUT0,*) 'HCHEMFILE=', HCHEMFILE
!
+ILEN = LEN_TRIM(HCAMSFILE)
+IF (ILEN>0) THEN
+ YFILE=' '
+ YFILE(1:ILEN) = HCAMSFILE(1:ILEN)
+ HCAMSFILE = ' '
+ HCAMSFILE(1:ILEN) = YFILE(1:ILEN)
+END IF
+WRITE(ILUOUT0,*) 'HCAMSFILE=', HCAMSFILE
+!
ILEN = LEN_TRIM(HSURFFILE)
IF (ILEN>0) THEN
YFILE=' '
diff --git a/src/MNH/prep_real_case.f90 b/src/MNH/prep_real_case.f90
index d60b32e48fc9308e97812251a8dcf5029ddbc07d..acb406fe3191d207c45da1f62814efb42e355981 100644
--- a/src/MNH/prep_real_case.f90
+++ b/src/MNH/prep_real_case.f90
@@ -374,6 +374,12 @@
!! Aug 2015 (M.Moge) removing EXTRAPOL on XDXX and XDYY in part 8
!! J.Escobar : 15/09/2015 : WENO5 & JPHEXT <> 1
!! M.Leriche 2015 : add LUSECHEM dans NAM_CH_CONF
+!! Feb 02, 2012 (C. Mari & BV) interpolation from CAMS
+!! add call to READ_CAMS_NETCDF_CASE &
+!! VER_PREP_NETCDF_CASE
+!! Modification 01/2016 (JP Pinty) Add LIMA
+!! Modification 02/2016 (JP Pinty) Convert CAMS mix ratio to nbr conc
+!
!! 06/2016 (G.Delautier) phasage surfex 8
!! P.Wautelet : 08/07/2016 : removed MNH_NCWRIT define
!! B.VIE 2016 : LIMA
@@ -446,6 +452,7 @@ USE MODI_ERROR_ON_TEMPERATURE
USE MODI_IBM_INIT_LS
USE MODI_INI_PROG_VAR
USE MODI_INIT_SALT
+USE MODI_LIMA_MIXRAT_TO_NCONC
USE MODI_METRICS
USE MODI_MNHREAD_ZS_DUMMY_n
USE MODI_MNHWRITE_ZS_DUMMY_n
@@ -455,6 +462,7 @@ USE MODI_PRESSURE_IN_PREP
USE MODI_READ_ALL_DATA_GRIB_CASE
USE MODI_READ_ALL_DATA_MESONH_CASE
USE MODI_READ_ALL_NAMELISTS
+USE MODI_READ_CAMS_DATA_NETCDF_CASE
USE MODI_READ_CHEM_DATA_NETCDF_CASE
USE MODI_READ_VER_GRID
USE MODI_SECOND_MNH
@@ -471,6 +479,7 @@ USE MODI_WRITE_LFIFM_n
!
USE MODN_CONF, ONLY: JPHEXT , NHALO
USE MODN_CONFZ
+USE MODN_PARAM_LIMA
!
IMPLICIT NONE
!
@@ -481,6 +490,8 @@ CHARACTER(LEN=28) :: YATMFILE ! name of the Atmospheric file
CHARACTER(LEN=6) :: YATMFILETYPE! type of the Atmospheric file
CHARACTER(LEN=28) :: YCHEMFILE ! name of the Chemical file
CHARACTER(LEN=6) :: YCHEMFILETYPE! type of the Chemical file
+CHARACTER(LEN=28) :: YCAMSFILE ! name of the input CAMS file
+CHARACTER(LEN=6) :: YCAMSFILETYPE! type of the input CAMS file
CHARACTER(LEN=28) :: YSURFFILE ! name of the Surface file
CHARACTER(LEN=6) :: YSURFFILETYPE! type of the Surface file
CHARACTER(LEN=28) :: YPGDFILE ! name of the physiographic data
@@ -581,7 +592,8 @@ CALL IO_Init()
CALL OPEN_PRC_FILES(TZPRE_REAL1FILE,YATMFILE, YATMFILETYPE,TZATMFILE &
,YCHEMFILE,YCHEMFILETYPE &
,YSURFFILE,YSURFFILETYPE &
- ,YPGDFILE,TPGDFILE)
+ ,YPGDFILE,TPGDFILE &
+ ,YCAMSFILE,YCAMSFILETYPE)
ILUOUT0 = TLUOUT0%NLU
TLUOUT => TLUOUT0
!
@@ -621,6 +633,8 @@ IPRE_REAL1 = TZPRE_REAL1FILE%NLU
CALL INIT_NMLVAR
CALL POSNAM(IPRE_REAL1,'NAM_REAL_CONF',GFOUND,ILUOUT0)
IF (GFOUND) READ(IPRE_REAL1,NAM_REAL_CONF)
+CALL POSNAM(IPRE_REAL1,'NAM_PARAM_LIMA',GFOUND,ILUOUT0)
+IF (GFOUND) READ(IPRE_REAL1,NAM_PARAM_LIMA)
!
CALL INI_FIELD_LIST(1)
!
@@ -757,6 +771,16 @@ IF(LEN_TRIM(YCHEMFILE)>0)THEN
CALL READ_CHEM_DATA_NETCDF_CASE(TZPRE_REAL1FILE,YCHEMFILE,TPGDFILE,ZHORI,NVERB,LDUMMY_REAL)
END IF
!
+!* 5.2 reading the input CAMS data
+!
+IF(LEN_TRIM(YCAMSFILE)>0)THEN
+ IF(YCAMSFILETYPE=='NETCDF') THEN
+ CALL READ_CAMS_DATA_NETCDF_CASE(TZPRE_REAL1FILE,YCAMSFILE,TPGDFILE,ZHORI,NVERB,LDUMMY_REAL)
+ ELSE
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','PREP_REAL_CASE','CANNOT READ CAMS GRIB FILES YET')
+ END IF
+END IF
+!
CALL IO_File_close(TZPRE_REAL1FILE)
!
CALL SECOND_MNH(ZTIME2)
@@ -895,7 +919,8 @@ END IF
IF (LEN_TRIM(YCHEMFILE)>0 .AND. YCHEMFILETYPE=='GRIBEX') THEN
CALL VER_PREP_GRIBEX_CASE('CHEM',ZDG)
END IF
-IF (LEN_TRIM(YCHEMFILE)>0 .AND. YCHEMFILETYPE=='NETCDF') THEN
+IF ((LEN_TRIM(YCHEMFILE)>0 .AND. YCHEMFILETYPE=='NETCDF') .OR. &
+ (LEN_TRIM(YCAMSFILE)>0 .AND. YCAMSFILETYPE=='NETCDF')) THEN
CALL VER_PREP_NETCDF_CASE(ZDG)
END IF
!
@@ -983,6 +1008,11 @@ IF(LEN_TRIM(YCHEMFILE)>0 .AND. YCHEMFILETYPE=='MESONH')THEN
LHORELAX_SVSLT = (NSV_SLT > 0)
LHORELAX_SVAER = (NSV_AER > 0)
ELSE
+!
+IF (LEN_TRIM(YCAMSFILE)>0 .AND. YCAMSFILETYPE=='NETCDF') THEN
+ CALL LIMA_MIXRAT_TO_NCONC(XPABST, XTHT, XRT(:,:,:,1), XSV_MX)
+END IF
+!
CALL INI_PROG_VAR(XTKE_MX,XSV_MX)
END IF
!
diff --git a/src/MNH/prep_surfex.f90 b/src/MNH/prep_surfex.f90
index 8493ac43da7fbc0362702f02ade48fdbd8ac639e..9fce74dc3528da980ec7708b68ae52491180aa60 100644
--- a/src/MNH/prep_surfex.f90
+++ b/src/MNH/prep_surfex.f90
@@ -27,6 +27,7 @@
!! 06/2016 (G.Delautier) phasage surfex 8
!! Philippe Wautelet: 05/2016-04/2018: new data structures and calls for I/O
! P. Wautelet 07/02/2019: force TYPE to a known value for IO_File_add2list
+!! 2021 B.Vie LIMA - CAMS coupling
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
@@ -67,6 +68,8 @@ CHARACTER(LEN=28) :: YATMFILE ! name of the Atmospheric file
CHARACTER(LEN=6) :: YATMFILETYPE ! type of the Atmospheric file
CHARACTER(LEN=28) :: YCHEMFILE ! name of the Chemical file (not used)
CHARACTER(LEN=6) :: YCHEMFILETYPE ! type of the Chemical file (not used)
+CHARACTER(LEN=28) :: YCAMSFILE ! name of the input CAMS file
+CHARACTER(LEN=6) :: YCAMSFILETYPE ! type of the input CAMS file
CHARACTER(LEN=28) :: YSURFFILE ! name of the Surface file (not used)
CHARACTER(LEN=6) :: YSURFFILETYPE ! type of the Surface file (not used)
CHARACTER(LEN=28) :: YPGDFILE ! name of the physiographic data
@@ -105,7 +108,8 @@ CALL IO_Init()
CALL OPEN_PRC_FILES(TZPRE_REAL1FILE,YATMFILE, YATMFILETYPE,TZATMFILE &
,YCHEMFILE,YCHEMFILETYPE &
,YSURFFILE,YSURFFILETYPE &
- ,YPGDFILE,TPGDFILE)
+ ,YPGDFILE,TPGDFILE &
+ ,YCAMSFILE,YCAMSFILETYPE)
ILUOUT0 = TLUOUT0%NLU
!
!-------------------------------------------------------------------------------
diff --git a/src/MNH/prognos_lima.f90 b/src/MNH/prognos_lima.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5f4c2d0c3158d58566bf797e559b33fc3ca3d164
--- /dev/null
+++ b/src/MNH/prognos_lima.f90
@@ -0,0 +1,391 @@
+!MNH_LIC Copyright 2012-2018 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.
+! #######################
+ MODULE MODI_PROGNOS_LIMA
+! #######################
+!
+INTERFACE
+!
+SUBROUTINE PROGNOS_LIMA(PTSTEP,PDZ,PLV,PCPH,PPRES,PRHOD,PRR,PTT,PRV,PRC,PS0,PNAS,PCCS,PNFS)
+!
+REAL, INTENT(IN) :: PTSTEP
+REAL, DIMENSION(:), INTENT(IN) :: PPRES
+REAL, DIMENSION(:), INTENT(IN) :: PDZ
+REAL, DIMENSION(:), INTENT(IN) :: PLV
+REAL, DIMENSION(:), INTENT(IN) :: PCPH
+REAL, DIMENSION(:), INTENT(IN) :: PRHOD
+REAL, DIMENSION(:), INTENT(IN) :: PRR
+REAL, DIMENSION(:), INTENT(INOUT) :: PTT ! PTHS
+REAL, DIMENSION(:), INTENT(INOUT) :: PRV ! PRVS
+REAL, DIMENSION(:), INTENT(INOUT) :: PRC ! PRCS
+REAL, DIMENSION(:), INTENT(INOUT) :: PS0 ! PSVS sursat source
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PNAS ! PSVS activated aerosols source
+REAL, DIMENSION(:), INTENT(INOUT) :: PCCS ! PSVS droplet concentration source
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PNFS ! PSVS free aerosol source
+!
+END SUBROUTINE PROGNOS_LIMA
+!
+END INTERFACE
+!
+END MODULE MODI_PROGNOS_LIMA
+!
+! ###################################################################################
+ SUBROUTINE PROGNOS_LIMA(PTSTEP,PDZ,PLV,PCPH,PPRES,PRHOD,PRR,PTT,PRV,PRC,PS0,PNAS,PCCS,PNFS)
+! ###################################################################################
+!
+!!**** * - compute pseudo-prognostic of supersaturation according to Thouron
+! et al. 2012
+!! PURPOSE
+!! -------
+!!
+!!** METHOD
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Thouron, O., J.-L. Brenguier, and F. Burnet, Supersaturation calculation
+!! in large eddy simulation models for prediction of the droplet number
+!! concentration, Geosci. Model Dev., 5, 761-772, 2012.
+!!
+!! AUTHOR
+!! ------
+!! 06/2021 B. Vie forked from prognos.f90
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+!
+USE MODD_CST
+USE MODD_PARAM_LIMA
+USE MODD_PARAM_LIMA_WARM
+!
+USE MODE_IO
+USE MODE_MSG
+!
+USE MODI_GAMMA
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of dummy arguments :
+!
+!
+!
+REAL, INTENT(IN) :: PTSTEP
+REAL, DIMENSION(:), INTENT(IN) :: PPRES
+REAL, DIMENSION(:), INTENT(IN) :: PDZ
+REAL, DIMENSION(:), INTENT(IN) :: PLV
+REAL, DIMENSION(:), INTENT(IN) :: PCPH
+REAL, DIMENSION(:), INTENT(IN) :: PRHOD
+REAL, DIMENSION(:), INTENT(IN) :: PRR
+REAL, DIMENSION(:), INTENT(INOUT) :: PTT ! PTHS
+REAL, DIMENSION(:), INTENT(INOUT) :: PRV ! PRVS
+REAL, DIMENSION(:), INTENT(INOUT) :: PRC ! PRCS
+REAL, DIMENSION(:), INTENT(INOUT) :: PS0 ! PSVS sursat source
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PNAS ! PSVS activated aerosols source
+REAL, DIMENSION(:), INTENT(INOUT) :: PCCS ! PSVS droplet concentration source
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PNFS ! PSVS free aerosol source
+!
+!
+!* 0.2 Declarations of local variables :
+!
+!
+REAL, DIMENSION(SIZE(PRHOD,1)) :: ZW1,ZW2,ZDZRC2,ZDZRC,ZCPH
+REAL, DIMENSION(SIZE(PRHOD,1)) :: ZA1,ZA2,ZB,ZC,ZG
+REAL, DIMENSION(SIZE(PRHOD,1)) :: ZLV,ZTT1,ZRT,ZTL,ZTT1_TEMP,ZTT2_TEMP
+REAL, DIMENSION(SIZE(PRHOD,1)) :: ZRMOY,ZRVSAT1,ZRVSAT2
+REAL, DIMENSION(SIZE(PRHOD,1)) :: ZVEC2 ! Work vectors forinterpolations
+INTEGER, DIMENSION(SIZE(PRHOD,1)):: IVEC2 ! Vectors of indices for interpolations
+INTEGER :: J1,J2,JMOD,INUCT,JL
+REAL,DIMENSION(SIZE(PS0,1)) ::MEM_PS0,ADJU2
+REAL::AER_RAD
+REAL, DIMENSION(SIZE(PRHOD,1)) :: ZFLAG_ACT !Flag for activation
+!
+INTEGER :: IRESP ! Return code of FM routines
+INTEGER :: ILUOUT ! Logical unit of output listing
+CHARACTER(LEN=100) :: YMSG
+!
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZCHEN_MULTI,ZTMP
+REAL, DIMENSION(:), ALLOCATABLE :: ZZW1, ZZW2, ZZW6, ZVEC1
+INTEGER, DIMENSION(:), ALLOCATABLE :: IVEC1 ! Vectors of indices for
+ ! interpolations
+
+!
+INUCT = SIZE(PTT,1)
+!
+!
+ ALLOCATE(ZZW1(INUCT))
+ ALLOCATE(ZZW2(INUCT))
+ ALLOCATE(ZZW6(INUCT))
+ ALLOCATE(ZCHEN_MULTI(INUCT,NMOD_CCN))
+ ALLOCATE(ZTMP(INUCT,NMOD_CCN))
+ ALLOCATE(ZVEC1(INUCT))
+ ALLOCATE(IVEC1(INUCT))
+!
+!
+ DO JL=1,INUCT
+ DO JMOD = 1,NMOD_CCN
+ ZCHEN_MULTI(JL,JMOD) = (PNFS(JL,JMOD)+PNAS(JL,JMOD))*PRHOD(JL) &
+ / XLIMIT_FACTOR(JMOD)
+ ENDDO
+ END DO
+!print*,'ZCHEN_MULTI=',MINVAL(ZCHEN_MULTI(:,1)), MAXVAL(ZCHEN_MULTI(:,1)), &
+! 'ZCHEN_MULTI(1,1)=',ZCHEN_MULTI(1,1)
+!
+!* . Compute the nucleus source
+! -----------------------------
+!
+!
+! Modified values for Beta and C (see in init_aerosol_properties) account for that
+!
+ WHERE ( PS0(:) > 0.)
+ ZVEC1(:) = MAX( 1.0001, MIN( REAL(NHYP)-0.0001, &
+ XHYPINTP1*LOG(PS0(:))+XHYPINTP2 ) )
+ IVEC1(:) = INT( ZVEC1(:) )
+ ZVEC1(:) = ZVEC1(:) - REAL( IVEC1(:) )
+ END WHERE
+!print*,'ZVEC1=',MINVAL(ZVEC1), MAXVAL(ZVEC1)
+ ZZW6(:) = 0. ! initialize the change of cloud droplet concentration
+!
+ ZTMP(:,:)=0.0
+!
+! Compute the concentration of activable aerosols for each mode
+! based on the supersaturation ( -> ZTMP )
+!
+ DO JMOD = 1, NMOD_CCN ! iteration on mode number
+ ZZW1(:) = 0.
+ !
+ WHERE( PS0(:)>0.0 )
+ ZZW1(:) = XHYPF12( IVEC1(:)+1,JMOD )* ZVEC1(:) & ! hypergeo function
+ - XHYPF12( IVEC1(:) ,JMOD )*(ZVEC1(:) - 1.0) ! XHYPF12 is tabulated
+ !
+ ZTMP(:,JMOD) = (ZCHEN_MULTI(:,JMOD)/PRHOD(:))*PS0(:)**XKHEN_MULTI(JMOD) &
+ *ZZW1(:)
+ ! ZTMP(:,JMOD) = (ZCHEN_MULTI(:,JMOD)/PRHOD(:))*100*PS0(:)**XKHEN_MULTI(JMOD) &
+ ENDWHERE
+!print*,'ZZW1=',MINVAL(ZZW1), MAXVAL(ZZW1)
+!print*,'ZTMP=',MINVAL(ZTMP), MAXVAL(ZTMP)
+ ENDDO
+!
+! Compute the concentration of aerosols activated at this time step
+! as the difference between ZTMP and the aerosols already activated at t-dt (ZZW1)
+!
+ DO JMOD = 1, NMOD_CCN ! iteration on mode number
+ ZZW2(:) = 0.
+ !
+! WHERE( SUM(ZTMP(:,:),DIM=2)*PTSTEP .GT. 15.E6/PRHOD(:) )
+ ZZW2(:) = MIN( PNFS(:,JMOD),MAX( ZTMP(:,JMOD)- PNAS(:,JMOD) , 0.0 ) )
+! ENDWHERE
+!print*,'ZTMP=',ZTMP(:,1)
+!print*,'PNAS=',PNAS(:,1)
+!print*,'PNFS=',PNFS(:,1)
+!print*,'ZZW2=',ZZW2(:)
+ !
+ !* update the concentration of activated CCN = Na
+ !
+ PNAS(:,JMOD) = (PNAS(:,JMOD) + ZZW2(:))
+ !
+ !* update the concentration of free CCN = Nf
+ !
+ PNFS(:,JMOD) = (PNFS(:,JMOD) - ZZW2(:))
+ !
+ !* prepare to update the cloud water concentration
+ !
+ ZZW6(:) = ZZW6(:) + ZZW2(:)
+!print*,'ZZW6=',MINVAL(ZZW6), MAXVAL(ZZW6)
+ ENDDO
+!
+!FLAG ACTIVE A TRUE (1.0) si on active pas
+ZFLAG_ACT(:)=0.0
+DO J2=1,SIZE(PRC,1)
+ IF (ZZW2(J2).EQ.0.0) THEN
+ ZFLAG_ACT(J2)=1.0
+ ENDIF
+!print*,'ZFLAG_ACT=',ZFLAG_ACT(J2)
+ENDDO
+!
+! Mean radius
+!minimum radius of cloud droplet
+AER_RAD=1.0E-6
+ZRMOY(:)=0.0
+DO J2=1,SIZE(PRC,1)
+ IF ((PRC(J2).NE.0.) .AND. (PCCS(J2).NE.0.)) THEN
+ ZRMOY(J2)=(MOMG(XALPHAC,XNUC,3.0)*4.0*XPI*PCCS(J2)*XRHOLW/&
+ (3.0*PRC(J2)*PRHOD(J2)))**(1.0/3.0)
+ ZRMOY(J2)=(PCCS(J2)*MOMG(XALPHAC,XNUC,1.0)/ZRMOY(J2))
+ ENDIF
+!ZRMOY(J2)=ZRMOY(J2)+(ZZW2(J2)*AER_RAD)
+ ZRMOY(J2)=ZRMOY(J2)+(ZZW6(J2)*AER_RAD)
+ENDDO
+ !print*,'prognos RMOY=',MINVAL(ZRMOY),MAXVAL(ZRMOY)
+!
+! PCCS(:) = ZZW6(:) * PTSTEP
+ PCCS(:) = PCCS(:) + ZZW6(:)
+ !print*,'prognos PCCS=',MINVAL(PCCS),MAXVAL(PCCS)
+!
+!CALCUL DE A1 => Estimation de (drs/dt)f
+!T(=Ã determiner) avant forcage; T'(=PTT) apres forcage
+!Calcul de ZTT1: calculé en inversant S0(T)jusqu'à T:
+! l'erreur faite sur cette inversion est supérieur à la précision
+! recherchée, on applique à rs(T') pour cxalculer le DT=T'-T qui
+! correspond à la variation rs(T')-rs(T). Permet de recuperer une valeur
+! correcte de DT et donc de determiner T comme T=T'-DT
+!ZRVSAT1=rs(T)
+!
+!print*,'prognos : PS0=',MINVAL(PS0),MAXVAL(PS0)
+ZRVSAT1(:)=PRV(:)/(PS0(:)+1.0)
+!ZTT1<--es(T) de rs(T)
+ZTT1_TEMP(:)=PPRES(:)*((((XMV / XMD)/ZRVSAT1(:))+1.0)**(-1D0))
+!ZTT1<--T de es(T)
+ZTT1_TEMP(:)=LOG(ZTT1_TEMP(:)/610.8)
+ZTT1_TEMP(:)=(31.25*ZTT1_TEMP(:) -17.5688*273.15)/(ZTT1_TEMP(:) - 17.5688)
+!es(T')
+ZW1(:)=EXP(XALPW-XBETAW/PTT(:)-XGAMW*LOG(PTT(:)))
+!ZRVSAT2=rs(T')
+ZRVSAT2(:)=(XMV / XMD)*ZW1(:)/(PPRES(:)-ZW1(:))
+!ZTT2<--es(T') de rs(T')
+ZTT2_TEMP(:)=PPRES(:)*((((XMV / XMD)/ZRVSAT2(:))+1.0)**(-1D0))
+!ZTT2<--T' de es(T')
+IF (MINVAL(ZTT2_TEMP).LT.0.0) THEN
+ WRITE(YMSG,*) 'ZTT2_TEMP',MINVAL(ZTT2_TEMP),MINLOC(ZTT2_TEMP)
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','PROGNOS_LIMA',YMSG)
+ENDIF
+!
+ZTT2_TEMP(:)=LOG(ZW1(:)/610.8)
+ZTT2_TEMP(:)=(31.25*ZTT2_TEMP(:) -17.5688*273.15)/(ZTT2_TEMP(:) - 17.5688)
+!ZTT1=T'-DT
+ZTT1(:)=PTT(:)-(ZTT2_TEMP(:)-ZTT1_TEMP(:))
+!Lv(T)
+ZLV(:) = XLVTT+(XCPV-XCL)*(ZTT1(:)-XTT)
+!
+ZA1(:)=-(((PS0(:)+1.0)**2.0)/PRV(:))*(ZRVSAT2(:)-(PRV(:)/(PS0(:)+1.0)))/PTSTEP
+!G
+ZG(:)= 1.0/(XRHOLW*((XRV*ZTT1(:)/(XDIVA*EXP(XALPW-(XBETAW/ZTT1(:))-(XGAMW*LOG(ZTT1(:)))))) &
++((ZLV(:)/(XTHCO*ZTT1(:)))*((ZLV(:)/(ZTT1(:)*XRV))-1.0))))
+!
+ZC(:)=4.0*XPI*(XRHOLW/PRHOD(:))*ZG(:)
+ZDZRC(:)=0.0
+ZDZRC(:)=ZC(:)*PS0(:)*ZRMOY(:)
+MEM_PS0(:)=PS0(:)
+!CALCUL DE B => Estimation de (drs/dT)ce
+!T(=PTT) avant condensation; T'(=Ã determiner) apres condensation
+!Lv(T),Cph(T)
+ZLV(:) = XLVTT+(XCPV-XCL)*(PTT(:)-XTT)
+ZCPH(:)= XCPD+XCPV*PRV(:)+XCL*(PRC(:)+PRR(:))
+!T'=T+(DT)ce
+ZTT1(:)=PTT(:)+(ZDZRC(:)*PTSTEP*ZLV(:)/ZCPH(:))
+!es(T')
+ZW1(:)=EXP(XALPW-XBETAW/PTT(:)-XGAMW*LOG(PTT(:)))
+!rs(T')
+ZW1(:)=(XMV / XMD)*ZW1(:)/(PPRES(:)-ZW1(:))
+!es(Tcond)
+ZW2(:)=EXP(XALPW-XBETAW/ZTT1(:)-XGAMW*LOG(ZTT1(:)))
+!rs(Tcond)
+ZW2(:)=(XMV / XMD)*ZW2(:)/(PPRES(:)-ZW2(:))
+!
+WHERE (ZTT1(:).NE.PTT(:))
+ ZB(:)=(ZLV(:)/ZCPH(:))*((ZW2(:)-ZW1(:))/(ZTT1(:)-PTT(:)))
+ELSEWHERE
+ ZB(:)=0.0
+ ZDZRC(:)=0.0
+ENDWHERE
+!Calcul de S+dS
+PS0(:)=PS0(:)+((ZA1(:)-(((ZB(:)*(PS0(:)+1.0)+1.0)*ZDZRC(:))/ZRVSAT1(:)))*PTSTEP)
+!
+!Ajustement tel que rv=(s+1)*rvs
+ZTL(:)=PTT(:)-(PLV(:)/PCPH(:))*PRC(:)
+ZRT(:)=PRC(:)+PRV(:)
+ZDZRC2(:)=PRC(:)
+DO J2=1,SIZE(ZDZRC,1)
+ IF ((ZDZRC(J2).NE.0.0).OR.(ZDZRC2(J2).NE.0.0)) THEN
+ DO J1=1,5
+ ZLV(J2) = XLVTT+(XCPV-XCL)*(PTT(J2)-XTT)
+ ZCPH(J2)=XCPD+XCPV*PRV(J2)+XCL*(PRC(J2)+PRR(J2))
+ ZW1(J2)=EXP(XALPW-XBETAW/PTT(J2)-XGAMW*LOG(PTT(J2)))
+ ZRVSAT1(J2)=(XMV / XMD)*ZW1(J2)/(PPRES(J2)-ZW1(J2))
+ PRV(J2)=MIN(ZRT(J2),(PS0(J2)+1.0)*ZRVSAT1(J2))
+ PRC(J2)=MAX(ZRT(J2)-PRV(J2),0.0)
+ PTT(J2)=0.5*PTT(J2)+0.5*(ZTL(J2)+(ZLV(J2)*PRC(J2)/ZCPH(J2)))
+ ENDDO
+ ZLV(J2) = XLVTT+(XCPV-XCL)*(PTT(J2)-XTT)
+ ZCPH(J2)=XCPD+XCPV*PRV(J2)+XCL*(PRC(J2)+PRR(J2))
+ PTT(J2)=ZTL(J2)+(ZLV(J2)*PRC(J2)/ZCPH(J2))
+ ENDIF
+ENDDO
+ADJU2(:)=0.0
+!
+!Correction dans les mailles où ds a été surestimée
+ZDZRC2(:)=PRC(:)-ZDZRC2(:)
+WHERE ((MEM_PS0(:).LE.0.0).AND.(PS0(:).GT.0.0).AND.(ZDZRC2(:).LT.0.0))
+ PS0(:)=0.0
+ ADJU2(:)=1.0
+ENDWHERE
+!
+WHERE ((MEM_PS0(:).GE.0.0).AND.(PS0(:).LT.0.0).AND.(ZDZRC2(:).GT.0.0))
+ PS0(:)=0.0
+ ADJU2(:)=1.0
+ENDWHERE
+!
+DO J2=1,SIZE(ADJU2,1)
+ IF (ADJU2(J2)==1) THEN
+ DO J1=1,5
+ ZLV(J2) = XLVTT+(XCPV-XCL)*(PTT(J2)-XTT)
+ ZCPH(J2)=XCPD+XCPV*PRV(J2)+XCL*(PRC(J2)+PRR(J2))
+ ZW1(J2)=EXP(XALPW-XBETAW/PTT(J2)-XGAMW*LOG(PTT(J2)))
+ ZRVSAT1(J2)=(XMV / XMD)*ZW1(J2)/(PPRES(J2)-ZW1(J2))
+ PRV(J2)=MIN(ZRT(J2),(PS0(J2)+1.0)*ZRVSAT1(J2))
+ PRC(J2)=MAX(ZRT(J2)-PRV(J2),0.0)
+ PTT(J2)=0.5*PTT(J2)+0.5*(ZTL(J2)+(ZLV(J2)*PRC(J2)/ZCPH(J2)))
+ ENDDO
+ ZLV(J2) = XLVTT+(XCPV-XCL)*(PTT(J2)-XTT)
+ ZCPH(J2)=XCPD+XCPV*PRV(J2)+XCL*(PRC(J2)+PRR(J2))
+ PTT(J2)=ZTL(J2)+(ZLV(J2)*PRC(J2)/ZCPH(J2))
+ ENDIF
+ENDDO
+!
+!Elimination de l'eau liquide dans les mailles où le rayon des gouttelettes est
+!inférieur à AER_RAD
+ZRMOY(:)=0.0
+DO J2=1,SIZE(PRC,1)
+ IF ((PRC(J2).NE.0.) .AND. (PCCS(J2).NE.0.)) THEN
+ ZRMOY(J2)=(MOMG(XALPHAC,XNUC,3.0)*4.0*XPI*PCCS(J2)*XRHOLW/&
+ (3.0*PRC(J2)*PRHOD(J2)))**(1.0/3.0)
+ ZRMOY(J2)=MOMG(XALPHAC,XNUC,1.0)/ZRMOY(J2)
+ IF ((ZFLAG_ACT(J2).EQ.1.0).AND.(MEM_PS0(J2).LT.0.0).AND.(ZRMOY(J2).LT.AER_RAD)) THEN
+ PTT(J2)=ZTL(J2)
+ PRV(J2)=ZRT(J2)
+ PRC(J2)=0.0
+ ENDIF
+ ENDIF
+ENDDO
+!
+!Calcul de S au regard de T et rv en fin de pas de temps
+ZW1=EXP(XALPW-XBETAW/PTT(:)-XGAMW*LOG(PTT(:)))
+ !rvsat
+ZRVSAT1(:)=(XMV / XMD)*ZW1(:)/(PPRES-ZW1(:))
+!
+WHERE (PRC(:)==0.0D0)
+ PS0(:)=(PRV(:)/ZRVSAT1(:))-1D0
+ENDWHERE
+!
+ DEALLOCATE(ZZW1,ZZW2,ZZW6,ZCHEN_MULTI,ZTMP,ZVEC1,IVEC1)
+!
+!
+CONTAINS
+!
+FUNCTION MOMG (PALPHA,PNU,PP) RESULT (PMOMG)
+USE MODI_GAMMA
+IMPLICIT NONE
+REAL :: PALPHA ! first shape parameter of the DIMENSIONnal distribution
+REAL :: PNU ! second shape parameter of the DIMENSIONnal distribution
+REAL :: PP ! order of the moment
+REAL :: PMOMG ! result: moment of order ZP
+PMOMG = GAMMA(PNU+PP/PALPHA)/GAMMA(PNU)
+!
+END FUNCTION MOMG
+!
+END SUBROUTINE PROGNOS_LIMA
diff --git a/src/MNH/read_cams_data_netcdf_case.f90 b/src/MNH/read_cams_data_netcdf_case.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7dab58538f927919093b9663135e3c29bd915410
--- /dev/null
+++ b/src/MNH/read_cams_data_netcdf_case.f90
@@ -0,0 +1,810 @@
+!MNH_LIC Copyright 2012-2021 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.
+!-----------------------------------------------------------------
+! ################################
+ MODULE MODI_READ_CAMS_DATA_NETCDF_CASE
+! #################################
+INTERFACE
+SUBROUTINE READ_CAMS_DATA_NETCDF_CASE(TPPRE_REAL1,HFILE,TPPGDFILE, &
+ PTIME_HORI,KVERB,ODUMMY_REAL )
+!
+USE MODD_IO, ONLY: TFILEDATA
+!
+TYPE(TFILEDATA),POINTER,INTENT(IN) :: TPPRE_REAL1 ! PRE_REAL1 file
+CHARACTER(LEN=28), INTENT(IN) :: HFILE ! name of the NETCDF file
+TYPE(TFILEDATA), INTENT(IN) :: TPPGDFILE ! physiographic data file
+REAL, INTENT(INOUT) :: PTIME_HORI ! time spent in hor. interpolations
+INTEGER, INTENT(IN) :: KVERB ! verbosity level
+LOGICAL, INTENT(IN) :: ODUMMY_REAL! flag to interpolate dummy fields
+END SUBROUTINE READ_CAMS_DATA_NETCDF_CASE
+!
+END INTERFACE
+END MODULE MODI_READ_CAMS_DATA_NETCDF_CASE
+! ####################################################################
+ SUBROUTINE READ_CAMS_DATA_NETCDF_CASE(TPPRE_REAL1,HFILE,TPPGDFILE, &
+ PTIME_HORI,KVERB,ODUMMY_REAL )
+! ####################################################################
+!
+!!**** *READ_CAMS_DATA_NETCDF_CASE* - reads data for the initialization of real cases.
+!!
+!! PURPOSE
+!! -------
+! This routine reads the two input files :
+! The PGD which is closed after reading
+! The NETCDF file
+! Projection is read in READ_LFIFM_PGD (MODD_GRID).
+! Grid and definition of large domain are read in PGD file and
+! NETCDF files.
+! The PGD files are also read in READ_LFIFM_PGD.
+! The PGD file is closed.
+! Vertical grid is defined in READ_VER_GRID.
+! PGD fields are stored on MESO-NH domain (in TRUNC_PGD).
+!!
+!!** METHOD
+!! ------
+!! 0. Declarations
+!! 1. Declaration of arguments
+!! 2. Declaration of local variables
+!! 1. Read PGD file
+!! 1. Domain restriction
+!! 2. Coordinate conversion to lat,lon system
+!! 2. Read Netcdf fields
+!! 3. Vertical grid
+!! 4. Free all temporary allocations
+!!
+!! EXTERNAL
+!! --------
+!! subroutine READ_LFIFM_PGD : to read PGD file
+!! subroutine READ_VER_GRID : to read the vertical grid in namelist file.
+!! subroutine HORIBL : horizontal bilinear interpolation
+!! subroutine XYTOLATLON : projection from conformal to lat,lon
+!!
+!! Module MODI_READ_VER_GRID : interface for subroutine READ_VER_GRID
+!! Module MODI_HORIBL : interface for subroutine HORIBL
+!! Module MODI_XYTOLATLON : interface for subroutine XYTOLATLON
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_CONF : contains configuration variables for all models.
+!! NVERB : verbosity level for output-listing
+!! Module MODD_LUNIT : contains logical unit names for all models
+!! TLUOUT0 : name of output-listing
+!! Module MODD_PGDDIM : contains dimension of PGD fields
+!! NPGDIMAX: dimension along x (no external point)
+!! NPGDJMAX: dimension along y (no external point)
+!! Module MODD_PARAMETERS
+!! JPHEXT
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/2021 forked from read_chem_data_netcdf_case.f90
+
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+!------------
+!
+USE MODD_CH_AEROSOL, ONLY: CORGANIC, NCARB, NSOA, NSP, LORILAM,&
+ JPMODE, LVARSIGI, LVARSIGJ,CAERONAMES
+USE MODD_CH_M9_n, ONLY: NEQ , CNAMES
+USE MODD_CH_MNHC_n, ONLY: LUSECHEM,LUSECHAQ,LUSECHIC,LCH_PH
+USE MODD_CONF
+USE MODD_CONF_n
+USE MODD_CST
+USE MODD_DIM_n
+USE MODD_GRID
+USE MODD_GRID_n
+USE MODD_IO, ONLY: TFILEDATA
+USE MODD_LUNIT, ONLY: TLUOUT0
+USE MODE_MODELN_HANDLER
+USE MODD_NETCDF, ONLY:CDFINT
+USE MODD_NSV
+USE MODD_PARAMETERS
+USE MODD_PARAM_n, ONLY : CTURB
+USE MODD_PRECISION, ONLY:CDFINT
+USE MODD_PREP_REAL
+USE MODD_TIME
+USE MODD_TIME_n
+!
+USE MODE_IO_FILE, only: IO_File_close
+USE MODE_MPPDB
+USE MODE_THERMO
+USE MODE_TIME
+USE MODE_TOOLS, ONLY: UPCASE
+use mode_tools_ll, only: GET_DIM_EXT_ll
+!
+USE MODI_CH_AER_INIT_SOA
+USE MODI_CH_INIT_SCHEME_n
+USE MODI_CH_OPEN_INPUT
+USE MODI_HORIBL
+USE MODI_INI_NSV
+USE MODI_READ_HGRID_n
+USE MODI_READ_VER_GRID
+USE MODI_XYTOLATLON
+!
+USE NETCDF
+!
+USE MODD_PARAM_n, ONLY : CCLOUD
+USE MODD_PARAM_LIMA, ONLY : NMOD_CCN, LSCAV, LAERO_MASS, HINI_CCN, HTYPE_CCN, &
+ NMOD_IFN, NMOD_IMM, LHHONI, NINDICE_CCN_IMM,CCCN_MODES,&
+ CIFN_SPECIES
+!
+IMPLICIT NONE
+!
+!* 0.1. Declaration of arguments
+! ------------------------
+!
+TYPE(TFILEDATA),POINTER,INTENT(IN) :: TPPRE_REAL1 ! PRE_REAL1 file
+CHARACTER(LEN=28), INTENT(IN) :: HFILE ! name of the NETCDF file
+TYPE(TFILEDATA), INTENT(IN) :: TPPGDFILE ! physiographic data file
+REAL, INTENT(INOUT) :: PTIME_HORI ! time spent in hor. interpolations
+INTEGER, INTENT(IN) :: KVERB ! verbosity level
+LOGICAL, INTENT(IN) :: ODUMMY_REAL! flag to interpolate dummy fields
+!
+!* 0.2 Declaration of local variables
+! ------------------------------
+! General purpose variables
+INTEGER :: ILUOUT0 ! Unit used for output msg.
+INTEGER :: JJ ! Dummy counters
+INTEGER :: JLOOP1
+! Variables used by the PGD reader
+CHARACTER(LEN=28) :: YPGD_NAME ! not used - dummy argument
+CHARACTER(LEN=28) :: YPGD_DAD_NAME ! not used - dummy argument
+CHARACTER(LEN=2) :: YPGD_TYPE ! not used - dummy argument
+! PGD Grib definition variables
+INTEGER :: INO ! Number of points of the grid
+INTEGER :: IIU ! Number of points along X
+INTEGER :: IJU ! Number of points along Y
+REAL, DIMENSION(:), ALLOCATABLE :: ZLONOUT ! mapping PGD -> Grib (lon.)
+REAL, DIMENSION(:), ALLOCATABLE :: ZLATOUT ! mapping PGD -> Grib (lat.)
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZXM ! X of PGD mass points
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZYM ! Y of PGD mass points
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZLATM ! Lat of PGD mass points
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZLONM ! Lon of PGD mass points
+INTEGER :: IMI
+!
+! For netcdf
+!
+integer(kind=CDFINT) :: istatus, incid
+integer(kind=CDFINT) :: ilatlen, ilonlen, ilevlen, inrecs
+integer(kind=CDFINT) :: itimeindex
+INTEGER(kind=CDFINT) :: ind_netcdf ! Indice for netcdf var.
+REAL, DIMENSION(:), ALLOCATABLE :: zlats
+REAL, DIMENSION(:), ALLOCATABLE :: zlons
+REAL, DIMENSION(:), ALLOCATABLE :: zlevs
+REAL, DIMENSION(:), ALLOCATABLE :: ztime
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: zmmr_dust1, zmmr_dust2, zmmr_dust3
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: zmmr_seasalt1, zmmr_seasalt2, zmmr_seasalt3
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: zmmr_bc_hydrophilic, zmmr_bc_hydrophobic
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: zmmr_oc_hydrophilic, zmmr_oc_hydrophobic
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: zmmr_sulfaer
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZWORK
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZTMOZ, ZQMOZ, ZPSMOZ
+REAL, DIMENSION(:), ALLOCATABLE :: ZTMP1, ZTMP2
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZTMP3
+REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: ZTMP4,ZTMP5
+!----------------------------------------------------------------------
+!
+IMI = GET_CURRENT_MODEL_INDEX()
+!
+!* 1. READ PGD FILE
+! -------------
+!
+ILUOUT0 = TLUOUT0%NLU
+CALL READ_HGRID_n(TPPGDFILE,YPGD_NAME,YPGD_DAD_NAME,YPGD_TYPE)
+!
+! 1.1 Domain restriction
+!
+CALL GET_DIM_EXT_ll('B',IIU,IJU)
+INO = IIU * IJU
+!
+!
+! 1.2 Coordinate conversion to lat,lon system
+!
+ALLOCATE (ZXM(IIU,IJU))
+ALLOCATE (ZYM(IIU,IJU))
+ALLOCATE (ZLONM(IIU,IJU))
+ALLOCATE (ZLATM(IIU,IJU))
+ZXM(1:IIU-1,1) = (XXHAT(1:IIU-1) + XXHAT(2:IIU) ) / 2.
+ZXM(IIU,1) = XXHAT(IIU) - XXHAT(IIU-1) + ZXM(IIU-1,1)
+ZXM(:,2:IJU) = SPREAD(ZXM(:,1),2,IJU-1)
+ZYM(1,1:IJU-1) = (XYHAT(1:IJU-1) + XYHAT(2:IJU)) / 2.
+ZYM(1,IJU) = XYHAT(IJU) - XYHAT(IJU-1) + ZYM(1,IJU-1)
+ZYM(2:IIU,:) = SPREAD(ZYM(1,:),1,IIU-1)
+CALL SM_XYTOLATLON_A (XLAT0,XLON0,XRPK,XLATORI,XLONORI,ZXM,ZYM,ZLATM,ZLONM, &
+ IIU,IJU)
+ALLOCATE (ZLONOUT(INO))
+ALLOCATE (ZLATOUT(INO))
+JLOOP1 = 0
+DO JJ = 1, IJU
+ ZLONOUT(JLOOP1+1:JLOOP1+IIU) = ZLONM(1:IIU,JJ)
+ ZLATOUT(JLOOP1+1:JLOOP1+IIU) = ZLATM(1:IIU,JJ)
+ JLOOP1 = JLOOP1 + IIU
+ENDDO
+DEALLOCATE (ZYM)
+DEALLOCATE (ZXM)
+DEALLOCATE (ZLONM)
+DEALLOCATE (ZLATM)
+!
+!
+!* 2. READ NETCDF FIELDS
+! ------------------
+!
+! 2.1 Open netcdf files
+!
+istatus = nf90_open(HFILE, nf90_nowrite, incid)
+if (istatus /= nf90_noerr) call handle_err(istatus)
+!
+! 2.2 Read netcdf files
+!
+! get dimensions
+!
+CALL READ_DIM(incid,"latitude",ilatlen)
+CALL READ_DIM(incid,"longitude",ilonlen)
+CALL READ_DIM(incid,"level",ilevlen)
+!
+! 2.3 Read data.
+!
+ALLOCATE (zlats(ilatlen))
+ALLOCATE (zlons(ilonlen))
+ALLOCATE (zlevs(ilevlen))
+ALLOCATE (ztime(inrecs))
+! T, Q, Ps :
+ALLOCATE (ZTMOZ(ilonlen,ilatlen,ilevlen))
+ALLOCATE (ZQMOZ(ilonlen,ilatlen,ilevlen))
+ALLOCATE (ZPSMOZ(ilonlen,ilatlen,ilevlen))
+! transformed a, b :
+ALLOCATE (XA_SV_LS(ilevlen))
+ALLOCATE (XB_SV_LS(ilevlen))
+!
+ALLOCATE (zmmr_dust1(ilonlen,ilatlen,ilevlen))
+ALLOCATE (zmmr_dust2(ilonlen,ilatlen,ilevlen))
+ALLOCATE (zmmr_dust3(ilonlen,ilatlen,ilevlen))
+!
+ALLOCATE (zmmr_seasalt1(ilonlen,ilatlen,ilevlen))
+ALLOCATE (zmmr_seasalt2(ilonlen,ilatlen,ilevlen))
+ALLOCATE (zmmr_seasalt3(ilonlen,ilatlen,ilevlen))
+!
+ALLOCATE (zmmr_bc_hydrophilic(ilonlen,ilatlen,ilevlen))
+ALLOCATE (zmmr_bc_hydrophobic(ilonlen,ilatlen,ilevlen))
+!
+ALLOCATE (zmmr_oc_hydrophilic(ilonlen,ilatlen,ilevlen))
+ALLOCATE (zmmr_oc_hydrophobic(ilonlen,ilatlen,ilevlen))
+!
+ALLOCATE (zmmr_sulfaer(ilonlen,ilatlen,ilevlen))
+!
+ALLOCATE (ZWORK(ilonlen,ilatlen,ilevlen))
+!
+! get values of variables
+!
+!
+! Reference pressure (needed for the vertical interpolation)
+!
+XP00_SV_LS = 101325.0
+!
+! a and b coefficients (needed for the vertical interpolation)
+!
+IF (ilevlen .eq. 60) THEN
+XA_SV_LS(:) = (/ 20.000000000, 38.425343000, 63.647804000, 95.636963000, 134.48330700, &
+ 180.58435100, 234.77905300, 298.49578900, 373.97192400, 464.61813400, &
+ 575.65100100, 713.21807900, 883.66052200, 1094.8347170, 1356.4746090, &
+ 1680.6402590, 2082.2739260, 2579.8886720, 3196.4216310, 3960.2915040, &
+ 4906.7084960, 6018.0195310, 7306.6313480, 8765.0537110, 10376.126953, &
+ 12077.446289, 13775.325195, 15379.805664, 16819.474609, 18045.183594, &
+ 19027.695313, 19755.109375, 20222.205078, 20429.863281, 20384.480469, &
+ 20097.402344, 19584.330078, 18864.750000, 17961.357422, 16899.468750, &
+ 15706.447266, 14411.124023, 13043.218750, 11632.758789, 10209.500977, &
+ 8802.3564450, 7438.8032230, 6144.3149410, 4941.7783200, 3850.9133300, &
+ 2887.6965330, 2063.7797850, 1385.9125980, 855.36175500, 467.33358800, &
+ 210.39389000, 65.889244000, 7.3677430000, 0.0000000000, 0.0000000000 /)
+
+XA_SV_LS(:) = XA_SV_LS(:) / XP00_SV_LS
+
+XB_SV_LS(:) = (/ 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, &
+ 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, &
+ 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, &
+ 0.00000000, 0.00000000, 0.00000000, 0.00000000, 0.00000000, &
+ 0.00000000, 0.00000000, 0.00000000, 0.00007582, 0.00046139, &
+ 0.00181516, 0.00508112, 0.01114291, 0.02067788, 0.03412116, &
+ 0.05169041, 0.07353383, 0.09967469, 0.13002251, 0.16438432, &
+ 0.20247594, 0.24393314, 0.28832296, 0.33515489, 0.38389215, &
+ 0.43396294, 0.48477158, 0.53570992, 0.58616841, 0.63554746, &
+ 0.68326861, 0.72878581, 0.77159661, 0.81125343, 0.84737492, &
+ 0.87965691, 0.90788388, 0.93194032, 0.95182151, 0.96764523, &
+ 0.97966272, 0.98827010, 0.99401945, 0.99763012, 1.00000000 /)
+
+ELSE IF (ilevlen .eq. 137) THEN
+
+XA_SV_LS(:) = (/ &
+2.000365 , 3.102241 , 4.666084 , 6.827977 , 9.746966 , 13.605424 , 18.608931 , 24.985718 , &
+32.985710 , 42.879242 , 54.955463 , 69.520576 , 86.895882 , 107.415741 , 131.425507 , 159.279404 , &
+191.338562 , 227.968948 , 269.539581 , 316.420746 , 368.982361 , 427.592499 , 492.616028 , 564.413452 , &
+643.339905 , 729.744141 , 823.967834 , 926.344910 , 1037.201172 , 1156.853638 , 1285.610352 , 1423.770142 , &
+1571.622925 , 1729.448975 , 1897.519287 , 2076.095947 , 2265.431641 , 2465.770508 , 2677.348145 , 2900.391357 , &
+3135.119385 , 3381.743652 , 3640.468262 , 3911.490479 , 4194.930664 , 4490.817383 , 4799.149414 , 5119.895020 , &
+5452.990723 , 5798.344727 , 6156.074219 , 6526.946777 , 6911.870605 , 7311.869141 , 7727.412109 , 8159.354004 , &
+8608.525391 , 9076.400391 , 9562.682617 , 10065.978516 , 10584.631836 , 11116.662109 , 11660.067383 , 12211.547852 , &
+12766.873047 , 13324.668945 , 13881.331055 , 14432.139648 , 14975.615234 , 15508.256836 , 16026.115234 , 16527.322266 , &
+17008.789063 , 17467.613281 , 17901.621094 , 18308.433594 , 18685.718750 , 19031.289063 , 19343.511719 , 19620.042969 , &
+19859.390625 , 20059.931641 , 20219.664063 , 20337.863281 , 20412.308594 , 20442.078125 , 20425.718750 , 20361.816406 , &
+20249.511719 , 20087.085938 , 19874.025391 , 19608.572266 , 19290.226563 , 18917.460938 , 18489.707031 , 18006.925781 , &
+17471.839844 , 16888.687500 , 16262.046875 , 15596.695313 , 14898.453125 , 14173.324219 , 13427.769531 , 12668.257813 , &
+11901.339844 , 11133.304688 , 10370.175781 , 9617.515625 , 8880.453125 , 8163.375000 , 7470.343750 , 6804.421875 , &
+6168.531250 , 5564.382813 , 4993.796875 , 4457.375000 , 3955.960938 , 3489.234375 , 3057.265625 , 2659.140625 , &
+2294.242188 , 1961.500000 , 1659.476563 , 1387.546875 , 1143.250000 , 926.507813 , 734.992188 , 568.062500 , &
+424.414063 , 302.476563 , 202.484375 , 122.101563 , 62.781250 , 22.835938 , 3.757813 , 0.000000 , 0.000000 /)
+
+XA_SV_LS(:) = XA_SV_LS(:) / XP00_SV_LS
+
+XB_SV_LS(:) = (/ &
+0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , &
+0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , &
+0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , &
+0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , &
+0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , &
+0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , &
+0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000000 , 0.000007 , 0.000024 , &
+0.000059 , 0.000112 , 0.000199 , 0.000340 , 0.000562 , 0.000890 , 0.001353 , 0.001992 , &
+0.002857 , 0.003971 , 0.005378 , 0.007133 , 0.009261 , 0.011806 , 0.014816 , 0.018318 , &
+0.022355 , 0.026964 , 0.032176 , 0.038026 , 0.044548 , 0.051773 , 0.059728 , 0.068448 , &
+0.077958 , 0.088286 , 0.099462 , 0.111505 , 0.124448 , 0.138313 , 0.153125 , 0.168910 , &
+0.185689 , 0.203491 , 0.222333 , 0.242244 , 0.263242 , 0.285354 , 0.308598 , 0.332939 , &
+0.358254 , 0.384363 , 0.411125 , 0.438391 , 0.466003 , 0.493800 , 0.521619 , 0.549301 , &
+0.576692 , 0.603648 , 0.630036 , 0.655736 , 0.680643 , 0.704669 , 0.727739 , 0.749797 , &
+0.770798 , 0.790717 , 0.809536 , 0.827256 , 0.843881 , 0.859432 , 0.873929 , 0.887408 , &
+0.899900 , 0.911448 , 0.922096 , 0.931881 , 0.940860 , 0.949064 , 0.956550 , 0.963352 , &
+0.969513 , 0.975078 , 0.980072 , 0.984542 , 0.988500 , 0.991984 , 0.995003 , 0.997630 , 1.000000 /)
+
+END IF
+
+CALL READ_VAR_1D(incid,"latitude",ilatlen,zlats)
+CALL READ_VAR_1D(incid,"longitude",ilonlen,zlons)
+CALL READ_VAR_1D(incid,"level",ilevlen,zlevs)
+
+CALL READ_VAR_2D(incid,"sp",ilonlen,ilatlen,ZPSMOZ)
+
+CALL READ_VAR_3D(incid,"t",ilonlen,ilatlen,ilevlen,ZTMOZ)
+CALL READ_VAR_3D(incid,"q",ilonlen,ilatlen,ilevlen,ZQMOZ)
+
+CALL READ_VAR_3D(incid,"aermr01",ilonlen,ilatlen,ilevlen,zmmr_seasalt1)
+CALL READ_VAR_3D(incid,"aermr02",ilonlen,ilatlen,ilevlen,zmmr_seasalt2)
+CALL READ_VAR_3D(incid,"aermr03",ilonlen,ilatlen,ilevlen,zmmr_seasalt3)
+CALL READ_VAR_3D(incid,"aermr04",ilonlen,ilatlen,ilevlen,zmmr_dust1)
+CALL READ_VAR_3D(incid,"aermr05",ilonlen,ilatlen,ilevlen,zmmr_dust2)
+CALL READ_VAR_3D(incid,"aermr06",ilonlen,ilatlen,ilevlen,zmmr_dust3)
+CALL READ_VAR_3D(incid,"aermr07",ilonlen,ilatlen,ilevlen,zmmr_oc_hydrophobic)
+CALL READ_VAR_3D(incid,"aermr08",ilonlen,ilatlen,ilevlen,zmmr_oc_hydrophilic)
+CALL READ_VAR_3D(incid,"aermr09",ilonlen,ilatlen,ilevlen,zmmr_bc_hydrophobic)
+CALL READ_VAR_3D(incid,"aermr10",ilonlen,ilatlen,ilevlen,zmmr_bc_hydrophilic)
+CALL READ_VAR_3D(incid,"aermr11",ilonlen,ilatlen,ilevlen,zmmr_sulfaer)
+!
+!------------------------------------------------------------------------
+!* 3 Conversion of CAMS variables into LIMA variables
+!---------------------------------------------------------------------
+!
+! initialise NSV_* variables
+! cas simple : 3 modes de CCN (dont 1 actif par immersion), 2 modes IFN
+! CCN1 : seasalt
+! CCN2 : sulfates
+! CCN3 (IMM) : hydrophilic OM and BC
+! IFN1 : dust
+! IFN2 : hydrophobic OM and BC
+!
+! XSV : Nc, Nr, 3 CCN free, 3 CCN activés, Ni, 2 IN free, 2 IN activé = 11 variables
+!
+! Concentrations en nombre par kilo !
+!
+!
+CCLOUD='LIMA'
+NMOD_CCN=3
+LSCAV=.FALSE.
+LAERO_MASS=.FALSE.
+NMOD_IFN=2
+NMOD_IMM=1
+LHHONI=.FALSE.
+HINI_CCN='AER'
+HTYPE_CCN(1)='M'
+HTYPE_CCN(2)='C'
+HTYPE_CCN(3)='C'
+CCCN_MODES='CAMS_AIT'
+CIFN_SPECIES='CAMS_AIT'
+!
+! Always initialize chemical scheme variables before INI_NSV call !
+!
+!CALL CH_INIT_SCHEME_n(IMI,LUSECHAQ,LUSECHIC,LCH_PH,ILUOUT0,KVERB)
+!LUSECHEM = .TRUE.
+!IF (LORILAM) THEN
+! CORGANIC = "MPMPO"
+! LVARSIGI = .TRUE.
+! LVARSIGJ = .TRUE.
+! CALL CH_AER_INIT_SOA(ILUOUT0, KVERB)
+!END IF
+!
+!
+!
+CALL INI_NSV(IMI)
+DEALLOCATE(XSV_LS)
+ALLOCATE (XSV_LS(IIU,IJU,ilevlen,NSV))
+XSV_LS(:,:,:,:) = 0.
+!
+ALLOCATE(NINDICE_CCN_IMM(1))
+NINDICE_CCN_IMM(1)=3
+!
+! Define work arrays
+!
+ALLOCATE (XPS_SV_LS(IIU,IJU))
+ALLOCATE (XZS_SV_LS(IIU,IJU))
+ALLOCATE (XT_SV_LS(IIU,IJU,ilevlen))
+ALLOCATE (XQ_SV_LS(IIU,IJU,ilevlen,NRR))
+XQ_SV_LS(:,:,:,2:)=0.000000000001
+!
+XZS_SV_LS(:,:) = XZS_LS(:,:) ! orography from the PGD file
+where (ZLONOUT(:) < 0.) ZLONOUT(:) = ZLONOUT(:) + 360. ! correct longitudes
+!
+!
+! Select CAMS mixing ratios
+! and perform the horizontal interpolation
+!
+! Free CCN concentration (mode 1)
+!
+ZWORK(:,:,:)=zmmr_seasalt1(:,:,:)+zmmr_seasalt2(:,:,:)+zmmr_seasalt3(:,:,:)
+CALL INTERP_3D (ilonlen,ilatlen,ilevlen,ZWORK,zlats,zlons,IIU,IJU,ZLATOUT,ZLONOUT,PTIME_HORI,XSV_LS(:,:,:,NSV_LIMA_CCN_FREE))
+!
+! Free CCN concentration (mode 2)
+!
+ZWORK(:,:,:)=zmmr_sulfaer(:,:,:)
+CALL INTERP_3D (ilonlen,ilatlen,ilevlen,ZWORK,zlats,zlons,IIU,IJU,ZLATOUT,ZLONOUT,PTIME_HORI,XSV_LS(:,:,:,NSV_LIMA_CCN_FREE + 1))
+!
+! Free CCN concentration (mode 3, IMM)
+!
+ZWORK(:,:,:)=zmmr_bc_hydrophilic(:,:,:)+zmmr_oc_hydrophilic(:,:,:)
+CALL INTERP_3D (ilonlen,ilatlen,ilevlen,ZWORK,zlats,zlons,IIU,IJU,ZLATOUT,ZLONOUT,PTIME_HORI,XSV_LS(:,:,:,NSV_LIMA_CCN_FREE + 2))
+!
+! Free IFN concentration (mode 1)
+!
+ZWORK(:,:,:)=zmmr_dust1(:,:,:) + zmmr_dust2(:,:,:) + zmmr_dust3(:,:,:)
+CALL INTERP_3D (ilonlen,ilatlen,ilevlen,ZWORK,zlats,zlons,IIU,IJU,ZLATOUT,ZLONOUT,PTIME_HORI,XSV_LS(:,:,:,NSV_LIMA_IFN_FREE))
+!
+! Free IFN concentration (mode 2)
+!
+ZWORK(:,:,:)=zmmr_bc_hydrophobic(:,:,:)+zmmr_oc_hydrophobic(:,:,:)
+CALL INTERP_3D (ilonlen,ilatlen,ilevlen,ZWORK,zlats,zlons,IIU,IJU,ZLATOUT,ZLONOUT,PTIME_HORI,XSV_LS(:,:,:,NSV_LIMA_IFN_FREE + 1))
+!
+! Temperature (needed for the vertical interpolation)
+!
+CALL INTERP_3D (ilonlen,ilatlen,ilevlen,ZTMOZ,zlats,zlons,IIU,IJU,ZLATOUT,ZLONOUT,PTIME_HORI,XT_SV_LS)
+!
+! Spec. Humidity (needed for the vertical interpolation)
+!
+CALL INTERP_3D (ilonlen,ilatlen,ilevlen,ZQMOZ,zlats,zlons,IIU,IJU,ZLATOUT,ZLONOUT,PTIME_HORI,XQ_SV_LS(:,:,:,1))
+!
+! Surface pressure (needed for the vertical interpolation)
+!
+CALL INTERP_2D (ilonlen,ilatlen,ZPSMOZ,zlats,zlons,IIU,IJU,ZLATOUT,ZLONOUT,PTIME_HORI,XPS_SV_LS)
+!
+! Correct negative values produced by the horizontal interpolations
+!
+XSV_LS(:,:,:,:) = MAX(XSV_LS(:,:,:,:),0.)
+XPS_SV_LS(:,:) = MAX(XPS_SV_LS(:,:),0.)
+XT_SV_LS(:,:,:) = MAX(XT_SV_LS(:,:,:),0.)
+XQ_SV_LS(:,:,:,1) = MAX(XQ_SV_LS(:,:,:,1),0.)
+!
+! If Netcdf vertical levels have to be reversed :
+!
+ALLOCATE(ZTMP1(ilevlen))
+ALLOCATE(ZTMP2(ilevlen))
+ALLOCATE(ZTMP3(IIU,IJU,ilevlen))
+ALLOCATE(ZTMP4(IIU,IJU,ilevlen,NRR))
+ALLOCATE(ZTMP5(IIU,IJU,ilevlen,NSV))
+DO JJ=1,ilevlen
+ ! inv. lev
+ ZTMP1(JJ) = XA_SV_LS(ilevlen+1-JJ)
+ ZTMP2(JJ) = XB_SV_LS(ilevlen+1-JJ)
+ ZTMP3(:,:,JJ) = XT_SV_LS(:,:,ilevlen+1-JJ)
+ ZTMP4(:,:,JJ,:) = XQ_SV_LS(:,:,ilevlen+1-JJ,:)
+ ZTMP5(:,:,JJ,:) = XSV_LS(:,:,ilevlen+1-JJ,:)
+ENDDO
+XA_SV_LS(:) = ZTMP1(:)
+XB_SV_LS(:) = ZTMP2(:)
+XT_SV_LS(:,:,:) = ZTMP3(:,:,:)
+XQ_SV_LS(:,:,:,:) = ZTMP4(:,:,:,:)
+XSV_LS(:,:,:,:) = ZTMP5(:,:,:,:)
+DEALLOCATE(ZTMP1)
+DEALLOCATE(ZTMP2)
+DEALLOCATE(ZTMP3)
+DEALLOCATE(ZTMP4)
+DEALLOCATE(ZTMP5)
+!
+! close the netcdf file
+istatus = nf90_close(incid)
+if (istatus /= nf90_noerr) call handle_err(istatus)
+!
+!-------------------------------------------------------------
+!
+!* 4. VERTICAL GRID
+!
+!* 4.1 Read VERTICAL GRID
+!
+WRITE (ILUOUT0,'(A)') ' | Reading of vertical grid in progress'
+CALL READ_VER_GRID(TPPRE_REAL1)
+!
+!--------------------------------------------------------------
+!
+!* Free all temporary allocations
+!
+DEALLOCATE (ZLATOUT)
+DEALLOCATE (ZLONOUT)
+!
+DEALLOCATE (zlats)
+DEALLOCATE (zlons)
+DEALLOCATE (zlevs)
+DEALLOCATE (ztime)
+! ps, T, Q :
+DEALLOCATE (ZPSMOZ)
+DEALLOCATE (ZTMOZ)
+DEALLOCATE (ZQMOZ)
+!
+DEALLOCATE (zmmr_dust1)
+DEALLOCATE (zmmr_dust2)
+DEALLOCATE (zmmr_dust3)
+!
+DEALLOCATE (zmmr_seasalt1)
+DEALLOCATE (zmmr_seasalt2)
+DEALLOCATE (zmmr_seasalt3)
+!
+DEALLOCATE (zmmr_bc_hydrophilic)
+DEALLOCATE (zmmr_bc_hydrophobic)
+!
+DEALLOCATE (zmmr_oc_hydrophilic)
+DEALLOCATE (zmmr_oc_hydrophobic)
+!
+DEALLOCATE (zmmr_sulfaer)
+!
+DEALLOCATE (ZWORK)
+!
+WRITE (ILUOUT0,'(A,A4,A)') ' -- netcdf decoder for ',HFILE,' file ended successfully'
+WRITE (ILUOUT0,'(A,A4,A)') 'CAMS mixing ratios are interpolated horizontally'
+!
+!
+CONTAINS
+!
+! #############################
+ subroutine handle_err(istatus)
+! #############################
+ use mode_msg
+
+ integer(kind=CDFINT) istatus
+
+ if ( istatus /= NF90_NOERR ) then
+ call Print_msg( NVERB_FATAL, 'IO', 'HANDLE_ERR', NF90_STRERROR(istatus) )
+ end if
+
+ end subroutine handle_err
+!
+!
+! #############################################
+ SUBROUTINE ARRAY_1D_TO_2D (KN1,P1,KL1,KL2,P2)
+! #############################################
+!
+! Small routine used to store a linear array into a 2 dimension array
+!
+USE MODE_MSG
+IMPLICIT NONE
+INTEGER, INTENT(IN) :: KN1
+REAL,DIMENSION(KN1), INTENT(IN) :: P1
+INTEGER, INTENT(IN) :: KL1
+INTEGER, INTENT(IN) :: KL2
+REAL,DIMENSION(KL1,KL2),INTENT(OUT) :: P2
+INTEGER :: JLOOP1_A1T2
+INTEGER :: JLOOP2_A1T2
+INTEGER :: JPOS_A1T2
+!
+IF (KN1 < KL1*KL2) THEN
+ CALL PRINT_MSG(NVERB_FATAL,'GEN','ARRAY_1D_TO_2D','sizes do not match')
+END IF
+JPOS_A1T2 = 1
+DO JLOOP2_A1T2 = 1, KL2
+ DO JLOOP1_A1T2 = 1, KL1
+ P2(JLOOP1_A1T2,JLOOP2_A1T2) = P1(JPOS_A1T2)
+ JPOS_A1T2 = JPOS_A1T2 + 1
+ END DO
+END DO
+END SUBROUTINE ARRAY_1D_TO_2D
+!
+! #############################################
+ SUBROUTINE READ_DIM (file,name,output)
+! #############################################
+!
+! Small routine used to store a linear array into a 2 dimension array
+!
+IMPLICIT NONE
+INTEGER(kind=CDFINT), INTENT(IN) :: file
+CHARACTER(*), INTENT(IN) :: name
+INTEGER(kind=CDFINT), INTENT(OUT) :: output
+!
+INTEGER(kind=CDFINT) :: istatus, index
+!
+istatus = nf90_inq_dimid(file, name, index)
+if (istatus /= nf90_noerr) call handle_err(istatus)
+istatus = nf90_inquire_dimension(file, index, len=output)
+if (istatus /= nf90_noerr) call handle_err(istatus)
+!
+END SUBROUTINE READ_DIM
+!
+! #############################################
+ SUBROUTINE READ_VAR_1D (file,name,size,output)
+! #############################################
+!
+! Small routine used to store a linear array into a 2 dimension array
+!
+IMPLICIT NONE
+INTEGER(kind=CDFINT), INTENT(IN) :: file
+CHARACTER(*), INTENT(IN) :: name
+INTEGER(kind=CDFINT), INTENT(IN) :: size
+REAL, DIMENSION(size), INTENT(INOUT) :: output
+!
+INTEGER(kind=CDFINT) :: istatus, index
+!
+istatus = nf90_inq_varid(file, name, index)
+if (istatus /= nf90_noerr) call handle_err(istatus)
+istatus = nf90_get_var(file, index, output)
+if (istatus /= nf90_noerr) call handle_err(istatus)
+!
+END SUBROUTINE READ_VAR_1D
+!
+! #############################################
+ SUBROUTINE READ_VAR_2D (file,name,size_lon,size_lat,output)
+! #############################################
+!
+! Small routine used to store a linear array into a 2 dimension array
+!
+IMPLICIT NONE
+INTEGER(kind=CDFINT), INTENT(IN) :: file
+CHARACTER(*), INTENT(IN) :: name
+INTEGER(kind=CDFINT), INTENT(IN) :: size_lon
+INTEGER(kind=CDFINT), INTENT(IN) :: size_lat
+REAL, DIMENSION(size_lon,size_lat), INTENT(INOUT) :: output
+!
+INTEGER(kind=CDFINT) :: istatus, index
+REAL :: scale, offset
+INTEGER,DIMENSION(4) :: s, c
+!
+s(:)=1
+c(1)=size_lon
+c(2)=size_lat
+c(3)=1
+c(4)=1
+istatus = nf90_inq_varid(file, name, index)
+if (istatus /= nf90_noerr) call handle_err(istatus)
+istatus = nf90_get_var(file, index, output)
+if (istatus /= nf90_noerr) call handle_err(istatus)
+istatus = nf90_get_att(file, index, "scale_factor", scale)
+istatus = nf90_get_att(file, index, "add_offset", offset)
+output = offset + scale * output
+!
+END SUBROUTINE READ_VAR_2D
+!
+! #############################################
+ SUBROUTINE READ_VAR_3D (file,name,size_lon,size_lat,size_lev,output)
+! #############################################
+!
+! Small routine used to store a linear array into a 2 dimension array
+!
+IMPLICIT NONE
+INTEGER(kind=CDFINT), INTENT(IN) :: file
+CHARACTER(*), INTENT(IN) :: name
+INTEGER(kind=CDFINT), INTENT(IN) :: size_lon
+INTEGER(kind=CDFINT), INTENT(IN) :: size_lat
+INTEGER(kind=CDFINT), INTENT(IN) :: size_lev
+REAL, DIMENSION(size_lon,size_lat,size_lev), INTENT(INOUT) :: output
+!
+INTEGER(kind=CDFINT) :: istatus, index
+REAL :: scale, offset
+INTEGER,DIMENSION(4) :: s, c
+!
+s(:)=1
+c(1)=size_lon
+c(2)=size_lat
+c(3)=size_lev
+c(4)=1
+istatus = nf90_inq_varid(file, name, index)
+if (istatus /= nf90_noerr) call handle_err(istatus)
+istatus = nf90_get_var(file, index, output,start=s,count=c)
+if (istatus /= nf90_noerr) call handle_err(istatus)
+istatus = nf90_get_att(file, index, "scale_factor", scale)
+istatus = nf90_get_att(file, index, "add_offset", offset)
+output = offset + scale * output
+!
+END SUBROUTINE READ_VAR_3D
+!
+! #############################################
+ SUBROUTINE INTERP_2D (size_lon,size_lat,input,zlats,zlons,IIU,IJU,PLATOUT,PLONOUT,PTIME_HORI,output)
+! #############################################
+!
+! Small routine used to store a linear array into a 2 dimension array
+!
+IMPLICIT NONE
+!
+INTEGER, INTENT(IN) :: size_lon
+INTEGER, INTENT(IN) :: size_lat
+REAL, DIMENSION(size_lon,size_lat), INTENT(IN) :: input
+REAL, DIMENSION(size_lat), INTENT(IN) :: zlats
+REAL, DIMENSION(size_lon), INTENT(IN) :: zlons
+INTEGER, INTENT(IN) :: IIU
+INTEGER, INTENT(IN) :: IJU
+REAL, DIMENSION(IIU*IJU), INTENT(IN) :: PLATOUT
+REAL, DIMENSION(IIU*IJU), INTENT(IN) :: PLONOUT
+REAL, INTENT(INOUT) :: PTIME_HORI
+REAL, DIMENSION(IIU,IJU), INTENT(INOUT) :: output
+!
+INTEGER :: JLOOP1, JJ, INO
+REAL, DIMENSION(size_lat*size_lon) :: ZVALUE
+REAL, DIMENSION(IIU*IJU) :: ZOUT
+INTEGER, DIMENSION(size_lat) :: kinlo
+INTEGER :: KILEN
+!
+kinlo(:)=size_lon
+KILEN=size_lat*size_lon
+INO=IIU*IJU
+JLOOP1 = 0
+DO JJ = 1, size_lat
+ ZVALUE(JLOOP1+1:JLOOP1+size_lon) = input(1:size_lon,JJ)
+ JLOOP1 = JLOOP1 + size_lon
+ENDDO
+CALL HORIBL(zlats(1),zlons(1),zlats(size_lat),zlons(size_lon), &
+ size_lat,kinlo,KILEN, &
+ ZVALUE(:),INO,PLONOUT,PLATOUT, &
+ ZOUT(:),.FALSE.,PTIME_HORI,.TRUE. )
+CALL ARRAY_1D_TO_2D(INO,ZOUT(:),IIU,IJU,output(:,:))
+!
+END SUBROUTINE INTERP_2D
+!
+! #############################################
+ SUBROUTINE INTERP_3D (size_lon,size_lat,size_lev,input,zlats,zlons,IIU,IJU,PLATOUT,PLONOUT,PTIME_HORI,output)
+! #############################################
+!
+! Small routine used to store a linear array into a 2 dimension array
+!
+IMPLICIT NONE
+!
+INTEGER, INTENT(IN) :: size_lon
+INTEGER, INTENT(IN) :: size_lat
+INTEGER, INTENT(IN) :: size_lev
+REAL, DIMENSION(size_lon,size_lat,size_lev), INTENT(IN) :: input
+REAL, DIMENSION(size_lat), INTENT(IN) :: zlats
+REAL, DIMENSION(size_lon), INTENT(IN) :: zlons
+INTEGER, INTENT(IN) :: IIU
+INTEGER, INTENT(IN) :: IJU
+REAL, DIMENSION(IIU*IJU), INTENT(IN) :: PLATOUT
+REAL, DIMENSION(IIU*IJU), INTENT(IN) :: PLONOUT
+REAL, INTENT(INOUT) :: PTIME_HORI
+REAL, DIMENSION(IIU,IJU,size_lev), INTENT(INOUT) :: output
+!
+INTEGER :: JLOOP1, JJ, JK, INO
+REAL, DIMENSION(size_lev,size_lat*size_lon) :: ZVALUE
+REAL, DIMENSION(size_lev,IIU*IJU) :: ZOUT
+INTEGER, DIMENSION(size_lat) :: kinlo
+INTEGER :: KILEN
+!
+kinlo(:)=size_lon
+KILEN=size_lat*size_lon
+INO=IIU*IJU
+DO JK = 1, ilevlen
+ JLOOP1 = 0
+ DO JJ = 1, size_lat
+ ZVALUE(JK,JLOOP1+1:JLOOP1+size_lon) = input(1:size_lon,JJ,JK)
+ JLOOP1 = JLOOP1 + size_lon
+ ENDDO
+ CALL HORIBL(zlats(1),zlons(1),zlats(size_lat),zlons(size_lon), &
+ size_lat,kinlo,KILEN, &
+ ZVALUE(JK,:),INO,PLONOUT,PLATOUT, &
+ ZOUT(JK,:),.FALSE.,PTIME_HORI,.TRUE. )
+ CALL ARRAY_1D_TO_2D(INO,ZOUT(JK,:),IIU,IJU,output(:,:,JK))
+ENDDO
+!
+END SUBROUTINE INTERP_3D
+!
+END SUBROUTINE READ_CAMS_DATA_NETCDF_CASE
diff --git a/src/MNH/read_exsegn.f90 b/src/MNH/read_exsegn.f90
index af4579ccace40b2827fe59bc5ef44c76970a15b3..fac8e124cf54aade5e49cabf6884fc7e2f4cdd4e 100644
--- a/src/MNH/read_exsegn.f90
+++ b/src/MNH/read_exsegn.f90
@@ -1257,15 +1257,15 @@ SELECT CASE ( CCLOUD )
LUSERH=LHAIL
END IF
!
- IF (LSUBG_COND .AND. LCOLD) THEN
- WRITE(UNIT=ILUOUT,FMT=9003) KMI
- WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH THE SIMPLE MIXED PHASE'
- WRITE(UNIT=ILUOUT,FMT=*) 'MICROPHYS. SCHEME AND THE SUBGRID COND. SCHEME.'
- WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT YET AVAILABLE. SET LSUBG_COND '
- WRITE(UNIT=ILUOUT,FMT=*) 'TO FALSE OR CCLOUD TO "REVE", "KESS" '
- !callabortstop
- CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
- END IF
+!!$ IF (LSUBG_COND .AND. LCOLD) THEN
+!!$ WRITE(UNIT=ILUOUT,FMT=9003) KMI
+!!$ WRITE(UNIT=ILUOUT,FMT=*) 'YOU WANT TO USE BOTH THE SIMPLE MIXED PHASE'
+!!$ WRITE(UNIT=ILUOUT,FMT=*) 'MICROPHYS. SCHEME AND THE SUBGRID COND. SCHEME.'
+!!$ WRITE(UNIT=ILUOUT,FMT=*) 'THIS IS NOT YET AVAILABLE. SET LSUBG_COND '
+!!$ WRITE(UNIT=ILUOUT,FMT=*) 'TO FALSE OR CCLOUD TO "REVE", "KESS" '
+!!$ !callabortstop
+!!$ CALL PRINT_MSG(NVERB_FATAL,'GEN','READ_EXSEG_n','')
+!!$ END IF
!
IF ( XALPHAC /= 3.0 .OR. XNUC /= 2.0) THEN
WRITE(UNIT=ILUOUT,FMT=9001) KMI
diff --git a/src/MNH/read_field.f90 b/src/MNH/read_field.f90
index e699bf02adbdbeb963970813fad79a9d30bdde82..d65be13d9e968b989260fd578e2693b9eb150fe0 100644
--- a/src/MNH/read_field.f90
+++ b/src/MNH/read_field.f90
@@ -251,6 +251,7 @@ END MODULE MODI_READ_FIELD
!! Bielli S. 02/2019 Sea salt : significant sea wave height influences salt emission; 5 salt modes
! P. Wautelet 14/03/2019: correct ZWS when variable not present in file
! M. Leriche 10/06/2019: in restart case read all immersion modes for LIMA
+!! B. Vie 06/2020: Add prognostic supersaturation for LIMA
!! F. Auguste 02/2021: add fields necessary for IBM
!! T. Nagel 02/2021: add fields necessary for turbulence recycling
!! J.L. Redelsperger 03/2021: add necessary variables for Ocean LES case
@@ -943,6 +944,11 @@ DO JSV = NSV_LIMA_BEG,NSV_LIMA_END
IF (JSV .EQ. NSV_LIMA_HOM_HAZE) THEN
TZFIELD%CMNHNAME = TRIM(CLIMA_COLD_NAMES(5))//'T'
END IF
+!
+! Super saturation
+ IF (JSV .EQ. NSV_LIMA_SPRO) THEN
+ TZFIELD%CMNHNAME = TRIM(CLIMA_WARM_NAMES(5))//'T'
+ END IF
!
TZFIELD%CLONGNAME = TRIM(TZFIELD%CMNHNAME)
CALL IO_Field_read(TPINIFILE,TZFIELD,PSVT(:,:,:,JSV))
diff --git a/src/MNH/resolved_cloud.f90 b/src/MNH/resolved_cloud.f90
index 9de88ea5bcb7cab7aa9721b8c239f8e184c6fe2a..399fd1455af870a6814828ad756d9cdee012b091 100644
--- a/src/MNH/resolved_cloud.f90
+++ b/src/MNH/resolved_cloud.f90
@@ -281,6 +281,7 @@ END MODULE MODI_RESOLVED_CLOUD
! P. Wautelet 23/06/2020: remove ZSVS and ZSVT to improve code readability
! P. Wautelet 30/06/2020: move removal of negative scalar variables to Sources_neg_correct
! P. Wautelet 30/06/2020: remove non-local corrections
+!! B. Vie 06/2020 Add prognostic supersaturation for LIMA
!-------------------------------------------------------------------------------
!
!* 0. DECLARATIONS
@@ -296,8 +297,8 @@ USE MODD_NSV, ONLY: NSV_C1R3END, NSV_C2R2BEG, NSV_C2R2END,
USE MODD_PARAM_C2R2, ONLY: LSUPSAT
USE MODD_PARAMETERS, ONLY: JPHEXT, JPVEXT
USE MODD_PARAM_ICE, ONLY: CSEDIM, LADJ_BEFORE, LADJ_AFTER, CFRAC_ICE_ADJUST, LRED
-USE MODD_PARAM_LIMA, ONLY: LCOLD, LRAIN, LWARM, XCONC_CCN_TOT, NMOD_CCN, NMOD_IFN, NMOD_IMM, LPTSPLIT, &
- YRTMIN=>XRTMIN, YCTMIN=>XCTMIN
+USE MODD_PARAM_LIMA, ONLY: LCOLD, XCONC_CCN_TOT, NMOD_CCN, NMOD_IFN, NMOD_IMM, LPTSPLIT, &
+ YRTMIN=>XRTMIN, YCTMIN=>XCTMIN, MACTIT=>LACTIT, LSPRO, LADJ
USE MODD_RAIN_ICE_DESCR, ONLY: XRTMIN
USE MODD_SALT, ONLY: LSALT
USE MODD_TURB_n, ONLY: CSUBG_AUCV_RI, CCONDENS, CLAMBDA3, CSUBG_MF_PDF
@@ -312,8 +313,10 @@ USE MODI_ICE_ADJUST
USE MODI_KHKO_NOTADJUST
USE MODI_LIMA
USE MODI_LIMA_ADJUST
+USE MODI_LIMA_ADJUST_SPLIT
USE MODI_LIMA_COLD
USE MODI_LIMA_MIXED
+USE MODI_LIMA_NOTADJUST
USE MODI_LIMA_WARM
USE MODI_RAIN_C2R2_KHKO
USE MODI_RAIN_ICE
@@ -468,11 +471,15 @@ INTEGER :: ISVEND ! last scalar index for microph
REAL, DIMENSION(:), ALLOCATABLE :: ZRSMIN ! Minimum value for tendencies
LOGICAL, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,2),SIZE(PZZ,3)):: LLMICRO ! mask to limit computation
REAL, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,2),SIZE(PZZ,3), KRR) :: ZFPR
+REAL, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,2),SIZE(PZZ,3)) :: ZNPRO,ZSSPRO
!
INTEGER :: JMOD, JMOD_IFN
LOGICAL :: GWEST,GEAST,GNORTH,GSOUTH
! BVIE work array waiting for PINPRI
REAL, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,2)):: ZINPRI
+REAL, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,2),SIZE(PZZ,3)):: ZICEFR
+REAL, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,2),SIZE(PZZ,3)):: ZPRCFR
+REAL, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,2),SIZE(PZZ,3)):: ZTM
!
!------------------------------------------------------------------------------
!
@@ -935,7 +942,7 @@ SELECT CASE ( HCLOUD )
PSVT(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), PW_ACT, &
PTHS, PRS, PSVS(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), &
PINPRC, PINDEP, PINPRR, ZINPRI, PINPRS, PINPRG, PINPRH, &
- PEVAP3D )
+ PEVAP3D, PCLDFR, ZICEFR, ZPRCFR )
ELSE
IF (OWARM) CALL LIMA_WARM(OACTIT, OSEDC, ORAIN, KSPLITR, PTSTEP, KMI, &
@@ -964,12 +971,29 @@ SELECT CASE ( HCLOUD )
!
!* 12.2 Perform the saturation adjustment
!
- CALL LIMA_ADJUST(KRR, KMI, TPFILE, HRAD, &
- HTURBDIM, OSUBG_COND, PTSTEP, &
- PRHODREF, PRHODJ, PEXNREF, PPABST, PSIGS, PPABST, &
- PRT, PRS, PSVT(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), &
- PSVS(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), &
- PTHS, PSRCS, PCLDFR )
+ IF (LSPRO) THEN
+ CALL LIMA_NOTADJUST (KRR, KMI, KTCOUNT,TPFILE, HRAD, &
+ PTSTEP, PRHODJ, PPABSM, PPABST, PRHODREF, PEXNREF, PZZ, &
+ PTHT,PRT, PSVT(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), &
+ PTHS,PRS, PSVS(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), &
+ PCLDFR, PSRCS )
+ ELSE IF (LPTSPLIT) THEN
+ CALL LIMA_ADJUST_SPLIT(KRR, KMI, TPFILE, HRAD, CCONDENS, CLAMBDA3, &
+ HTURBDIM, OSUBG_COND, OSIGMAS, PTSTEP, PSIGQSAT, &
+ PRHODREF, PRHODJ, PEXNREF, PPABST, PSIGS, PMFCONV, PPABST, ZZZ, &
+ PDTHRAD, PW_ACT, &
+ PRT, PRS, PSVT(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), &
+ PSVS(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), &
+ PTHS, PSRCS, PCLDFR, ZICEFR, ZPRCFR, PRC_MF, PCF_MF )
+ ELSE
+ CALL LIMA_ADJUST(KRR, KMI, TPFILE, HRAD, &
+ HTURBDIM, OSUBG_COND, OSIGMAS, PTSTEP, PSIGQSAT, &
+ PRHODREF, PRHODJ, PEXNREF, PPABST, PSIGS, PMFCONV, PPABST, ZZZ, &
+ PDTHRAD, PW_ACT, &
+ PRT, PRS, PSVT(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), &
+ PSVS(:,:,:,NSV_LIMA_BEG:NSV_LIMA_END), &
+ PTHS, PSRCS, PCLDFR, ZICEFR, ZPRCFR, PRC_MF, PCF_MF )
+ ENDIF
!
END SELECT
!
diff --git a/src/MNH/sources_neg_correct.f90 b/src/MNH/sources_neg_correct.f90
index 2c40ecb995dbb6da35e1ae155d5722193fc01145..452c18e4327b60168e5c18101b106d14bc656702 100644
--- a/src/MNH/sources_neg_correct.f90
+++ b/src/MNH/sources_neg_correct.f90
@@ -29,7 +29,7 @@ use modd_budget, only: lbudget_th, lbudget_rv, lbudget_rc, lbudget_rr, lbudg
use modd_cst, only: xci, xcl, xcpd, xcpv, xlstt, xlvtt, xp00, xrd, xtt
use modd_nsv, only: nsv_c2r2beg, nsv_c2r2end, nsv_lima_beg, nsv_lima_end, nsv_lima_nc, nsv_lima_nr, nsv_lima_ni
use modd_param_lima, only: lcold_lima => lcold, lrain_lima => lrain, lwarm_lima => lwarm, &
- xctmin_lima => xctmin, xrtmin_lima => xrtmin
+ xctmin_lima => xctmin, xrtmin_lima => xrtmin, lspro
use mode_budget, only: Budget_store_init, Budget_store_end
use mode_msg
@@ -52,6 +52,7 @@ integer :: ji, jj, jk
integer :: jr
integer :: jrmax
integer :: jsv
+integer :: jlimaend
real, dimension(:, :, :), allocatable :: zt, zexn, zlv, zls, zcph, zcor
if ( krr == 0 ) return
@@ -285,7 +286,9 @@ CLOUD: select case ( hcloud )
end if
end if
- prsvs(:, :, :, nsv_lima_beg : nsv_lima_end) = Max( 0.0, prsvs(:, :, :, nsv_lima_beg : nsv_lima_end) )
+ jlimaend=nsv_lima_end
+ if (lspro) jlimaend=jlimaend-1
+ prsvs(:, :, :, nsv_lima_beg : jlimaend) = Max( 0.0, prsvs(:, :, :, nsv_lima_beg : jlimaend) )
end select CLOUD
diff --git a/src/MNH/spawn_field2.f90 b/src/MNH/spawn_field2.f90
index e5fc2c18b42527182dc7a5625af2b5edeb003ee1..44aa7c3ce0835e7c48c58e373e25a9c06ff8c636 100644
--- a/src/MNH/spawn_field2.f90
+++ b/src/MNH/spawn_field2.f90
@@ -155,6 +155,7 @@ END MODULE MODI_SPAWN_FIELD2
!! Modification 05/03/2018 (J.Escobar) bypass gridnesting special case KD(X/Y)RATIO == 1 not parallelized
!! Bielli S. 02/2019 Sea salt : significant sea wave height influences salt emission; 5 salt modes
! P. Wautelet 14/03/2019: correct ZWS when variable not present in file
+!! B. Vie 06/2020 Add prognostic supersaturation for LIMA
! P. Wautelet 11/03/2021: bugfix: correct name for NSV_LIMA_IMM_NUCL
!-------------------------------------------------------------------------------
!
@@ -934,6 +935,10 @@ IF (PRESENT(TPSONFILE)) THEN
IF (JSV .EQ. NSV_LIMA_HOM_HAZE) THEN
TZFIELD%CMNHNAME = TRIM(CLIMA_COLD_NAMES(5))//'T'
END IF
+ ! Supersaturation
+ IF (JSV .EQ. NSV_LIMA_SPRO) THEN
+ TZFIELD%CMNHNAME = TRIM(CLIMA_WARM_NAMES(5))//'T'
+ END IF
! time t
TZFIELD%CLONGNAME = TRIM(TZFIELD%CMNHNAME)
CALL IO_Field_read(TPSONFILE,TZFIELD,ZWORK3D,IRESP)
diff --git a/src/MNH/turb_ver_thermo_flux.f90 b/src/MNH/turb_ver_thermo_flux.f90
index c9187c7190a8d8b72c779a14015db3a4b195c35b..4aa82b977c5a69363823ceffca8cf3d8821afc25 100644
--- a/src/MNH/turb_ver_thermo_flux.f90
+++ b/src/MNH/turb_ver_thermo_flux.f90
@@ -328,6 +328,7 @@ END MODULE MODI_TURB_VER_THERMO_FLUX
!! applied to vertical fluxes of r_np and Thl
!! for implicit version of turbulence scheme
!! corrections and cleaning
+!! June 2020 (B. Vie) Patch preventing negative rc and ri in 2.3 and 3.3
!! JL Redelsperger : 03/2021: Ocean and Autocoupling O-A LES Cases
!! Sfc flux shape for LDEEPOC Case
!!--------------------------------------------------------------------------
@@ -792,14 +793,14 @@ END IF
IF ( KRRL >= 1 ) THEN
IF ( KRRI >= 1 ) THEN
PRRS(:,:,:,2) = PRRS(:,:,:,2) - &
- DZF( MZM( PRHODJ*PATHETA*2.*PSRCM )*ZFLXZ/PDZZ ) &
+ PRHODJ*PATHETA*2.*PSRCM*DZF(ZFLXZ/PDZZ) &
*(1.0-PFRAC_ICE(:,:,:))
PRRS(:,:,:,4) = PRRS(:,:,:,4) - &
- DZF( MZM( PRHODJ*PATHETA*2.*PSRCM )*ZFLXZ/PDZZ ) &
+ PRHODJ*PATHETA*2.*PSRCM*DZF(ZFLXZ/PDZZ) &
*PFRAC_ICE(:,:,:)
ELSE
PRRS(:,:,:,2) = PRRS(:,:,:,2) - &
- DZF( MZM( PRHODJ*PATHETA*2.*PSRCM )*ZFLXZ/PDZZ )
+ PRHODJ*PATHETA*2.*PSRCM*DZF(ZFLXZ/PDZZ)
END IF
END IF
!
@@ -1024,14 +1025,14 @@ IF (KRR /= 0) THEN
IF ( KRRL >= 1 ) THEN
IF ( KRRI >= 1 ) THEN
PRRS(:,:,:,2) = PRRS(:,:,:,2) - &
- DZF( MZM( PRHODJ*PAMOIST*2.*PSRCM )*ZFLXZ/PDZZ ) &
+ PRHODJ*PAMOIST*2.*PSRCM*DZF(ZFLXZ/PDZZ ) &
*(1.0-PFRAC_ICE(:,:,:))
PRRS(:,:,:,4) = PRRS(:,:,:,4) - &
- DZF( MZM( PRHODJ*PAMOIST*2.*PSRCM )*ZFLXZ/PDZZ ) &
+ PRHODJ*PAMOIST*2.*PSRCM*DZF(ZFLXZ/PDZZ ) &
*PFRAC_ICE(:,:,:)
ELSE
PRRS(:,:,:,2) = PRRS(:,:,:,2) - &
- DZF( MZM( PRHODJ*PAMOIST*2.*PSRCM )*ZFLXZ/PDZZ )
+ PRHODJ*PAMOIST*2.*PSRCM*DZF(ZFLXZ/PDZZ )
END IF
END IF
!
diff --git a/src/MNH/update_nsv.f90 b/src/MNH/update_nsv.f90
index 6d5f9fdd0977068e6b0b0f5f3c98d7b709ecae50..c706bfe90fb70043a98770e68a2ab27e486a7745 100644
--- a/src/MNH/update_nsv.f90
+++ b/src/MNH/update_nsv.f90
@@ -87,6 +87,7 @@ NSV_LIMA_IFN_FREE = NSV_LIMA_IFN_FREE_A(KMI)
NSV_LIMA_IFN_NUCL = NSV_LIMA_IFN_NUCL_A(KMI)
NSV_LIMA_IMM_NUCL = NSV_LIMA_IMM_NUCL_A(KMI)
NSV_LIMA_HOM_HAZE = NSV_LIMA_HOM_HAZE_A(KMI)
+NSV_LIMA_SPRO = NSV_LIMA_SPRO_A(KMI)
!
NSV_ELEC = NSV_ELEC_A(KMI)
NSV_ELECBEG = NSV_ELECBEG_A(KMI)
diff --git a/src/MNH/write_lfifm1_for_diag.f90 b/src/MNH/write_lfifm1_for_diag.f90
index 50131fea21510726da1ce8d84a5489d6f0e5f07f..60240e9caf00f71d49bb49ef35d0410ceb14dfa1 100644
--- a/src/MNH/write_lfifm1_for_diag.f90
+++ b/src/MNH/write_lfifm1_for_diag.f90
@@ -145,6 +145,7 @@ END MODULE MODI_WRITE_LFIFM1_FOR_DIAG
! P. Wautelet 08/02/2019: minor bug: compute ZWORK36 only when needed
! S Bielli 02/2019: sea salt: significant sea wave height influences salt emission; 5 salt modes
! P. Wautelet 18/03/2020: remove ICE2 option
+! B. Vie 06/2020 Add prognostic supersaturation for LIMA
! P. Wautelet 11/03/2021: bugfix: correct name for NSV_LIMA_IMM_NUCL
! J.L Redelsperger 03/2021 Adding OCEAN LES Case and Autocoupled O-A LES
!-------------------------------------------------------------------------------
@@ -1171,6 +1172,11 @@ IF (LLIMA_DIAG) THEN
TZFIELD%CMNHNAME = TRIM(CLIMA_COLD_CONC(5))//'T'
END IF
!
+! Supersaturation
+ IF (JSV .EQ. NSV_LIMA_SPRO) THEN
+ TZFIELD%CMNHNAME = TRIM(CLIMA_WARM_CONC(5))//'T'
+ END IF
+ !
TZFIELD%CLONGNAME = TRIM(TZFIELD%CMNHNAME)
ZWORK31(:,:,:)=XSVT(:,:,:,JSV)*1.E-6*XRHODREF(:,:,:)
CALL IO_Field_write(TPFILE,TZFIELD,ZWORK31)
diff --git a/src/MNH/write_lfin.f90 b/src/MNH/write_lfin.f90
index 03363082cf5405f48c941abbd35769fcc40d3ca7..66feb45c3b7e9806fab6f13dd38a998b282e3675 100644
--- a/src/MNH/write_lfin.f90
+++ b/src/MNH/write_lfin.f90
@@ -173,6 +173,7 @@ END MODULE MODI_WRITE_LFIFM_n
! S. Bielli 02/2019: Sea salt: significant sea wave height influences salt emission; 5 salt modes
! P. Wautelet 10/04/2019: replace ABORT and STOP calls by Print_msg
! P. Tulet 02/2020: correction for dust and sea salts
+!! B. Vie 06/2020 Add prognostic supersaturation for LIMA
! PA. Joulin 12/2020: add wind turbine outputs
! F.Auguste 02/2021 : Add IBM
! T.Nagel 02/2021 : Add turbulence recycling
@@ -1007,6 +1008,11 @@ IF (NSV >=1) THEN
TZFIELD%CMNHNAME = TRIM(CLIMA_COLD_NAMES(5))//'T'
END IF
!
+! Supersaturation
+ IF (JSV .EQ. NSV_LIMA_SPRO) THEN
+ TZFIELD%CMNHNAME = TRIM(CLIMA_WARM_NAMES(5))//'T'
+ END IF
+ !
TZFIELD%CLONGNAME = TRIM(TZFIELD%CMNHNAME)
CALL IO_Field_write(TPFILE,TZFIELD,XSVT(:,:,:,JSV))
!