From 726e04cd30e397b6672c8cb8616a33293621366d Mon Sep 17 00:00:00 2001
From: VIE Benoit <vie@sxphynh>
Date: Tue, 10 Jan 2023 16:50:22 +0100
Subject: [PATCH] Move LIMA files from mesonh to common
---
src/arome/micro/hypgeo.F90 | 120 -
src/arome/micro/hypser.F90 | 118 -
src/arome/micro/lima_adjust.F90 | 1229 ----
src/arome/micro/lima_bergeron.F90 | 127 -
src/arome/micro/lima_cold.F90 | 446 --
src/arome/micro/lima_cold_hom_nucl.F90 | 696 --
src/arome/micro/lima_cold_sedimentation.F90 | 383 --
src/arome/micro/lima_cold_slow_processes.F90 | 583 --
src/arome/micro/lima_meyers.F90 | 486 --
src/arome/micro/lima_mixed.F90 | 816 ---
src/arome/micro/lima_mixed_fast_processes.F90 | 1341 ----
src/arome/micro/lima_mixed_slow_processes.F90 | 297 -
src/arome/micro/lima_phillips.F90 | 675 --
src/arome/micro/lima_warm.F90 | 459 --
src/arome/micro/lima_warm_coal.F90 | 513 --
src/arome/micro/lima_warm_evap.F90 | 350 -
src/arome/micro/lima_warm_nucl.F90 | 817 ---
src/arome/micro/lima_warm_sedimentation.F90 | 425 --
.../hypgeo.f90 => common/micro/hypgeo.F90} | 0
.../micro/ini_lima.F90} | 0
.../micro/ini_lima_cold_mixed.F90} | 0
.../micro/ini_lima_warm.F90} | 0
.../micro/init_aerosol_properties.F90} | 0
.../micro/lima.f90 => common/micro/lima.F90} | 0
.../micro/lima_adjust_split.F90} | 0
.../micro/lima_bergeron.F90} | 0
.../micro/lima_ccn_activation.F90} | 0
.../micro/lima_ccn_hom_freezing.F90} | 0
.../micro/lima_collisional_ice_breakup.F90} | 0
.../micro/lima_compute_cloud_fractions.F90} | 0
.../micro/lima_conversion_melting_snow.F90} | 0
.../micro/lima_droplets_accretion.F90} | 0
.../micro/lima_droplets_autoconversion.F90} | 0
.../micro/lima_droplets_hom_freezing.F90} | 0
.../micro/lima_droplets_riming_snow.F90} | 0
.../micro/lima_droplets_self_collection.F90} | 0
.../micro/lima_drops_break_up.F90} | 0
.../micro/lima_drops_hom_freezing.F90} | 0
.../micro/lima_drops_self_collection.F90} | 0
.../micro/lima_drops_to_droplets_conv.F90} | 0
.../micro/lima_functions.F90} | 0
.../micro/lima_graupel.F90} | 0
.../micro/lima_graupel_deposition.F90} | 0
.../micro/lima_hail.F90} | 0
.../micro/lima_hail_deposition.F90} | 0
.../micro/lima_ice_aggregation_snow.F90} | 0
.../micro/lima_ice_deposition.F90} | 0
.../micro/lima_ice_melting.F90} | 0
.../lima_init_ccn_activation_spectrum.F90} | 0
.../micro/lima_inst_procs.F90} | 0
.../micro/lima_meyers_nucleation.F90} | 0
.../micro/lima_nucleation_procs.F90} | 0
.../micro/lima_phillips_ifn_nucleation.F90} | 0
.../micro/lima_phillips_integ.F90} | 0
.../micro/lima_phillips_ref_spectrum.F90} | 0
.../micro/lima_rain_accr_snow.F90} | 0
.../micro/lima_rain_evaporation.F90} | 0
.../micro/lima_rain_freezing.F90} | 0
.../lima_raindrop_shattering_freezing.F90} | 0
.../micro/lima_read_xker_gweth.F90} | 0
.../micro/lima_read_xker_raccs.F90} | 0
.../micro/lima_read_xker_rdryg.F90} | 0
.../micro/lima_read_xker_sdryg.F90} | 0
.../micro/lima_read_xker_sweth.F90} | 0
.../micro/lima_sedimentation.F90} | 0
.../micro/lima_snow_deposition.F90} | 0
.../micro/lima_snow_self_collection.F90} | 0
.../micro/lima_tendencies.F90} | 0
src/common/micro/minpack.F90 | 5780 +++++++++++++++++
.../micro/modd_param_lima.F90} | 0
.../micro/modd_param_lima_cold.F90} | 0
.../micro/modd_param_lima_mixed.F90} | 0
.../micro/modd_param_lima_warm.F90} | 0
tools/check_commit_mesonh.sh | 2 +-
74 files changed, 5781 insertions(+), 9882 deletions(-)
delete mode 100644 src/arome/micro/hypgeo.F90
delete mode 100644 src/arome/micro/hypser.F90
delete mode 100644 src/arome/micro/lima_adjust.F90
delete mode 100644 src/arome/micro/lima_bergeron.F90
delete mode 100644 src/arome/micro/lima_cold.F90
delete mode 100644 src/arome/micro/lima_cold_hom_nucl.F90
delete mode 100644 src/arome/micro/lima_cold_sedimentation.F90
delete mode 100644 src/arome/micro/lima_cold_slow_processes.F90
delete mode 100644 src/arome/micro/lima_meyers.F90
delete mode 100644 src/arome/micro/lima_mixed.F90
delete mode 100644 src/arome/micro/lima_mixed_fast_processes.F90
delete mode 100644 src/arome/micro/lima_mixed_slow_processes.F90
delete mode 100644 src/arome/micro/lima_phillips.F90
delete mode 100644 src/arome/micro/lima_warm.F90
delete mode 100644 src/arome/micro/lima_warm_coal.F90
delete mode 100644 src/arome/micro/lima_warm_evap.F90
delete mode 100644 src/arome/micro/lima_warm_nucl.F90
delete mode 100644 src/arome/micro/lima_warm_sedimentation.F90
rename src/{mesonh/micro/hypgeo.f90 => common/micro/hypgeo.F90} (100%)
rename src/{mesonh/micro/ini_lima.f90 => common/micro/ini_lima.F90} (100%)
rename src/{mesonh/micro/ini_lima_cold_mixed.f90 => common/micro/ini_lima_cold_mixed.F90} (100%)
rename src/{mesonh/micro/ini_lima_warm.f90 => common/micro/ini_lima_warm.F90} (100%)
rename src/{mesonh/micro/init_aerosol_properties.f90 => common/micro/init_aerosol_properties.F90} (100%)
rename src/{mesonh/micro/lima.f90 => common/micro/lima.F90} (100%)
rename src/{mesonh/micro/lima_adjust_split.f90 => common/micro/lima_adjust_split.F90} (100%)
rename src/{mesonh/micro/lima_bergeron.f90 => common/micro/lima_bergeron.F90} (100%)
rename src/{mesonh/micro/lima_ccn_activation.f90 => common/micro/lima_ccn_activation.F90} (100%)
rename src/{mesonh/micro/lima_ccn_hom_freezing.f90 => common/micro/lima_ccn_hom_freezing.F90} (100%)
rename src/{mesonh/micro/lima_collisional_ice_breakup.f90 => common/micro/lima_collisional_ice_breakup.F90} (100%)
rename src/{mesonh/micro/lima_compute_cloud_fractions.f90 => common/micro/lima_compute_cloud_fractions.F90} (100%)
rename src/{mesonh/micro/lima_conversion_melting_snow.f90 => common/micro/lima_conversion_melting_snow.F90} (100%)
rename src/{mesonh/micro/lima_droplets_accretion.f90 => common/micro/lima_droplets_accretion.F90} (100%)
rename src/{mesonh/micro/lima_droplets_autoconversion.f90 => common/micro/lima_droplets_autoconversion.F90} (100%)
rename src/{mesonh/micro/lima_droplets_hom_freezing.f90 => common/micro/lima_droplets_hom_freezing.F90} (100%)
rename src/{mesonh/micro/lima_droplets_riming_snow.f90 => common/micro/lima_droplets_riming_snow.F90} (100%)
rename src/{mesonh/micro/lima_droplets_self_collection.f90 => common/micro/lima_droplets_self_collection.F90} (100%)
rename src/{mesonh/micro/lima_drops_break_up.f90 => common/micro/lima_drops_break_up.F90} (100%)
rename src/{mesonh/micro/lima_drops_hom_freezing.f90 => common/micro/lima_drops_hom_freezing.F90} (100%)
rename src/{mesonh/micro/lima_drops_self_collection.f90 => common/micro/lima_drops_self_collection.F90} (100%)
rename src/{mesonh/micro/lima_drops_to_droplets_conv.f90 => common/micro/lima_drops_to_droplets_conv.F90} (100%)
rename src/{mesonh/micro/lima_functions.f90 => common/micro/lima_functions.F90} (100%)
rename src/{mesonh/micro/lima_graupel.f90 => common/micro/lima_graupel.F90} (100%)
rename src/{mesonh/micro/lima_graupel_deposition.f90 => common/micro/lima_graupel_deposition.F90} (100%)
rename src/{mesonh/micro/lima_hail.f90 => common/micro/lima_hail.F90} (100%)
rename src/{mesonh/micro/lima_hail_deposition.f90 => common/micro/lima_hail_deposition.F90} (100%)
rename src/{mesonh/micro/lima_ice_aggregation_snow.f90 => common/micro/lima_ice_aggregation_snow.F90} (100%)
rename src/{mesonh/micro/lima_ice_deposition.f90 => common/micro/lima_ice_deposition.F90} (100%)
rename src/{mesonh/micro/lima_ice_melting.f90 => common/micro/lima_ice_melting.F90} (100%)
rename src/{mesonh/micro/lima_init_ccn_activation_spectrum.f90 => common/micro/lima_init_ccn_activation_spectrum.F90} (100%)
rename src/{mesonh/micro/lima_inst_procs.f90 => common/micro/lima_inst_procs.F90} (100%)
rename src/{mesonh/micro/lima_meyers_nucleation.f90 => common/micro/lima_meyers_nucleation.F90} (100%)
rename src/{mesonh/micro/lima_nucleation_procs.f90 => common/micro/lima_nucleation_procs.F90} (100%)
rename src/{mesonh/micro/lima_phillips_ifn_nucleation.f90 => common/micro/lima_phillips_ifn_nucleation.F90} (100%)
rename src/{mesonh/micro/lima_phillips_integ.f90 => common/micro/lima_phillips_integ.F90} (100%)
rename src/{mesonh/micro/lima_phillips_ref_spectrum.f90 => common/micro/lima_phillips_ref_spectrum.F90} (100%)
rename src/{mesonh/micro/lima_rain_accr_snow.f90 => common/micro/lima_rain_accr_snow.F90} (100%)
rename src/{mesonh/micro/lima_rain_evaporation.f90 => common/micro/lima_rain_evaporation.F90} (100%)
rename src/{mesonh/micro/lima_rain_freezing.f90 => common/micro/lima_rain_freezing.F90} (100%)
rename src/{mesonh/micro/lima_raindrop_shattering_freezing.f90 => common/micro/lima_raindrop_shattering_freezing.F90} (100%)
rename src/{mesonh/micro/lima_read_xker_gweth.f90 => common/micro/lima_read_xker_gweth.F90} (100%)
rename src/{mesonh/micro/lima_read_xker_raccs.f90 => common/micro/lima_read_xker_raccs.F90} (100%)
rename src/{mesonh/micro/lima_read_xker_rdryg.f90 => common/micro/lima_read_xker_rdryg.F90} (100%)
rename src/{mesonh/micro/lima_read_xker_sdryg.f90 => common/micro/lima_read_xker_sdryg.F90} (100%)
rename src/{mesonh/micro/lima_read_xker_sweth.f90 => common/micro/lima_read_xker_sweth.F90} (100%)
rename src/{mesonh/micro/lima_sedimentation.f90 => common/micro/lima_sedimentation.F90} (100%)
rename src/{mesonh/micro/lima_snow_deposition.f90 => common/micro/lima_snow_deposition.F90} (100%)
rename src/{mesonh/micro/lima_snow_self_collection.f90 => common/micro/lima_snow_self_collection.F90} (100%)
rename src/{mesonh/micro/lima_tendencies.f90 => common/micro/lima_tendencies.F90} (100%)
create mode 100644 src/common/micro/minpack.F90
rename src/{mesonh/micro/modd_param_lima.f90 => common/micro/modd_param_lima.F90} (100%)
rename src/{mesonh/micro/modd_param_lima_cold.f90 => common/micro/modd_param_lima_cold.F90} (100%)
rename src/{mesonh/micro/modd_param_lima_mixed.f90 => common/micro/modd_param_lima_mixed.F90} (100%)
rename src/{mesonh/micro/modd_param_lima_warm.f90 => common/micro/modd_param_lima_warm.F90} (100%)
diff --git a/src/arome/micro/hypgeo.F90 b/src/arome/micro/hypgeo.F90
deleted file mode 100644
index 9976b4990..000000000
--- a/src/arome/micro/hypgeo.F90
+++ /dev/null
@@ -1,120 +0,0 @@
-!-----------------------------------------------------------------
-!--------------- special set of characters for RCS information
-!-----------------------------------------------------------------
-! $Source: /home/cvsroot/MESONH_RCS/CODEMNH/hypgeo.f90,v $ $Revision: 1.6 $
-! MASDEV4_7 operators 2006/05/18 13:07:25
-!-----------------------------------------------------------------
-!####################
-MODULE MODI_HYPGEO
-!####################
-!
-INTERFACE
-!
-FUNCTION HYPGEO(PA,PB,PC,PF,PX) RESULT(PHYPGEO)
-REAL, INTENT(IN) :: PA,PB,PC,PF
-REAL, INTENT(IN) :: PX
-REAL :: PHYPGEO
-END FUNCTION HYPGEO
-!
-END INTERFACE
-!
-END MODULE MODI_HYPGEO
-! #############################################
- FUNCTION HYPGEO(PA,PB,PC,PF,PX) RESULT(PHYPGEO)
-! #############################################
-!
-!
-!!**** *HYPGEO* - hypergeometric function
-!!
-!!
-!! PURPOSE
-!! -------
-! The purpose of this function is to compute the hypergeometric
-!! function of its argument.
-!!
-!!
-!! A*B (A+1)A*(B+1)B X^2
-!! HYPGEO(A,B,C,X)= 1 + ----- * X + ------------- * --- + ... +
-!! C (C+1)C 2
-!!
-!! (A+n)...A*(B+n)...B X^n
-!! --------------------- * ----- + ... ...
-!! (C+n)...C n!
-!!
-!!** METHOD
-!! ------
-!!
-!! EXTERNAL
-!! --------
-!! HYPSER
-!!
-!! IMPLICIT ARGUMENTS
-!! ------------------
-!!
-!! REFERENCE
-!! ---------
-!! Press, Teukolsky, Vetterling and Flannery: Numerical Recipes, 272
-!!
-!!
-!! AUTHOR
-!! ------
-!! Jean-Martial Cohard *LA/OMP*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original 31/12/96
-!
-!------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-!
-!
-USE MODI_GAMMA
-USE MODI_HYPSER
-!
-IMPLICIT NONE
-!
-!* 0.1 declarations of arguments and result
-!
-REAL, INTENT(IN) :: PA,PB,PC,PF
-REAL, INTENT(IN) :: PX
-REAL :: PHYPGEO
-!
-!* 0.2 declarations of local variables
-!
-!
-INTEGER :: JN
-INTEGER :: ITMAX=100
-REAL :: ZEPS,ZTEMP
-REAL :: ZFPMIN=1.E-30
-REAL :: ZXH
-REAL :: ZX0,ZX1,ZZA,ZZB,ZZC,ZZD,Y(2)
-!
-!------------------------------------------------------------------------------
-!
-!
-ZEPS = 2.E-2
-ZXH = PF * PX**2.0
-IF (ZXH.LT.(1-ZEPS)) THEN
- CALL HYPSER(PA,PB,PC,-ZXH,PHYPGEO)
-ELSE IF (ZXH.GT.(1.+ZEPS)) THEN
- ZXH = 1./ZXH
- CALL HYPSER(PA,PA-PC+1.,PA-PB+1.,-ZXH,PHYPGEO)
- PHYPGEO = PHYPGEO*ZXH**(PA)* &
- (GAMMA(PC)*GAMMA(PB-PA)/(GAMMA(PB)*GAMMA(PC-PA)))
- CALL HYPSER(PB,PB-PC+1.,PB-PA+1.,-ZXH,ZTEMP)
- PHYPGEO = PHYPGEO+ZTEMP*ZXH**(PB)* &
- (GAMMA(PC)*GAMMA(PA-PB)/(GAMMA(PA)*GAMMA(PC-PB)))
-ELSE
- ZX0 = (1.-ZEPS)
- ZX1 = 1./(1.+ZEPS)
- CALL HYPSER(PA,PA-PC+1.,PA-PB+1.,-ZX1,PHYPGEO)
- PHYPGEO = PHYPGEO*ZX1**(PA)* &
- (GAMMA(PC)*GAMMA(PB-PA)/(GAMMA(PB)*GAMMA(PC-PA)))
- CALL HYPSER(PB,PB-PC+1.,PB-PA+1.,-ZX1,ZTEMP)
- PHYPGEO = PHYPGEO+ZTEMP*ZX1**(PB)* &
- (GAMMA(PC)*GAMMA(PA-PB)/(GAMMA(PA)*GAMMA(PC-PB)))
- CALL HYPSER(PA,PB,PC,-ZX0,ZTEMP)
- PHYPGEO = ZTEMP + (ZXH-ZX0)*(PHYPGEO-ZTEMP)/(2.*ZEPS)
-ENDIF
-END
diff --git a/src/arome/micro/hypser.F90 b/src/arome/micro/hypser.F90
deleted file mode 100644
index 28a15f8eb..000000000
--- a/src/arome/micro/hypser.F90
+++ /dev/null
@@ -1,118 +0,0 @@
-!-----------------------------------------------------------------
-!--------------- special set of characters for RCS information
-!-----------------------------------------------------------------
-! $Source: /home/cvsroot/MESONH_RCS/CODEMNH/hypser.f90,v $ $Revision: 1.7 $
-! MASDEV4_7 operators 2006/05/18 13:07:25
-!-----------------------------------------------------------------
-!####################
-MODULE MODI_HYPSER
-!####################
-!
-INTERFACE
-!
-SUBROUTINE HYPSER(PA,PB,PC,PX,PHYP)
-REAL, INTENT(IN) :: PA,PB,PC
-REAL, INTENT(IN) :: PX
-REAL, INTENT(INOUT) :: PHYP
-END SUBROUTINE HYPSER
-!
-END INTERFACE
-!
-END MODULE MODI_HYPSER
-! #############################################
- SUBROUTINE HYPSER(PA,PB,PC,PX,PHYP)
-! #############################################
-!
-!
-!!**** *HYPSER* - hypergeometric function
-!!
-!!
-!! PURPOSE
-!! -------
-! The purpose of this function is to compute the hypergeometric
-!! function of its argument.
-!!
-!!
-!! A*B (A+1)A*(B+1)B X^2
-!! HYPSER(A,B,C,X)= 1 + ----- * X + ------------- * --- + ... +
-!! C (C+1)C 2
-!!
-!! (A+n)...A*(B+n)...B X^n
-!! --------------------- * ----- + ... ...
-!! (C+n)...C n!
-!!
-!!** METHOD
-!! ------
-!!
-!! EXTERNAL
-!! --------
-!! HYPSER
-!!
-!! IMPLICIT ARGUMENTS
-!! ------------------
-!!
-!! REFERENCE
-!! ---------
-!! Press, Teukolsky, Vetterling and Flannery: Numerical Recipes, 272
-!!
-!!
-!! AUTHOR
-!! ------
-!! Jean-Martial Cohard *LA/OMP*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original 31/12/96
-!
-!------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-!
-!
-IMPLICIT NONE
-!
-!* 0.1 declarations of arguments and result
-!
-REAL, INTENT(IN) :: PA,PB,PC
-REAL, INTENT(IN) :: PX
-REAL, INTENT(INOUT) :: PHYP
-!
-!
-!
-!* 0.2 declarations of local variables
-!
-INTEGER :: JN,JFLAG
-REAL :: ZXH,ZZA,ZZB,ZZC,ZFAC,ZTEMP
-REAL :: ZPREC
-!
-!------------------------------------------------------------------------------
-!
-ZPREC = 1.0E-04
-ZXH = PX
-ZFAC = 1.0
-ZTEMP = ZFAC
-ZZA = PA
-ZZB = PB
-ZZC = PC
-JFLAG = 0
-SERIE: DO JN = 1,5000
- ZFAC = ZFAC * ZZA * ZZB / ZZC
- ZFAC = ZFAC * ZXH / FLOAT(JN)
- PHYP = ZTEMP + ZFAC
- IF (ABS(PHYP-ZTEMP).LE.ZPREC) THEN
- JFLAG = 1
- EXIT SERIE
- END IF
- ZTEMP = PHYP
- ZZA = ZZA + 1.
- ZZB = ZZB + 1.
- ZZC = ZZC + 1.
-END DO SERIE
-IF (JFLAG == 0) THEN
- PRINT *,'CONVERGENCE FAILURE IN HYPSER'
-!callabortstop
-CALL ABORT
- STOP
-END IF
-!
-END
diff --git a/src/arome/micro/lima_adjust.F90 b/src/arome/micro/lima_adjust.F90
deleted file mode 100644
index fd7e8f5cd..000000000
--- a/src/arome/micro/lima_adjust.F90
+++ /dev/null
@@ -1,1229 +0,0 @@
-! #######################
- MODULE MODI_LIMA_ADJUST
-! #######################
-!
-INTERFACE
-!
- SUBROUTINE LIMA_ADJUST(KRR, KMI, HFMFILE, HLUOUT, HRAD, &
- HTURBDIM, OCLOSE_OUT, OSUBG_COND, PTSTEP, &
- PRHODREF, PRHODJ, PEXNREF, PPABSM, PSIGS, PPABST, &
- PRT, PRS, PSVT, PSVS, &
- PTHS, PSRCS, PCLDFR, &
- YDDDH, YDLDDH, YDMDDH )
- !
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-INTEGER, INTENT(IN) :: KRR ! Number of moist variables
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-CHARACTER*4, INTENT(IN) :: HTURBDIM ! Dimensionality of the
- ! turbulence scheme
-CHARACTER*4, INTENT(IN) :: HRAD ! Radiation scheme name
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the OUTPUT FM-file
-LOGICAL, INTENT(IN) :: OSUBG_COND ! Switch for Subgrid
- ! Condensation
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-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) :: PPABST ! Absolute Pressure at t
-!
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! m.r. at t
-!
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRS ! m.r. source
-!
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PSVT ! Concentrations at t
-!
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PSVS ! Concentration source
-!
-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
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-END SUBROUTINE LIMA_ADJUST
-!
-END INTERFACE
-!
-END MODULE MODI_LIMA_ADJUST
-!
-! ##########################################################################
- SUBROUTINE LIMA_ADJUST(KRR, KMI, HFMFILE, HLUOUT, HRAD, &
- HTURBDIM, OCLOSE_OUT, OSUBG_COND, PTSTEP, &
- PRHODREF, PRHODJ, PEXNREF, PPABSM, PSIGS, PPABST, &
- PRT, PRS, PSVT, PSVS, &
- PTHS, PSRCS, PCLDFR, &
- YDDDH, YDLDDH, YDMDDH )
-! ##########################################################################
-!
-!!**** *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
-!! NBUPROCCTR
-!! 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 ??/??/13
-!! C. Barthe * LACy* jan. 2014 add budgets
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_PARAMETERS
-USE MODD_CST
-USE MODD_CONF
-USE MODD_PARAM_LIMA
-USE MODD_PARAM_LIMA_WARM
-USE MODD_PARAM_LIMA_COLD
-USE MODD_PARAM_LIMA_MIXED
-USE MODD_NSV
-USE MODD_BUDGET
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-USE MODE_BUDGET, ONLY: BUDGET_DDH
-USE MODI_LIMA_FUNCTIONS
-!
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-!
-INTEGER, INTENT(IN) :: KRR ! Number of moist variables
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-CHARACTER*4, INTENT(IN) :: HTURBDIM ! Dimensionality of the
- ! turbulence scheme
-CHARACTER*4, INTENT(IN) :: HRAD ! Radiation scheme name
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the OUTPUT FM-file
-LOGICAL, INTENT(IN) :: OSUBG_COND ! Switch for Subgrid
- ! Condensation
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-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) :: PPABST ! Absolute Pressure at t
-!
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! m.r. at t
-!
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRS ! m.r. source
-!
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PSVT ! Concentrations at t
-!
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PSVS ! Concentration source
-!
-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
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-!* 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
- 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
- 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
-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
-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
-!
-INTEGER :: IRESP ! Return code of FM routines
-INTEGER :: ILENG ! Length of comment string in LFIFM file
-INTEGER :: IGRID ! C-grid indicator in LFIFM file
-INTEGER :: ILENCH ! Length of comment string in LFIFM file
-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
-CHARACTER (LEN=100) :: YCOMMENT ! Comment string in LFIFM file
-CHARACTER (LEN=16) :: YRECFM ! Name of the desired field in LFIFM file
-!
-INTEGER :: ISIZE
-REAL, DIMENSION(:), ALLOCATABLE :: ZRTMIN
-REAL, DIMENSION(:), ALLOCATABLE :: ZCTMIN
-!
-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
-!
-!-------------------------------------------------------------------------------
-!
-!* 1. PRELIMINARIES
-! -------------
-!
-CALL FMLOOK_ll(HLUOUT,HLUOUT,ILUOUT,IRESP)
-!
-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
-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_LIMA ) PCCT(:,:,:) = PSVT(:,:,:,NSV_LIMA_NC)
-IF ( LCOLD_LIMA ) PCIT(:,:,:) = PSVT(:,:,:,NSV_LIMA_NI)
-!
-IF ( LWARM_LIMA ) PCCS(:,:,:) = PSVS(:,:,:,NSV_LIMA_NC)
-IF ( LCOLD_LIMA ) PCIS(:,:,:) = PSVS(:,:,:,NSV_LIMA_NI)
-!
-IF ( LSCAV .AND. LAERO_MASS ) PMAS(:,:,:) = PSVS(:,:,:,NSV_LIMA_SCAVMASS)
-!
-IF ( LWARM_LIMA .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) )
- 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)
-END IF
-!
-IF ( LCOLD_LIMA .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
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 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
-!
-! not yet available
-!
- STOP
- ELSE
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 4. FULLY EXPLICIT SCHEME FROM TZIVION et al. (1989)
-! -----------------------------------------------
-!
-!* select cases where r_i>0 and r_c=0
-!
-GMICRO(:,:,:) = .FALSE.
-GMICRO(IIB:IIE,IJB:IJE,IKB:IKE) = &
- (PRIS(IIB:IIE,IJB:IJE,IKB:IKE)>ZRTMIN(4) .AND. &
- PCIS(IIB:IIE,IJB:IJE,IKB:IKE)>ZCTMIN(4) ) &
- .AND. .NOT. (PRCS(IIB:IIE,IJB:IJE,IKB:IKE)>ZRTMIN(2) .AND. &
- PCCS(IIB:IIE,IJB:IJE,IKB:IKE)>ZCTMIN(2) )
-GMICRO_RI(:,:,:) = GMICRO(:,:,:)
-IMICRO = COUNTJV( GMICRO(:,:,:),I1(:),I2(:),I3(:))
-IF( IMICRO >= 1 ) 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) = PRVT(I1(JL),I2(JL),I3(JL))
- ZRIT(JL) = PRIT(I1(JL),I2(JL),I3(JL))
- ZCIT(JL) = PCIT(I1(JL),I2(JL),I3(JL))
-!
- ZRVS(JL) = PRVS(I1(JL),I2(JL),I3(JL))
- ZRIS(JL) = PRIS(I1(JL),I2(JL),I3(JL))
- ZCIS(JL) = PCIS(I1(JL),I2(JL),I3(JL)) !!!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(:)*ZDT - 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(:)*ZDT ! 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(:) < ZRTMIN(4) )
- 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(:) * ZDT ) * ( ZPRES(:) / XP00 ) ** (XRD/XCPD)
- ZZW(:) = EXP( XALPI - XBETAI/ZZT(:) - XGAMI*ALOG(ZZT(:) ) ) ! es_i
- ZRVSATI(:) = ZEPS*ZZW(:) / ( ZPRES(:)-ZZW(:) ) ! r_si
- WHERE( ZRVS(:)*ZDT<ZRVSATI(:) )
- ZZW(:) = ZRVS(:) + ZRIS(:)
- ZRVS(:) = MIN( ZZW(:),ZRVSATI(:)/ZDT )
- ZTHS(:) = ZTHS(:) + ( MAX( 0.0,ZZW(:)-ZRVS(:) )-ZRIS(:) ) &
- * ZLSFACT(:) / ZEXNREF(:)
- ZRIS(:) = MAX( 0.0,ZZW(:)-ZRVS(:) )
- END WHERE
-!
-!
- ZW(:,:,:) = PRVS(:,:,:)
- PRVS(:,:,:) = UNPACK( ZRVS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRIS(:,:,:)
- PRIS(:,:,:) = 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
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 5. FULLY IMPLICIT CONDENSATION SCHEME
-! ---------------------------------
-!
-!* 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_RC(:,:,:) = GMICRO(:,:,:)
-IMICRO = COUNTJV( GMICRO(:,:,:),I1(:),I2(:),I3(:))
-IF( IMICRO >= 1 ) THEN
- ALLOCATE(ZRVT(IMICRO))
- ALLOCATE(ZRCT(IMICRO))
-!
- ALLOCATE(ZRVS(IMICRO))
- ALLOCATE(ZRCS(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))
- 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))
- ZLVFACT(:) = (XLVTT+(XCPV-XCL)*(ZZT(:)-XTT))/ZZCPH(:) ! L_v/C_ph
- ALLOCATE(ZRVSATW(IMICRO))
- ALLOCATE(ZRVSATW_PRIME(IMICRO))
-!
- 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)
-!
-! 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(ZRVSATW_PRIME)
- DEALLOCATE(ZAWW)
- DEALLOCATE(ZDELT1)
- DEALLOCATE(ZDELT2)
- DEALLOCATE(ZCND)
-END IF ! IMICRO
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 6. IMPLICIT-EXPLICIT SCHEME USING REISIN et al. (1996)
-! ---------------------------------------------------
-!
-!* select cases where r_i>0 and r_c>0 (supercooled water)
-!
-!
-GMICRO(IIB:IIE,IJB:IJE,IKB:IKE) = &
- .NOT. GMICRO_RI(IIB:IIE,IJB:IJE,IKB:IKE) &
- .AND. .NOT. GMICRO_RC(IIB:IIE,IJB:IJE,IKB:IKE) &
- .AND. ( PRIS(IIB:IIE,IJB:IJE,IKB:IKE)>ZRTMIN(4) .AND. &
- PCIS(IIB:IIE,IJB:IJE,IKB:IKE)>ZCTMIN(4) ) &
- .AND. ( PRCS(IIB:IIE,IJB:IJE,IKB:IKE)>ZRTMIN(2) .AND. &
- PCCS(IIB:IIE,IJB:IJE,IKB:IKE)>ZCTMIN(2) )
-IMICRO = COUNTJV( GMICRO(:,:,:),I1(:),I2(:),I3(:))
-IF( IMICRO >= 1 ) THEN
- ALLOCATE(ZRVT(IMICRO))
- ALLOCATE(ZRCT(IMICRO))
- ALLOCATE(ZRIT(IMICRO))
- ALLOCATE(ZCCT(IMICRO))
- ALLOCATE(ZCIT(IMICRO))
-!
- ALLOCATE(ZRVS(IMICRO))
- ALLOCATE(ZRCS(IMICRO))
- ALLOCATE(ZRIS(IMICRO))
- ALLOCATE(ZCCS(IMICRO))
- ALLOCATE(ZCIS(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))
- ZRIT(JL) = PRIT(I1(JL),I2(JL),I3(JL))
- ZCCT(JL) = PCCT(I1(JL),I2(JL),I3(JL))
- ZCIT(JL) = PCIT(I1(JL),I2(JL),I3(JL))
-!
- ZRVS(JL) = PRVS(I1(JL),I2(JL),I3(JL))
- ZRCS(JL) = PRCS(I1(JL),I2(JL),I3(JL))
- ZRIS(JL) = PRIS(I1(JL),I2(JL),I3(JL))
- ZCCS(JL) = PCCS(I1(JL),I2(JL),I3(JL))
- ZCIS(JL) = PCIS(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(ZLSFACT(IMICRO))
- ZLVFACT(:) = (XLVTT+(XCPV-XCL)*(ZZT(:)-XTT))/ZZCPH(:) ! L_v/C_ph
- ZLSFACT(:) = (XLSTT+(XCPV-XCI)*(ZZT(:)-XTT))/ZZCPH(:) ! L_s/C_ph
- ALLOCATE(ZRVSATW(IMICRO))
- ALLOCATE(ZRVSATI(IMICRO))
- ALLOCATE(ZRVSATW_PRIME(IMICRO))
- ALLOCATE(ZRVSATI_PRIME(IMICRO))
- ALLOCATE(ZDELTW(IMICRO))
- ALLOCATE(ZDELTI(IMICRO))
- ALLOCATE(ZAW(IMICRO))
- ALLOCATE(ZAI(IMICRO))
- ALLOCATE(ZCJ(IMICRO))
- ALLOCATE(ZKA(IMICRO))
- ALLOCATE(ZDV(IMICRO))
- ALLOCATE(ZITW(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) )
-!
-!* 6.2 implicit adjustment at water saturation
-!
- 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 )
- ZDELTW(:) = ABS( ZRVS(:)*ZDT - ZRVSATW(:) )
- ZAW(:) = ( XLSTT + (XCPV-XCL)*(ZZT(:)-XTT) )**2 / (ZKA(:)*XRV*ZZT(:)**2) &
- + ( XRV*ZZT(:) ) / (ZDV(:)*ZZW(:))
- 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(:) = ABS( ZRVS(:)*ZDT - ZRVSATI(:) )
- ZAI(:) = ( XLSTT + (XCPV-XCI)*(ZZT(:)-XTT) )**2 / (ZKA(:)*XRV*ZZT(:)**2) &
- + ( XRV*ZZT(:) ) / (ZDV(:)*ZZW(:))
-!
- ZZW(:) = MIN(1.E8,( XLBC* MAX(ZCCT(:),XCTMIN(2)) &
- /(MAX(ZRCT(:),XRTMIN(2))) )**XLBEXC)
- ! Lbda_c
- ZITW(:) = ZCCT(:) * (X0CNDC/ZZW(:) + X2CNDC*ZCJ(:)*ZCJ(:)/ZZW(:)**(XDC+2.0)) &
- / (ZRVSATW(:)*ZAW(:))
- 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(ZAWW(IMICRO))
- ALLOCATE(ZAIW(IMICRO))
- ALLOCATE(ZAWI(IMICRO))
- ALLOCATE(ZAII(IMICRO))
-!
- ALLOCATE(ZFACT(IMICRO))
- ALLOCATE(ZDELT1(IMICRO))
- ALLOCATE(ZDELT2(IMICRO))
-!
- ZAII(:) = ZITI(:)*ZDELTI(:)
- WHERE( ZAII(:)<1.0E-15 )
- ZFACT(:) = ZLVFACT(:)
- ELSEWHERE
- ZFACT(:) = (ZLVFACT(:)*ZITW(:)*ZDELTW(:)+ZLSFACT(:)*ZITI(:)*ZDELTI(:)) &
- / (ZITW(:)*ZDELTW(:)+ZITI(:)*ZDELTI(:))
- END WHERE
- ZAWW(:) = 1.0 + ZRVSATW_PRIME(:)*ZFACT(:)
-!
- ZDELT2(:) = (ZRVSATW_PRIME(:)*ZFACT(:)/ZAWW(:)) * &
- ( ((-2.*XBETAW+XGAMW*ZZT(:))/(XBETAW-XGAMW*ZZT(:)) &
- + (XBETAW/ZZT(:)-XGAMW)*(1.0+2.0*ZRVSATW(:)/ZEPS))/ZZT(:) )
- ZDELT1(:) = (ZFACT(:)/ZAWW(:)) * ( ZRVSATW(:) - ZRVS(:)*ZDT )
-!
- ALLOCATE(ZCND(IMICRO))
- ALLOCATE(ZDEP(IMICRO))
- ZCND(:) = 0.0
- ZDEP(:) = 0.0
-!
- ZZW(:) = - ZDELT1(:)*( 1.0 + 0.5*ZDELT1(:)*ZDELT2(:) ) / (ZFACT(:)*ZDT)
- WHERE( ZAII(:)<1.0E-15 )
- ZCND(:) = ZZW(:)
- ZDEP(:) = 0.0
- ELSEWHERE
- ZCND(:) = ZZW(:)*ZITW(:)*ZDELTW(:) / (ZITW(:)*ZDELTW(:)+ZITI(:)*ZDELTI(:))
- ZDEP(:) = ZZW(:)*ZITI(:)*ZDELTI(:) / (ZITW(:)*ZDELTW(:)+ZITI(:)*ZDELTI(:))
- END WHERE
-!
-! 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(:)
-!
- WHERE( ZDEP(:) < 0.0 )
- ZDEP(:) = MAX ( ZDEP(:), -ZRIS(:) )
- ELSEWHERE
- ZDEP(:) = MIN ( ZDEP(:), ZRVS(:) )
- END WHERE
- ZRVS(:) = ZRVS(:) - ZDEP(:)
- ZRIS(:) = ZRIS(:) + ZDEP(:)
- ZTHS(:) = ZTHS(:) + ZDEP(:) * ZLSFACT(:) / ZEXNREF(:)
-!
-!* 6.3 explicit integration of the final eva/dep rates
-!
- ZZT(:) = ( ZTHS(:) * ZDT ) * ( ZPRES(:) / XP00 ) ** (XRD/XCPD)
- ZZW(:) = EXP( XALPI - XBETAI/ZZT(:) - XGAMI*ALOG(ZZT(:) ) ) ! es_i
- ZRVSATI(:) = ZEPS*ZZW(:) / ( ZPRES(:)-ZZW(:) ) ! r_si
-!
-! If Si < 0, implicit adjustment to Si=0 using ice only
-!
- WHERE( ZRVS(:)*ZDT<ZRVSATI(:) )
- ZZW(:) = ZRVS(:) + ZRIS(:)
- ZRVS(:) = MIN( ZZW(:),ZRVSATI(:)/ZDT )
- ZTHS(:) = ZTHS(:) + ( MAX( 0.0,ZZW(:)-ZRVS(:) )-ZRIS(:) ) &
- * ZLSFACT(:) / ZEXNREF(:)
- ZRIS(:) = MAX( 0.0,ZZW(:)-ZRVS(:) )
- END WHERE
-!
-! Following the previous adjustment, the real procedure begins
-!
- ZZT(:) = ( ZTHS(:) * ZDT ) * ( ZPRES(:) / XP00 ) ** (XRD/XCPD)
-!
- ZLVFACT(:) = (XLVTT+(XCPV-XCL)*(ZZT(:)-XTT))/ZZCPH(:) ! L_v/C_ph
- ZLSFACT(:) = (XLSTT+(XCPV-XCI)*(ZZT(:)-XTT))/ZZCPH(:) ! L_s/C_ph
-!
- 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( 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 )
- ZDELTW(:) = ZRVS(:)*ZDT - ZRVSATW(:)
- ZAW(:) = ( XLSTT + (XCPV-XCL)*(ZZT(:)-XTT) )**2 / (ZKA(:)*XRV*ZZT(:)**2) &
- + ( XRV*ZZT(:) ) / (ZDV(:)*ZZW(:))
-!
- 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(:)*ZDT - ZRVSATI(:)
- ZAI(:) = ( XLSTT + (XCPV-XCI)*(ZZT(:)-XTT) )**2 / (ZKA(:)*XRV*ZZT(:)**2) &
- + ( XRV*ZZT(:) ) / (ZDV(:)*ZZW(:))
-!
- ZZW(:) = MIN(1.E8,( XLBC* MAX(ZCCS(:),ZCTMIN(2)) &
- /(MAX(ZRCS(:),ZRTMIN(2))) )**XLBEXC)
- ! Lbda_c
- ZITW(:) = ZCCT(:) * (X0CNDC/ZZW(:) + X2CNDC*ZCJ(:)*ZCJ(:)/ZZW(:)**(XDC+2.0)) &
- / (ZRVSATW(:)*ZAW(:))
- ZZW(:) = MIN(1.E8,( XLBI* MAX(ZCIS(:),ZCTMIN(4)) &
- /(MAX(ZRIS(:),ZRTMIN(4))) )**XLBEXI)
- ! Lbda_I
- ZITI(:) = ZCIT(:) * (X0DEPI/ZZW(:) + X2DEPI*ZCJ(:)*ZCJ(:)/ZZW(:)**(XDI+2.0)) &
- / (ZRVSATI(:)*ZAI(:))
-!
- ZAWW(:) = 1.0 + ZRVSATW_PRIME(:)*ZLVFACT(:)
- ZAIW(:) = 1.0 + ZRVSATI_PRIME(:)*ZLVFACT(:)
- ZAWI(:) = 1.0 + ZRVSATW_PRIME(:)*ZLSFACT(:)
- ZAII(:) = 1.0 + ZRVSATI_PRIME(:)*ZLSFACT(:)
-!
- ZCND(:) = 0.0
- ZDEP(:) = 0.0
- ZZW(:) = ZAWW(:)*ZITW(:) + ZAII(:)*ZITI(:) ! R
- WHERE( ZZW(:)<1.0E-2 )
- ZFACT(:) = ZDT*(0.5 - (ZZW(:)*ZDT)/6.0)
- ELSEWHERE
- ZFACT(:) = (1.0/ZZW(:))*(1.0-(1.0-EXP(-ZZW(:)*ZDT))/(ZZW(:)*ZDT))
- END WHERE
- ZCND(:) = ZITW(:)*(ZDELTW(:)-( ZAWW(:)*ZITW(:)*ZDELTW(:) &
- + ZAWI(:)*ZITI(:)*ZDELTI(:) )*ZFACT(:))
- ZDEP(:) = ZITI(:)*(ZDELTI(:)-( ZAIW(:)*ZITW(:)*ZDELTW(:) &
- + ZAII(:)*ZITI(:)*ZDELTI(:) )*ZFACT(:))
-!
-! Integration
-!
- WHERE( ZCND(:) < 0.0 )
- ZCND(:) = MAX ( ZCND(:), -ZRCS(:) )
- ELSEWHERE
- ZCND(:) = MIN ( ZCND(:), ZRVS(:) )
- END WHERE
- WHERE( ZRCS(:) < ZRTMIN(2) )
- ZCND(:) = 0.0
- END WHERE
- ZRVS(:) = ZRVS(:) - ZCND(:)
- ZRCS(:) = ZRCS(:) + ZCND(:)
- ZTHS(:) = ZTHS(:) + ZCND(:) * ZLVFACT(:) / ZEXNREF(:)
-!
- WHERE( ZDEP(:) < 0.0 )
- ZDEP(:) = MAX ( ZDEP(:), -ZRIS(:) )
- ELSEWHERE
- ZDEP(:) = MIN ( ZDEP(:), ZRVS(:) )
- END WHERE
- WHERE( ZRIS(:) < ZRTMIN(4) )
- 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(:) * ZDT ) * ( ZPRES(:) / XP00 ) ** (XRD/XCPD)
- ZLVFACT(:) = (XLVTT+(XCPV-XCL)*(ZZT(:)-XTT))/ZZCPH(:) ! L_v/C_ph
- ZLSFACT(:) = (XLSTT+(XCPV-XCI)*(ZZT(:)-XTT))/ZZCPH(:) ! L_s/C_ph
- ZZW(:) = EXP( XALPI - XBETAI/ZZT(:) - XGAMI*ALOG(ZZT(:) ) ) ! es_i
- ZRVSATI(:) = ZEPS*ZZW(:) / ( ZPRES(:)-ZZW(:) ) ! r_si
- WHERE( ZRVS(:)*ZDT<ZRVSATI(:) )
- ZZW(:) = ZRVS(:) + ZRIS(:)
- ZRVS(:) = MIN( ZZW(:),ZRVSATI(:)/ZDT )
- ZTHS(:) = ZTHS(:) + ( MAX( 0.0,ZZW(:)-ZRVS(:) )-ZRIS(:) ) &
- * ZLSFACT(:) / ZEXNREF(:)
- ZRIS(:) = MAX( 0.0,ZZW(:)-ZRVS(:) )
- END WHERE
-!
-!
-!
- ZW(:,:,:) = PRVS(:,:,:)
- PRVS(:,:,:) = UNPACK( ZRVS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRCS(:,:,:)
- PRCS(:,:,:) = UNPACK( ZRCS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRIS(:,:,:)
- PRIS(:,:,:) = UNPACK( ZRIS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PTHS(:,:,:)
- PTHS(:,:,:) = UNPACK( ZTHS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
-!
- DEALLOCATE(ZRVT)
- DEALLOCATE(ZRCT)
- DEALLOCATE(ZRIT)
- DEALLOCATE(ZCCT)
- DEALLOCATE(ZCIT)
- DEALLOCATE(ZRVS)
- DEALLOCATE(ZRCS)
- DEALLOCATE(ZRIS)
- DEALLOCATE(ZCCS)
- DEALLOCATE(ZCIS)
- DEALLOCATE(ZTHS)
- DEALLOCATE(ZRHODREF)
- DEALLOCATE(ZZT)
- DEALLOCATE(ZPRES)
- DEALLOCATE(ZEXNREF)
- DEALLOCATE(ZZCPH)
- DEALLOCATE(ZZW)
- DEALLOCATE(ZLVFACT)
- DEALLOCATE(ZLSFACT)
- DEALLOCATE(ZRVSATW)
- DEALLOCATE(ZRVSATI)
- DEALLOCATE(ZRVSATW_PRIME)
- DEALLOCATE(ZRVSATI_PRIME)
- DEALLOCATE(ZDELTW)
- DEALLOCATE(ZDELTI)
- DEALLOCATE(ZAW)
- DEALLOCATE(ZAI)
- DEALLOCATE(ZCJ)
- DEALLOCATE(ZKA)
- DEALLOCATE(ZDV)
- DEALLOCATE(ZITW)
- DEALLOCATE(ZITI)
- DEALLOCATE(ZAWW)
- DEALLOCATE(ZAIW)
- DEALLOCATE(ZAWI)
- DEALLOCATE(ZAII)
- DEALLOCATE(ZFACT)
- DEALLOCATE(ZDELT1)
- DEALLOCATE(ZDELT2)
- DEALLOCATE(ZCND)
- DEALLOCATE(ZDEP)
-END IF ! IMICRO
-!
-END IF ! OSUBG_COND
-!
-! full sublimation of the cloud ice crystals if there are few
-!
-ZMASK(:,:,:) = 0.0
-ZW(:,:,:) = 0.
-WHERE (PRIS(:,:,:) <= ZRTMIN(4) .OR. PCIS(:,:,:) <= ZCTMIN(4))
- PRVS(:,:,:) = PRVS(:,:,:) + PRIS(:,:,:)
- PTHS(:,:,:) = PTHS(:,:,:) - PRIS(:,:,:)*ZLS(:,:,:)/(ZCPH(:,:,:)*ZEXNS(:,:,:))
- PRIS(:,:,:) = 0.0
- ZW(:,:,:) = MAX(PCIS(:,:,:),0.)
- PCIS(:,:,:) = 0.0
-END WHERE
-!
-IF (LCOLD_LIMA .AND. (NMOD_IFN .GE. 1 .OR. NMOD_IMM .GE. 1)) THEN
- ZW1(:,:,:) = 0.
- IF (NMOD_IFN .GE. 1) ZW1(:,:,:) = ZW1(:,:,:) + SUM(PINS,DIM=4)
- IF (NMOD_IMM .GE. 1) ZW1(:,:,:) = ZW1(:,:,:) + SUM(PNIS,DIM=4)
- ZW (:,:,:) = MIN( ZW(:,:,:), ZW1(:,:,:) )
- ZW2(:,:,:) = 0.
- WHERE ( ZW(:,:,:) > 0. )
- ZMASK(:,:,:) = 1.0
- ZW2(:,:,:) = ZW(:,:,:) / ZW1(:,:,:)
- ENDWHERE
-END IF
-!
-IF (LCOLD_LIMA .AND. NMOD_IFN.GE.1) THEN
- DO JMOD_IFN = 1, NMOD_IFN
- PIFS(:,:,:,JMOD_IFN) = PIFS(:,:,:,JMOD_IFN) + &
- ZMASK(:,:,:) * PINS(:,:,:,JMOD_IFN) * ZW2(:,:,:)
- PINS(:,:,:,JMOD_IFN) = PINS(:,:,:,JMOD_IFN) - &
- ZMASK(:,:,:) * PINS(:,:,:,JMOD_IFN) * ZW2(:,:,:)
- PINS(:,:,:,JMOD_IFN) = MAX( 0.0 , PINS(:,:,:,JMOD_IFN) )
- ENDDO
-END IF
-!
-IF (LCOLD_LIMA .AND. NMOD_IMM.GE.1) THEN
- JMOD_IMM = 0
- DO JMOD = 1, NMOD_CCN
- IF (NIMM(JMOD) == 1) THEN
- JMOD_IMM = JMOD_IMM + 1
- PNAS(:,:,:,JMOD) = PNAS(:,:,:,JMOD) + &
- ZMASK(:,:,:) * PNIS(:,:,:,JMOD_IMM) * ZW2(:,:,:)
- PNIS(:,:,:,JMOD_IMM) = PNIS(:,:,:,JMOD_IMM) - &
- ZMASK(:,:,:) * PNIS(:,:,:,JMOD_IMM) * ZW2(:,:,:)
- PNIS(:,:,:,JMOD_IMM) = MAX( 0.0 , PNIS(:,:,:,JMOD_IMM) )
- END IF
- ENDDO
-END IF
-!
-! complete evaporation of the 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_LIMA .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_LIMA .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 of the iterative loop
-!
-END DO
-!
-DEALLOCATE(ZRTMIN)
-DEALLOCATE(ZCTMIN)
-!
-!* 5.2 compute the cloud fraction PCLDFR (binary !!!!!!!)
-!
-IF ( .NOT. OSUBG_COND ) THEN
- WHERE (PRCS(:,:,:) > 1.E-12 / ZDT)
- ZW(:,:,:) = 1.
- ELSEWHERE
- ZW(:,:,:) = 0.
- ENDWHERE
- IF ( SIZE(PSRCS,3) /= 0 ) THEN
- PSRCS(:,:,:) = ZW(:,:,:)
- END IF
-END IF
-!
-IF ( HRAD /= 'NONE' ) THEN
- PCLDFR(:,:,:) = ZW(:,:,:)
-END IF
-!
-IF ( OCLOSE_OUT ) THEN
- ILENCH=LEN(YCOMMENT)
- YRECFM ='NEB'
- YCOMMENT='X_Y_Z_NEB (0)'
- IGRID = 1
- ILENG = SIZE(ZW,1)*SIZE(ZW,2)*SIZE(ZW,3)
- CALL FMWRIT(HFMFILE,YRECFM,HLUOUT,'XY',ZW,IGRID,ILENCH,YCOMMENT,IRESP)
-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_LIMA ) PSVS(:,:,:,NSV_LIMA_NC) = PCCS(:,:,:)
-IF ( LCOLD_LIMA ) PSVS(:,:,:,NSV_LIMA_NI) = PCIS(:,:,:)
-!
-IF ( LSCAV .AND. LAERO_MASS ) PSVS(:,:,:,NSV_LIMA_SCAVMASS) = PMAS(:,:,:)
-!
-IF ( LWARM_LIMA .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_LIMA .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_LIMA .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 ( OCLOSE_OUT ) 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
-
- ILENCH=LEN(YCOMMENT)
- YRECFM ='SSI'
- YCOMMENT='X_Y_Z_SSI'
- IGRID = 1
- ILENG = SIZE(ZW,1)*SIZE(ZW,2)*SIZE(ZW,3)
- CALL FMWRIT(HFMFILE,YRECFM,HLUOUT,'XY',ZW,IGRID,ILENCH,YCOMMENT,IRESP)
-END IF
-!
-!
-!* 7. STORE THE BUDGET TERMS
-! ----------------------
-!
-!
-IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:) * PRHODJ(:,:,:),4,'CEDS_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RV) CALL BUDGET_DDH (PRVS(:,:,:) * PRHODJ(:,:,:),6,'CEDS_BU_RRV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:) * PRHODJ(:,:,:),7,'CEDS_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:) * PRHODJ(:,:,:),9,'CEDS_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH (PCCS(:,:,:) * PRHODJ(:,:,:),12+NSV_LIMA_NC,'CEDS_BU_RSV',YDDDH, YDLDDH, YDMDDH) ! RCC
- CALL BUDGET_DDH (PCIS(:,:,:) * PRHODJ(:,:,:),12+NSV_LIMA_NI,'CEDS_BU_RSV',YDDDH, YDLDDH, YDMDDH) ! RCI
- IF (NMOD_CCN .GE. 1) THEN
- DO JL = 1, NMOD_CCN
- CALL BUDGET_DDH (PNFS(:,:,:,JL)*PRHODJ(:,:,:),12+NSV_LIMA_CCN_FREE+JL-1,'CEDS_BU_RSV',YDDDH, YDLDDH, YDMDDH) ! RCC
- END DO
- END IF
- IF (NMOD_IFN .GE. 1) THEN
- DO JL = 1, NMOD_IFN
- CALL BUDGET_DDH (PIFS(:,:,:,JL)*PRHODJ(:,:,:),12+NSV_LIMA_IFN_FREE+JL-1,'CEDS_BU_RSV',YDDDH, YDLDDH, YDMDDH) ! RCC
- END DO
- END IF
- END IF
-END IF
-
-IF (ALLOCATED(PNFS)) DEALLOCATE(PNFS)
-IF (ALLOCATED(PNAS)) DEALLOCATE(PNAS)
-IF (ALLOCATED(PIFS)) DEALLOCATE(PIFS)
-IF (ALLOCATED(PINS)) DEALLOCATE(PINS)
-IF (ALLOCATED(PNIS)) DEALLOCATE(PNIS)
-
-!
-!------------------------------------------------------------------------------
-!
-END SUBROUTINE LIMA_ADJUST
diff --git a/src/arome/micro/lima_bergeron.F90 b/src/arome/micro/lima_bergeron.F90
deleted file mode 100644
index 63677da20..000000000
--- a/src/arome/micro/lima_bergeron.F90
+++ /dev/null
@@ -1,127 +0,0 @@
-! #################################
- MODULE MODI_LIMA_BERGERON
-! #################################
-!
-INTERFACE
- SUBROUTINE LIMA_BERGERON (HFMFILE, OCLOSE_OUT, LDCOMPUTE, &
- PRCT, PRIT, PCIT, PLBDI, &
- PSSIW, PAI, PCJ, PLVFACT, PLSFACT, &
- P_TH_BERFI, P_RC_BERFI, &
- PA_TH, PA_RC, PA_RI )
-!
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE
-LOGICAL, INTENT(IN) :: OCLOSE_OUT
-LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
-!
-REAL, DIMENSION(:), INTENT(IN) :: PRCT ! Cloud water C. at t
-REAL, DIMENSION(:), INTENT(IN) :: PRIT ! Cloud water C. at t
-REAL, DIMENSION(:), INTENT(IN) :: PCIT ! Cloud water C. at t
-REAL, DIMENSION(:), INTENT(IN) :: PLBDI !
-!
-REAL, DIMENSION(:), INTENT(IN) :: PSSIW !
-REAL, DIMENSION(:), INTENT(IN) :: PAI !
-REAL, DIMENSION(:), INTENT(IN) :: PCJ !
-REAL, DIMENSION(:), INTENT(IN) :: PLVFACT !
-REAL, DIMENSION(:), INTENT(IN) :: PLSFACT !
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: P_TH_BERFI
-REAL, DIMENSION(:), INTENT(INOUT) :: P_RC_BERFI
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_TH
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RC
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RI
-!!
-END SUBROUTINE LIMA_BERGERON
-END INTERFACE
-END MODULE MODI_LIMA_BERGERON
-!
-! ######################################################################
- SUBROUTINE LIMA_BERGERON(HFMFILE, OCLOSE_OUT, LDCOMPUTE, &
- PRCT, PRIT, PCIT, PLBDI, &
- PSSIW, PAI, PCJ, PLVFACT, PLSFACT, &
- P_TH_BERFI, P_RC_BERFI, &
- PA_TH, PA_RC, PA_RI )
-! ######################################################################
-!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the cold-phase homogeneous
-!! freezing of CCN, droplets and drops (T<-35°C)
-!!
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!! C. Barthe * LACy* jan. 2014 add budgets
-!! B.Vie 10/2016 Bug zero division
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_PARAM_LIMA, ONLY : XRTMIN, XCTMIN
-USE MODD_PARAM_LIMA_COLD, ONLY : XDI, X0DEPI, X2DEPI
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE
-LOGICAL, INTENT(IN) :: OCLOSE_OUT
-LOGICAL, DIMENSION(:),INTENT(IN) :: LDCOMPUTE
-!
-REAL, DIMENSION(:), INTENT(IN) :: PRCT ! Cloud water C. at t
-REAL, DIMENSION(:), INTENT(IN) :: PRIT ! Cloud water C. at t
-REAL, DIMENSION(:), INTENT(IN) :: PCIT ! Cloud water C. at t
-REAL, DIMENSION(:), INTENT(IN) :: PLBDI !
-!
-REAL, DIMENSION(:), INTENT(IN) :: PSSIW !
-REAL, DIMENSION(:), INTENT(IN) :: PAI !
-REAL, DIMENSION(:), INTENT(IN) :: PCJ !
-REAL, DIMENSION(:), INTENT(IN) :: PLVFACT !
-REAL, DIMENSION(:), INTENT(IN) :: PLSFACT !
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: P_TH_BERFI
-REAL, DIMENSION(:), INTENT(INOUT) :: P_RC_BERFI
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_TH
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RC
-REAL, DIMENSION(:), INTENT(INOUT) :: PA_RI
-!
-!* 0.2 Declarations of local variables :
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 1. PRELIMINARY COMPUTATIONS
-! ------------------------
-!
-P_TH_BERFI(:) = 0.0
-P_RC_BERFI(:) = 0.0
-!
-WHERE( (PRCT(:)>XRTMIN(2)) .AND. (PRIT(:)>XRTMIN(4)) .AND. (PCIT(:)>XCTMIN(4)) .AND. LDCOMPUTE(:))
-! ZZW(:) = EXP( (XALPW-XALPI) - (XBETAW-XBETAI)/ZZT(:) &
-! - (XGAMW-XGAMI)*ALOG(ZZT(:)) ) -1.0
-! supersaturation over ice at water saturation
- P_RC_BERFI(:) = - ( PSSIW(:) / PAI(:) ) * PCIT(:) * &
- ( X0DEPI/PLBDI(:)+X2DEPI*PCJ(:)*PCJ(:)/PLBDI(:)**(XDI+2.0) )
- P_TH_BERFI(:) = - P_RC_BERFI(:)*(PLSFACT(:)-PLVFACT(:))
-END WHERE
-!
-PA_RC(:) = PA_RC(:) + P_RC_BERFI(:)
-PA_RI(:) = PA_RI(:) - P_RC_BERFI(:)
-PA_TH(:) = PA_TH(:) + P_TH_BERFI(:)
-!
-!
-!-------------------------------------------------------------------------------
-!
-END SUBROUTINE LIMA_BERGERON
diff --git a/src/arome/micro/lima_cold.F90 b/src/arome/micro/lima_cold.F90
deleted file mode 100644
index 2c6030595..000000000
--- a/src/arome/micro/lima_cold.F90
+++ /dev/null
@@ -1,446 +0,0 @@
-! #####################
- MODULE MODI_LIMA_COLD
-! #####################
-!
-INTERFACE
- SUBROUTINE LIMA_COLD (OSEDI, OHHONI, KSPLITG, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, KRR, PZZ, PRHODJ, &
- PRHODREF, PEXNREF, PPABST, PW_NU, &
- PTHM, PPABSM, &
- PTHT, PRT, PSVT, &
- PTHS, PRS, PSVS, &
- PINPRS, PINPRG, PINPRH, &
- YDDDH, YDLDDH, YDMDDH)
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-LOGICAL, INTENT(IN) :: OSEDI ! switch to activate the
- ! cloud ice sedimentation
-LOGICAL, INTENT(IN) :: OHHONI ! enable haze freezing
-INTEGER, INTENT(IN) :: KSPLITG ! Number of small time step
- ! for ice sedimendation
-REAL, INTENT(IN) :: PTSTEP ! Time step
-INTEGER, INTENT(IN) :: KMI ! Model index
-!
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-INTEGER, INTENT(IN) :: KRR ! Number of moist variables
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PW_NU ! updraft velocity used for
- ! the nucleation param.
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHM ! Theta at time t-dt
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSM ! abs. pressure at time t-dt
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! m.r. at t
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PSVT ! Concentrations at t
-!
-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(INOUT) :: PINPRS ! Snow instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRG ! Graupel instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRH ! Hail instant precip
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-END SUBROUTINE LIMA_COLD
-END INTERFACE
-END MODULE MODI_LIMA_COLD
-!
-! ######################################################################
- SUBROUTINE LIMA_COLD (OSEDI, OHHONI, KSPLITG, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, KRR, PZZ, PRHODJ, &
- PRHODREF, PEXNREF, PPABST, PW_NU, &
- PTHM, PPABSM, &
- PTHT, PRT, PSVT, &
- PTHS, PRS, PSVS, &
- PINPRS, PINPRG, PINPRH, &
- YDDDH, YDLDDH, YDMDDH)
-! ######################################################################
-!
-!!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the cold-phase
-!! microphysical sources involving only primary ice and snow, except for
-!! the sedimentation which also includes graupelns, and the homogeneous
-!! freezing of CCNs, cloud droplets and raindrops.
-!!
-!!
-!!** METHOD
-!! ------
-!! The nucleation of IFN is parameterized following either Meyers (1992)
-!! or Phillips (2008, 2013).
-!!
-!! The sedimentation rates are computed with a time spliting technique:
-!! an upstream scheme, written as a difference of non-advective fluxes.
-!! This source term is added to the next coming time step (split-implicit
-!! process).
-!!
-!!
-!! REFERENCES
-!! ----------
-!!
-!! Cohard, J.-M. and J.-P. Pinty, 2000: A comprehensive two-moment warm
-!! microphysical bulk scheme.
-!! Part I: Description and tests
-!! Part II: 2D experiments with a non-hydrostatic model
-!! Accepted for publication in Quart. J. Roy. Meteor. Soc.
-!!
-!! Phillips et al., 2008: An empirical parameterization of heterogeneous
-!! ice nucleation for multiple chemical species of aerosols, J. Atmos. Sci.
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-USE MODD_NSV
-USE MODD_PARAM_LIMA
-!
-USE MODD_BUDGET
-USE MODE_BUDGET, ONLY: BUDGET_DDH
-!
-USE MODI_LIMA_COLD_SEDIMENTATION
-USE MODI_LIMA_MEYERS
-USE MODI_LIMA_PHILLIPS
-USE MODI_LIMA_COLD_HOM_NUCL
-USE MODI_LIMA_COLD_SLOW_PROCESSES
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-LOGICAL, INTENT(IN) :: OSEDI ! switch to activate the
- ! cloud ice sedimentation
-LOGICAL, INTENT(IN) :: OHHONI ! enable haze freezing
-INTEGER, INTENT(IN) :: KSPLITG ! Number of small time step
- ! for ice sedimendation
-REAL, INTENT(IN) :: PTSTEP ! Time step
-INTEGER, INTENT(IN) :: KMI ! Model index
-!
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-INTEGER, INTENT(IN) :: KRR ! Number of moist variables
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PW_NU ! updraft velocity used for
- ! the nucleation param.
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHM ! Theta at time t-dt
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSM ! abs. pressure at time t-dt
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! m.r. at t
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PSVT ! Concentrations at t
-!
-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(INOUT) :: PINPRS ! Snow instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRG ! Graupel instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRH ! Hail instant precip
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-!* 0.2 Declarations of local variables :
-!
-REAL, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,2),SIZE(PZZ,3)) &
- :: 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, & ! Snow/aggregate m.r. at t
- PRGT, & ! Graupel m.r. at t
- PRHT, & ! Graupel m.r. at t
- !
- PRVS, & ! Water vapor m.r. source
- PRCS, & ! Cloud water m.r. source
- PRRS, & ! Rain water m.r. source
- PRIS, & ! Pristine ice m.r. source
- PRSS, & ! Snow/aggregate m.r. source
- PRGS, & ! Graupel/hail m.r. source
- PRHS, & ! Graupel/hail m.r. source
- !
- PCCT, & ! Cloud water C. at t
- PCRT, & ! Rain water C. at t
- PCIT, & ! Ice crystal C. at t
- !
- PCCS, & ! Cloud water C. source
- PCRS, & ! Rain water C. source
- PCIS ! Ice crystal C. source
-!
-REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: PNFS ! CCN C. available source
- !used as Free ice nuclei for
- !HOMOGENEOUS nucleation of haze
-REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: PNAS ! Cloud C. nuclei C. source
- !used as Free ice nuclei for
- !IMMERSION freezing
-REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: PIFS ! Free ice nuclei C. source
- !for DEPOSITION and CONTACT
-REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: PINS ! Activated ice nuclei C. source
- !for DEPOSITION and CONTACT
-REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: PNIS ! Activated ice nuclei C. source
- !for IMMERSION
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: PNHS ! Haze homogeneous activation
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 0. 3D MICROPHYSCAL VARIABLES
-! -------------------------
-!
-!
-! Prepare 3D water mixing ratios
-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.
-PRHT(:,:,:) = 0.
-PRHS(:,:,:) = 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)
-IF ( KRR .GE. 7 ) PRHT(:,:,:) = PRT(:,:,:,7)
-IF ( KRR .GE. 7 ) PRHS(:,:,:) = PRS(:,:,:,7)
-!
-! Prepare 3D number concentrations
-PCCT(:,:,:) = 0.
-PCRT(:,:,:) = 0.
-PCIT(:,:,:) = 0.
-PCCS(:,:,:) = 0.
-PCRS(:,:,:) = 0.
-PCIS(:,:,:) = 0.
-!
-IF ( LWARM_LIMA ) PCCT(:,:,:) = PSVT(:,:,:,NSV_LIMA_NC)
-IF ( LWARM_LIMA .AND. LRAIN_LIMA ) PCRT(:,:,:) = PSVT(:,:,:,NSV_LIMA_NR)
-IF ( LCOLD_LIMA ) PCIT(:,:,:) = PSVT(:,:,:,NSV_LIMA_NI)
-!
-IF ( LWARM_LIMA ) PCCS(:,:,:) = PSVS(:,:,:,NSV_LIMA_NC)
-IF ( LWARM_LIMA .AND. LRAIN_LIMA ) PCRS(:,:,:) = PSVS(:,:,:,NSV_LIMA_NR)
-IF ( LCOLD_LIMA ) PCIS(:,:,:) = PSVS(:,:,:,NSV_LIMA_NI)
-!
-IF ( 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) )
- 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)
-ELSE
- ALLOCATE( PNFS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),1) )
- ALLOCATE( PNAS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),1) )
- PNFS(:,:,:,:) = 0.
- PNAS(:,:,:,:) = 0.
-END IF
-!
-IF ( 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)
-ELSE
- ALLOCATE( PIFS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),1) )
- ALLOCATE( PINS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),1) )
- PIFS(:,:,:,:) = 0.
- PINS(:,:,:,:) = 0.
-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)
-ELSE
- ALLOCATE( PNIS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),1) )
- PNIS(:,:,:,:) = 0.0
-END IF
-!
-IF ( OHHONI ) THEN
- ALLOCATE( PNHS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3)) )
- PNHS(:,:,:) = PSVS(:,:,:,NSV_LIMA_HOM_HAZE)
-ELSE
- ALLOCATE( PNHS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3)) )
- PNHS(:,:,:) = 0.0
-END IF
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 1. COMPUTE THE SEDIMENTATION (RS) SOURCE
-! -------------------------------------
-!
-CALL LIMA_COLD_SEDIMENTATION (OSEDI, KSPLITG, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, &
- PZZ, PRHODJ, PRHODREF, &
- PRIT, PCIT, &
- PRIS, PRSS, PRGS, PRHS, PCIS, &
- PINPRS, PINPRG,&
- PINPRH )
-IF (LBU_ENABLE) THEN
- IF (LBUDGET_RI .AND. OSEDI) &
- CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9 ,'SEDI_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH (PRSS(:,:,:)*PRHODJ(:,:,:),10 ,'SEDI_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH (PRGS(:,:,:)*PRHODJ(:,:,:),11 ,'SEDI_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RH) CALL BUDGET_DDH (PRHS(:,:,:)*PRHODJ(:,:,:),12 ,'SEDI_BU_RRH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- IF (OSEDI) CALL BUDGET_DDH (PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'SEDI_BU_RSV',YDDDH, YDLDDH, YDMDDH) ! RCI
- END IF
-END IF
-!-------------------------------------------------------------------------------
-!
-!
-! COMPUTE THE NUCLEATION PROCESS SOURCES
-! --------------------------------------
-!
-IF (LNUCL_LIMA) THEN
-!
- IF ( LMEYERS_LIMA ) THEN
- PIFS(:,:,:,:) = 0.0
- PNIS(:,:,:,:) = 0.0
- CALL LIMA_MEYERS (OHHONI, PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT, &
- PZZ, PRHODJ, PRHODREF, PEXNREF, PPABST, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, PCCT, &
- PTHS, PRVS, PRCS, PRIS, &
- PCCS, PCIS, PINS, &
- YDDDH, YDLDDH, YDMDDH )
- ELSE
- CALL LIMA_PHILLIPS (OHHONI, PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT, &
- PZZ, PRHODJ, PRHODREF, PEXNREF, PPABST, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
- PTHS, PRVS, PRCS, PRIS, &
- PCIT, PCCS, PCIS, &
- PNAS, PIFS, PINS, PNIS, &
- YDDDH, YDLDDH, YDMDDH )
- END IF
-!
- IF (LWARM_LIMA) THEN
- CALL LIMA_COLD_HOM_NUCL (OHHONI, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, PZZ, PRHODJ, &
- PRHODREF, PEXNREF, PPABST, PW_NU, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
- PTHS, PRVS, PRCS, PRRS, PRIS, PRGS, &
- PCCT, &
- PCCS, PCRS, PNFS, &
- PCIS, PNIS, PNHS , &
- YDDDH, YDLDDH, YDMDDH )
- END IF
-!
-END IF
-!
-!------------------------------------------------------------------------------
-!
-!
-!* 4. SLOW PROCESSES: depositions, aggregation
-! ----------------------------------------
-!
-IF (LSNOW_LIMA) THEN
-!
- CALL LIMA_COLD_SLOW_PROCESSES(PTSTEP, KMI, HFMFILE, HLUOUT, &
- OCLOSE_OUT, PZZ, PRHODJ, &
- PRHODREF, PEXNREF, PPABST, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
- PTHS, PRVS, PRIS, PRSS, &
- PCIT, PCIS, &
- YDDDH, YDLDDH, YDMDDH )
-!
-END IF
-!
-!------------------------------------------------------------------------------
-!
-!
-!* 4. REPORT 3D MICROPHYSICAL VARIABLES IN PRS AND PSVS
-! -------------------------------------------------
-!
-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(:,:,:)
-IF ( KRR .GE. 7 ) PRS(:,:,:,7) = PRHS(:,:,:)
-!
-! Prepare 3D number concentrations
-!
-IF ( LWARM_LIMA ) PSVS(:,:,:,NSV_LIMA_NC) = PCCS(:,:,:)
-IF ( LWARM_LIMA .AND. LRAIN_LIMA ) PSVS(:,:,:,NSV_LIMA_NR) = PCRS(:,:,:)
-IF ( LCOLD_LIMA ) PSVS(:,:,:,NSV_LIMA_NI) = PCIS(:,:,:)
-!
-IF ( 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 ( 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 ( NMOD_IMM .GE. 1 ) THEN
- PSVS(:,:,:,NSV_LIMA_IMM_NUCL:NSV_LIMA_IMM_NUCL+NMOD_IMM-1) = PNIS(:,:,:,:)
-END IF
-
-IF ( OHHONI ) PSVS(:,:,:,NSV_LIMA_HOM_HAZE) = PNHS(:,:,:)
-!
-IF (ALLOCATED(PNFS)) DEALLOCATE(PNFS)
-IF (ALLOCATED(PNAS)) DEALLOCATE(PNAS)
-IF (ALLOCATED(PIFS)) DEALLOCATE(PIFS)
-IF (ALLOCATED(PINS)) DEALLOCATE(PINS)
-IF (ALLOCATED(PNIS)) DEALLOCATE(PNIS)
-IF (ALLOCATED(PNHS)) DEALLOCATE(PNHS)
-!
-!-------------------------------------------------------------------------------
-!
-END SUBROUTINE LIMA_COLD
diff --git a/src/arome/micro/lima_cold_hom_nucl.F90 b/src/arome/micro/lima_cold_hom_nucl.F90
deleted file mode 100644
index f30a0feb3..000000000
--- a/src/arome/micro/lima_cold_hom_nucl.F90
+++ /dev/null
@@ -1,696 +0,0 @@
-! ######################
- MODULE MODI_LIMA_COLD_HOM_NUCL
-! ######################
-!
-INTERFACE
- SUBROUTINE LIMA_COLD_HOM_NUCL (OHHONI, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, PZZ, PRHODJ, &
- PRHODREF, PEXNREF, PPABST, PW_NU, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
- PTHS, PRVS, PRCS, PRRS, PRIS, PRGS, &
- PCCT, &
- PCCS, PCRS, PNFS, &
- PCIS, PNIS, PNHS, &
- YDDDH, YDLDDH, YDMDDH )
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-LOGICAL, INTENT(IN) :: OHHONI ! enable haze freezing
-REAL, INTENT(IN) :: PTSTEP ! Time step
-INTEGER, INTENT(IN) :: KMI ! Model index
-!
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PW_NU ! updraft velocity used for
- ! the nucleation param.
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Cloud ice m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGT ! Graupel m.r. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRGS ! Graupel/hail m.r. source
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCCT ! Cloud water C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCCS ! Cloud water C. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCRS ! Rain water C. source
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNFS ! CCN C. available source
- !used as Free ice nuclei for
- !HOMOGENEOUS nucleation of haze
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIS ! Ice crystal C. source
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNIS ! Activated ice nuclei C. source
- !for IMMERSION
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PNHS ! haze homogeneous freezing
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-END SUBROUTINE LIMA_COLD_HOM_NUCL
-END INTERFACE
-END MODULE MODI_LIMA_COLD_HOM_NUCL
-!
-! ######################################################################
- SUBROUTINE LIMA_COLD_HOM_NUCL (OHHONI, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, PZZ, PRHODJ, &
- PRHODREF, PEXNREF, PPABST, PW_NU, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
- PTHS, PRVS, PRCS, PRRS, PRIS, PRGS, &
- PCCT, &
- PCCS, PCRS, PNFS, &
- PCIS, PNIS, PNHS, &
- YDDDH, YDLDDH, YDMDDH )
-! ######################################################################
-!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the cold-phase homogeneous
-!! freezing of CCN, droplets and drops (T<-35°C)
-!!
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!! C. Barthe * LACy* jan. 2014 add budgets
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_PARAMETERS, ONLY : JPHEXT, JPVEXT
-USE MODD_CST, ONLY : XP00, XRD, XRV, XMV, XMD, XCPD, XCPV, XCL, XCI, &
- XTT, XLSTT, XLVTT, XALPI, XBETAI, XGAMI, &
- XG
-USE MODD_PARAM_LIMA, ONLY : NMOD_CCN, NMOD_IMM, XRTMIN, XCTMIN, XNUC
-USE MODD_PARAM_LIMA_COLD, ONLY : XRCOEF_HONH, XCEXP_DIFVAP_HONH, XCOEF_DIFVAP_HONH,&
- XCRITSAT1_HONH, XCRITSAT2_HONH, XTMAX_HONH, &
- XTMIN_HONH, XC1_HONH, XC2_HONH, XC3_HONH, &
- XDLNJODT1_HONH, XDLNJODT2_HONH, XRHOI_HONH, &
- XC_HONC, XTEXP1_HONC, XTEXP2_HONC, XTEXP3_HONC, &
- XTEXP4_HONC, XTEXP5_HONC
-USE MODD_PARAM_LIMA_WARM, ONLY : XLBC
-USE MODI_LIMA_FUNCTIONS, ONLY : COUNTJV
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-USE MODD_NSV
-USE MODD_BUDGET
-USE MODE_BUDGET, ONLY: BUDGET_DDH
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-LOGICAL, INTENT(IN) :: OHHONI ! enable haze freezing
-REAL, INTENT(IN) :: PTSTEP ! Time step
-INTEGER, INTENT(IN) :: KMI ! Model index
-!
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PW_NU ! updraft velocity used for
- ! the nucleation param.
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Cloud ice m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGT ! Graupel m.r. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRGS ! Graupel/hail m.r. source
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCCT ! Cloud water C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCCS ! Cloud water C. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCRS ! Rain water C. source
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNFS ! CCN C. available source
- !used as Free ice nuclei for
- !HOMOGENEOUS nucleation of haze
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIS ! Ice crystal C. source
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNIS ! Activated ice nuclei C. source
- !for IMMERSION
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PNHS ! haze homogeneous freezing
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-!* 0.2 Declarations of local variables :
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRRT ! Rain water m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRIT ! Pristine ice m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRGT ! Graupel/hail m.r. at t
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZCCT ! Cloud water conc. at t
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZTHS ! Theta source
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVS ! Water vapor m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRCS ! Cloud water m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRRS ! Rain water m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRGS ! Graupel/hail m.r. source
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZCCS ! Cloud water conc. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZCRS ! Rain water conc. source
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZNFS ! available nucleus conc. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZCIS ! Pristine ice conc. source
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZNIS ! Nucleated Ice nuclei conc. source
- !by Immersion
-REAL, DIMENSION(:), ALLOCATABLE :: ZZNHS ! Nucleated Ice nuclei conc. source
- !by Homogeneous freezing
-!
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: ZNHS ! Nucleated Ice nuclei conc. source
- ! by Homogeneous freezing of haze
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: ZW, ZT ! work arrays
-!
-REAL, DIMENSION(:), ALLOCATABLE &
- :: ZRHODREF, & ! RHO Dry REFerence
- ZRHODJ, & ! RHO times Jacobian
- ZZT, & ! Temperature
- ZPRES, & ! Pressure
- ZEXNREF, & ! EXNer Pressure REFerence
- ZZW, & ! Work array
- ZZX, & ! Work array
- ZZY, & ! Work array
- ZLSFACT, & ! L_s/(Pi_ref*C_ph)
- ZLVFACT, & ! L_v/(Pi_ref*C_ph)
- ZLBDAC, & ! Slope parameter of the cloud droplet distr.
- ZSI, & ! Saturation over ice
- ZTCELSIUS,&
- ZLS, &
- ZPSI1, &
- ZPSI2, &
- ZTAU, &
- ZBFACT, &
- ZW_NU, &
- ZFREECCN, &
- ZCCNFROZEN
-!
-INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE ! Physical domain
-INTEGER :: JL, JMOD_CCN, JMOD_IMM ! Loop index
-!
-INTEGER :: INEGT ! Case number of hom. nucleation
-LOGICAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: GNEGT ! Test where to compute the hom. nucleation
-INTEGER , DIMENSION(SIZE(GNEGT)) :: I1,I2,I3 ! Used to replace the COUNT
-!
-REAL :: ZEPS ! molar mass ratio
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 1. PRELIMINARY COMPUTATIONS
-! ------------------------
-!
-!
-! Physical domain
-IIB=1+JPHEXT
-IIE=SIZE(PZZ,1) - JPHEXT
-IJB=1+JPHEXT
-IJE=SIZE(PZZ,2) - JPHEXT
-IKB=1+JPVEXT
-IKE=SIZE(PZZ,3) - JPVEXT
-!
-! Temperature
-ZT(:,:,:) = PTHT(:,:,:) * ( PPABST(:,:,:)/XP00 ) ** (XRD/XCPD)
-!
-IF( OHHONI ) THEN
- ZNHS(:,:,:) = PNHS(:,:,:)
-ELSE
- ZNHS(:,:,:) = 0.0
-END IF
-!
-! Computations only where the temperature is below -35°C
-! PACK variables
-!
-GNEGT(:,:,:) = .FALSE.
-GNEGT(IIB:IIE,IJB:IJE,IKB:IKE) = ZT(IIB:IIE,IJB:IJE,IKB:IKE)<XTT-35.0
-INEGT = COUNTJV( GNEGT(:,:,:),I1(:),I2(:),I3(:))
-!
-IF (INEGT.GT.0) THEN
-
- ALLOCATE(ZRVT(INEGT))
- ALLOCATE(ZRCT(INEGT))
- ALLOCATE(ZRRT(INEGT))
- ALLOCATE(ZRIT(INEGT))
- ALLOCATE(ZRST(INEGT))
- ALLOCATE(ZRGT(INEGT))
- !
- ALLOCATE(ZCCT(INEGT))
- !
- ALLOCATE(ZRVS(INEGT))
- ALLOCATE(ZRCS(INEGT))
- ALLOCATE(ZRRS(INEGT))
- ALLOCATE(ZRIS(INEGT))
- ALLOCATE(ZRGS(INEGT))
- !
- ALLOCATE(ZTHS(INEGT))
- !
- ALLOCATE(ZCCS(INEGT))
- ALLOCATE(ZCRS(INEGT))
- ALLOCATE(ZCIS(INEGT))
- !
- ALLOCATE(ZNFS(INEGT,NMOD_CCN))
- ALLOCATE(ZNIS(INEGT,NMOD_IMM))
- ALLOCATE(ZZNHS(INEGT))
- !
- ALLOCATE(ZRHODREF(INEGT))
- ALLOCATE(ZZT(INEGT))
- ALLOCATE(ZPRES(INEGT))
- ALLOCATE(ZEXNREF(INEGT))
- !
- DO JL=1,INEGT
- ZRVT(JL) = PRVT(I1(JL),I2(JL),I3(JL))
- ZRCT(JL) = PRCT(I1(JL),I2(JL),I3(JL))
- ZRRT(JL) = PRRT(I1(JL),I2(JL),I3(JL))
- ZRIT(JL) = PRIT(I1(JL),I2(JL),I3(JL))
- ZRST(JL) = PRST(I1(JL),I2(JL),I3(JL))
- ZRGT(JL) = PRGT(I1(JL),I2(JL),I3(JL))
- !
- ZCCT(JL) = PCCT(I1(JL),I2(JL),I3(JL))
- !
- ZRVS(JL) = PRVS(I1(JL),I2(JL),I3(JL))
- ZRCS(JL) = PRCS(I1(JL),I2(JL),I3(JL))
- ZRRS(JL) = PRRS(I1(JL),I2(JL),I3(JL))
- ZRIS(JL) = PRIS(I1(JL),I2(JL),I3(JL))
- ZRGS(JL) = PRGS(I1(JL),I2(JL),I3(JL))
- !
- ZTHS(JL) = PTHS(I1(JL),I2(JL),I3(JL))
- !
- ZCCS(JL) = PCCS(I1(JL),I2(JL),I3(JL))
- ZCRS(JL) = PCRS(I1(JL),I2(JL),I3(JL))
- ZCIS(JL) = PCIS(I1(JL),I2(JL),I3(JL))
- !
- DO JMOD_CCN = 1, NMOD_CCN
- ZNFS(JL,JMOD_CCN) = PNFS(I1(JL),I2(JL),I3(JL),JMOD_CCN)
- ENDDO
- DO JMOD_IMM = 1, NMOD_IMM
- ZNIS(JL,JMOD_IMM) = PNIS(I1(JL),I2(JL),I3(JL),JMOD_IMM)
- ENDDO
- ZZNHS(JL) = ZNHS(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) = PPABST(I1(JL),I2(JL),I3(JL))
- ZEXNREF(JL) = PEXNREF(I1(JL),I2(JL),I3(JL))
- ENDDO
-!
-! PACK : done
-! Prepare computations
-!
- ALLOCATE( ZLSFACT (INEGT) )
- ALLOCATE( ZLVFACT (INEGT) )
- ALLOCATE( ZSI (INEGT) )
- ALLOCATE( ZTCELSIUS (INEGT) )
- ALLOCATE( ZLBDAC (INEGT) )
-!
- ALLOCATE( ZZW (INEGT) ) ; ZZW(:) = 0.0
- ALLOCATE( ZZX (INEGT) ) ; ZZX(:) = 0.0
- ALLOCATE( ZZY (INEGT) ) ; ZZY(:) = 0.0
-!
- ZTCELSIUS(:) = ZZT(:)-XTT ! T [°C]
- ZZW(:) = ZEXNREF(:)*( XCPD+XCPV*ZRVT(:)+XCL*(ZRCT(:)+ZRRT(:)) &
- +XCI*(ZRIT(:)+ZRST(:)+ZRGT(:)) )
- ZLSFACT(:) = (XLSTT+(XCPV-XCI)*ZTCELSIUS(:))/ZZW(:) ! L_s/(Pi_ref*C_ph)
- ZLVFACT(:) = (XLVTT+(XCPV-XCL)*ZTCELSIUS(:))/ZZW(:) ! L_v/(Pi_ref*C_ph)
-!
- ZZW(:) = EXP( XALPI - XBETAI/ZZT(:) - XGAMI*ALOG(ZZT(:) ) ) ! es_i
- ZSI(:) = ZRVT(:)*(ZPRES(:)-ZZW(:))/((XMV/XMD)*ZZW(:)) ! Saturation over ice
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 2. Haze homogeneous freezing
-! ------------------------
-!
-!
-! Compute the haze homogeneous nucleation source: RHHONI
-!
- IF( OHHONI .AND. NMOD_CCN.GT.0 ) THEN
-
-! Sum of the available CCN
- ALLOCATE( ZFREECCN(INEGT) )
- ALLOCATE( ZCCNFROZEN(INEGT) )
- ZFREECCN(:)=0.
- ZCCNFROZEN(:)=0.
- DO JMOD_CCN = 1, NMOD_CCN
- ZFREECCN(:) = ZFREECCN(:) + ZNFS(:,JMOD_CCN)
- END DO
-!
- ALLOCATE(ZW_NU(INEGT))
- DO JL=1,INEGT
- ZW_NU(JL) = PW_NU(I1(JL),I2(JL),I3(JL))
- END DO
-!
- ZZW(:) = 0.0
- ZZX(:) = 0.0
- ZEPS = XMV / XMD
- ZZY(:) = XCRITSAT1_HONH - & ! Critical Sat.
- (MIN( XTMAX_HONH,MAX( XTMIN_HONH,ZZT(:) ) )/XCRITSAT2_HONH)
-!
- ALLOCATE(ZLS(INEGT))
- ALLOCATE(ZPSI1(INEGT))
- ALLOCATE(ZPSI2(INEGT))
- ALLOCATE(ZTAU(INEGT))
- ALLOCATE(ZBFACT(INEGT))
-!
- WHERE( (ZZT(:)<XTT-35.0) .AND. (ZSI(:)>ZZY(:)) )
- ZLS(:) = XLSTT+(XCPV-XCI)*ZTCELSIUS(:) ! Ls
-!
- ZPSI1(:) = ZZY(:) * (XG/(XRD*ZZT(:)))*(ZEPS*ZLS(:)/(XCPD*ZZT(:))-1.)
-! ! Psi1 (a1*Scr in KL01)
-! BV correction PSI2 enlever 1/ZEPS ?
-! ZPSI2(:) = ZSI(:) * (1.0/ZEPS+1.0/ZRVT(:)) + &
- ZPSI2(:) = ZSI(:) * (1.0/ZRVT(:)) + &
- ZZY(:) * ((ZLS(:)/ZZT(:))**2)/(XCPD*XRV)
-! ! Psi2 (a2+a3*Scr in KL01)
- ZTAU(:) = 1.0 / ( MAX( XC1_HONH,XC1_HONH*(XC2_HONH-XC3_HONH*ZZT(:)) ) *&
- ABS( (XDLNJODT1_HONH - XDLNJODT2_HONH*ZZT(:)) * &
- ((ZPRES(:)/XP00)**(XRD/XCPD))*ZTHS(:) ) )
-!
- ZBFACT(:) = (XRHOI_HONH/ZRHODREF(:)) * (ZSI(:)/(ZZY(:)-1.0)) &
-! BV correction ZBFACT enlever 1/ZEPS ?
-! * (1.0/ZRVT(:)+1.0/ZEPS) &
- * (1.0/ZRVT(:)) &
- / (XCOEF_DIFVAP_HONH*(ZZT(:)**XCEXP_DIFVAP_HONH /ZPRES(:)))
-!
-! BV correction ZZX rho_i{-1} ?
-! ZZX(:) = MAX( MIN( XRHOI_HONH*ZBFACT(:)**1.5 * (ZPSI1(:)/ZPSI2(:)) &
- ZZX(:) = MAX( MIN( (1/XRHOI_HONH)*ZBFACT(:)**1.5 * (ZPSI1(:)/ZPSI2(:)) &
-! BV correction ZZX PTSTEP wrong place ?
-! * (ZW_NU(:)/SQRT(ZTAU(:))), ZNFS(:,JMOD_CCN) )/PTSTEP , 0.)
- * (ZW_NU(:)/SQRT(ZTAU(:)))/PTSTEP , ZFREECCN(:) ) , 0.)
-!
- ZZW(:) = MIN( XRCOEF_HONH*ZZX(:)*(ZTAU(:)/ZBFACT(:))**1.5 , ZRVS(:) )
- END WHERE
-!
-! Apply the changes to ZNFS,
- DO JMOD_CCN = 1, NMOD_CCN
- WHERE(ZFREECCN(:)>1.)
- ZCCNFROZEN(:) = ZZX(:) * ZNFS(:,JMOD_CCN)/ZFREECCN(:)
- ZNFS(:,JMOD_CCN) = ZNFS(:,JMOD_CCN) - ZCCNFROZEN(:)
- END WHERE
- ZW(:,:,:) = PNFS(:,:,:,JMOD_CCN)
- PNFS(:,:,:,JMOD_CCN)=UNPACK( ZNFS(:,JMOD_CCN), MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:))
- END DO
- ZZNHS(:) = ZZNHS(:) + ZZX(:)
- ZNHS(:,:,:) = UNPACK( ZZNHS(:), MASK=GNEGT(:,:,:),FIELD=0.0)
- PNHS(:,:,:) = ZNHS(:,:,:)
-!
- DEALLOCATE(ZFREECCN)
- DEALLOCATE(ZCCNFROZEN)
- DEALLOCATE(ZLS)
- DEALLOCATE(ZPSI1)
- DEALLOCATE(ZPSI2)
- DEALLOCATE(ZTAU)
- DEALLOCATE(ZBFACT)
- DEALLOCATE(ZW_NU)
-!
- ZRVS(:) = ZRVS(:) - ZZW(:)
- ZRIS(:) = ZRIS(:) + ZZW(:)
- ZTHS(:) = ZTHS(:) + ZZW(:) * (ZLSFACT(:)-ZLVFACT(:)) ! f(L_s*(RHHONI))
- ZCIS(:) = ZCIS(:) + ZZX(:)
-!
- END IF ! OHHONI
-!
-! Budget storage
- IF (NBUMOD==KMI .AND. LBU_ENABLE .AND. OHHONI) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GNEGT(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'HONH_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RV) CALL BUDGET_DDH ( &
- UNPACK(ZRVS(:),MASK=GNEGT(:,:,:),FIELD=PRVS)*PRHODJ(:,:,:),&
- 6,'HONH_BU_RRV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GNEGT(:,:,:),FIELD=PRIS)*PRHODJ(:,:,:),&
- 9,'HONH_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH ( UNPACK(ZCIS(:),MASK=GNEGT(:,:,:),FIELD=PCIS)*PRHODJ(:,:,:),&
- 12+NSV_LIMA_NI,'HONH_BU_RSV',YDDDH, YDLDDH, YDMDDH) ! RCI
- IF (NMOD_CCN.GE.1) THEN
- DO JL=1, NMOD_CCN
- CALL BUDGET_DDH ( UNPACK(ZNFS(:,JL),MASK=GNEGT(:,:,:),FIELD=PNFS(:,:,:,JL))*PRHODJ(:,:,:),&
- 12+NSV_LIMA_CCN_FREE+JL-1,'HONH_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END DO
- CALL BUDGET_DDH ( UNPACK(ZZNHS(:),MASK=GNEGT(:,:,:),FIELD=ZNHS(:,:,:))*PRHODJ(:,:,:),&
- 12+NSV_LIMA_HOM_HAZE,'HONH_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
- END IF
- END IF
- END IF
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 3. Cloud droplets homogeneous freezing
-! -----------------------------------
-!
-!
-! Compute the droplet homogeneous nucleation source: RCHONI
-! -> Pruppacher(1995)
-!
- ZZW(:) = 0.0
- ZZX(:) = 0.0
- WHERE( (ZZT(:)<XTT-35.0) .AND. (ZCCT(:)>XCTMIN(2)) .AND. (ZRCT(:)>XRTMIN(2)) )
- ZLBDAC(:) = XLBC*ZCCT(:) / (ZRCT(:)) ! Lambda_c**3
- ZZX(:) = 1.0 / ( 1.0 + (XC_HONC/ZLBDAC(:))*PTSTEP* &
- EXP( XTEXP1_HONC + ZTCELSIUS(:)*( &
- XTEXP2_HONC + ZTCELSIUS(:)*( &
- XTEXP3_HONC + ZTCELSIUS(:)*( &
- XTEXP4_HONC + ZTCELSIUS(:)*XTEXP5_HONC))) ) )**XNUC
- ZZW(:) = ZCCS(:) * (1.0 - ZZX(:)) ! CCHONI
-!
- ZCCS(:) = ZCCS(:) - ZZW(:)
- ZCIS(:) = ZCIS(:) + ZZW(:)
-!
- ZZW(:) = ZRCS(:) * (1.0 - ZZX(:)) ! RCHONI
-!
- ZRCS(:) = ZRCS(:) - ZZW(:)
- ZRIS(:) = ZRIS(:) + ZZW(:)
- ZTHS(:) = ZTHS(:) + ZZW(:) * (ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(RCHONI))
- END WHERE
-!
-! Budget storage
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GNEGT(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'HONC_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH ( &
- UNPACK(ZRCS(:),MASK=GNEGT(:,:,:),FIELD=PRCS)*PRHODJ(:,:,:),&
- 7,'HONC_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GNEGT(:,:,:),FIELD=PRIS)*PRHODJ(:,:,:),&
- 9,'HONC_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH ( UNPACK(ZCCS(:),MASK=GNEGT(:,:,:),FIELD=PCCS)*PRHODJ(:,:,:),&
- 12+NSV_LIMA_NC,'HONC_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH ( UNPACK(ZCIS(:),MASK=GNEGT(:,:,:),FIELD=PCIS)*PRHODJ(:,:,:),&
- 12+NSV_LIMA_NI,'HONC_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
- END IF
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 4. Rain drops homogeneous freezing
-! -------------------------------
-!
-!
-! Compute the drop homogeneous nucleation source: RRHONG
-!
- ZZW(:) = 0.0
- WHERE( (ZZT(:)<XTT-35.0) .AND. (ZRRS(:)>XRTMIN(3)/PTSTEP) )
- ZZW(:) = ZRRS(:) ! Instantaneous freezing of the raindrops
- ZRRS(:) = ZRRS(:) - ZZW(:)
- ZRGS(:) = ZRGS(:) + ZZW(:)
- ZTHS(:) = ZTHS(:) + ZZW(:)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(RRHONG))
-!
- ZCRS(:) = 0.0 ! No more raindrops when T<-35 C
- ENDWHERE
-!
-! Budget storage
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GNEGT(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'HONR_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH ( &
- UNPACK(ZRRS(:),MASK=GNEGT(:,:,:),FIELD=PRRS)*PRHODJ(:,:,:),&
- 8,'HONR_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH ( &
- UNPACK(ZRGS(:),MASK=GNEGT(:,:,:),FIELD=PRGS)*PRHODJ(:,:,:),&
- 11,'HONR_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH ( UNPACK(ZCRS(:),MASK=GNEGT(:,:,:),FIELD=PCRS)*PRHODJ(:,:,:),&
- 12+NSV_LIMA_NR,'HONR_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
- END IF
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 4. Unpack variables, clean
-! -----------------------
-!
-!
-! End of homogeneous nucleation processes
-!
- ZW(:,:,:) = PRVS(:,:,:)
- PRVS(:,:,:) = UNPACK( ZRVS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRCS(:,:,:)
- PRCS(:,:,:) = UNPACK( ZRCS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRRS(:,:,:)
- PRRS(:,:,:) = UNPACK( ZRRS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRIS(:,:,:)
- PRIS(:,:,:) = UNPACK( ZRIS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRGS(:,:,:)
- PRGS(:,:,:) = UNPACK( ZRGS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PTHS(:,:,:)
- PTHS(:,:,:) = UNPACK( ZTHS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PCCS(:,:,:)
- PCCS(:,:,:) = UNPACK( ZCCS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PCRS(:,:,:)
- PCRS(:,:,:) = UNPACK( ZCRS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PCIS(:,:,:)
- PCIS(:,:,:) = UNPACK( ZCIS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
-!
- DEALLOCATE(ZRVT)
- DEALLOCATE(ZRCT)
- DEALLOCATE(ZRRT)
- DEALLOCATE(ZRIT)
- DEALLOCATE(ZRST)
- DEALLOCATE(ZRGT)
-!
- DEALLOCATE(ZCCT)
-!
- DEALLOCATE(ZRVS)
- DEALLOCATE(ZRCS)
- DEALLOCATE(ZRRS)
- DEALLOCATE(ZRIS)
- DEALLOCATE(ZRGS)
-!
- DEALLOCATE(ZTHS)
-!
- DEALLOCATE(ZCCS)
- DEALLOCATE(ZCRS)
- DEALLOCATE(ZCIS)
-!
- DEALLOCATE(ZNFS)
- DEALLOCATE(ZNIS)
- DEALLOCATE(ZZNHS)
-!
- DEALLOCATE(ZRHODREF)
- DEALLOCATE(ZZT)
- DEALLOCATE(ZPRES)
- DEALLOCATE(ZEXNREF)
-!
- DEALLOCATE(ZLSFACT)
- DEALLOCATE(ZLVFACT)
- DEALLOCATE(ZSI)
- DEALLOCATE(ZTCELSIUS)
- DEALLOCATE(ZLBDAC)
-!
- DEALLOCATE(ZZW)
- DEALLOCATE(ZZX)
- DEALLOCATE(ZZY)
-!
-ELSE
-!
-! Advance the budget calls
-!
-
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF ( OHHONI ) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'HONH_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RV) CALL BUDGET_DDH (PRVS(:,:,:)*PRHODJ(:,:,:),6,'HONH_BU_RRV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9,'HONH_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH (PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'HONH_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- IF (NMOD_CCN.GE.1) THEN
- DO JL=1, NMOD_CCN
- CALL BUDGET_DDH ( UNPACK(ZNFS(:,JL),MASK=GNEGT(:,:,:),FIELD=PNFS(:,:,:,JL))*PRHODJ(:,:,:),&
- & 12+NSV_LIMA_CCN_FREE+JL-1,'HONH_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END DO
- CALL BUDGET_DDH (ZNHS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_HOM_HAZE,'HONH_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
- END IF
- END IF
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'HONC_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:),7,'HONC_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9,'HONC_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH (PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,'HONC_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'HONC_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'HONR_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH (PRRS(:,:,:)*PRHODJ(:,:,:),8,'HONR_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH (PRGS(:,:,:)*PRHODJ(:,:,:),11,'HONR_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCRS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NR,'HONR_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
-
-
-
-
- END IF
-!
-END IF ! INEGT>0
-!
-!
-!-------------------------------------------------------------------------------
-!
-END SUBROUTINE LIMA_COLD_HOM_NUCL
diff --git a/src/arome/micro/lima_cold_sedimentation.F90 b/src/arome/micro/lima_cold_sedimentation.F90
deleted file mode 100644
index 635a0d931..000000000
--- a/src/arome/micro/lima_cold_sedimentation.F90
+++ /dev/null
@@ -1,383 +0,0 @@
-! ###################################
- MODULE MODI_LIMA_COLD_SEDIMENTATION
-! ###################################
-!
-INTERFACE
- SUBROUTINE LIMA_COLD_SEDIMENTATION (OSEDI, KSPLITG, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, &
- PZZ, PRHODJ, PRHODREF, &
- PRIT, PCIT, &
- PRIS, PRSS, PRGS, PRHS, PCIS, &
- PINPRS, PINPRG, PINPRH )
-!
-LOGICAL, INTENT(IN) :: OSEDI ! switch to activate the
- ! cloud ice sedimentation
-INTEGER, INTENT(IN) :: KSPLITG ! Number of small time step
- ! for ice sedimendation
-REAL, INTENT(IN) :: PTSTEP ! Time step
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the FM file output
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian (Budgets)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Cloud ice m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCIT ! Ice crystal C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRSS ! Snow/aggregate m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRGS ! Graupel m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRHS ! Hail m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIS ! Ice crystal C. source
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRS ! Snow instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRG ! Graupel instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRH ! Hail instant precip
-
-!
- END SUBROUTINE LIMA_COLD_SEDIMENTATION
-END INTERFACE
-END MODULE MODI_LIMA_COLD_SEDIMENTATION
-!
-!
-! ######################################################################
- SUBROUTINE LIMA_COLD_SEDIMENTATION (OSEDI, KSPLITG, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, &
- PZZ, PRHODJ, PRHODREF, &
- PRIT, PCIT, &
- PRIS, PRSS, PRGS, PRHS, PCIS, &
- PINPRS,PINPRG,PINPRH )
-! ######################################################################
-!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the sediimentation
-!! of primary ice, snow and graupel.
-!!
-!! METHOD
-!! ------
-!! The sedimentation rates are computed with a time spliting technique:
-!! an upstream scheme, written as a difference of non-advective fluxes.
-!! This source term is added to the next coming time step (split-implicit
-!! process).
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!! C. Barthe * LACy * jan. 2014 add budgets
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_PARAM_LIMA_COLD, ONLY : XLBEXI, XLBI, XDI, &
- XFSEDRI, XFSEDCI, XFSEDS, XEXSEDS
-USE MODD_PARAM_LIMA_MIXED, ONLY : XFSEDG, XEXSEDG, XFSEDH, XEXSEDH
-USE MODD_PARAM_LIMA, ONLY : XCEXVT, XRTMIN, XCTMIN
-USE MODD_CST, ONLY : XRHOLW
-USE MODD_PARAMETERS, ONLY : JPHEXT, JPVEXT
-USE MODI_LIMA_FUNCTIONS, ONLY : COUNTJV
-!
-USE MODD_NSV
-
-IMPLICIT NONE
-
-!
-!* 0.1 Declarations of dummy arguments :
-!
-LOGICAL, INTENT(IN) :: OSEDI ! switch to activate the
- ! cloud ice sedimentation
-INTEGER, INTENT(IN) :: KSPLITG ! Number of small time step
- ! for ice sedimendation
-REAL, INTENT(IN) :: PTSTEP ! Time step
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the FM file output
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian (Budgets)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Cloud ice m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCIT ! Ice crystal C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRSS ! Snow/aggregate m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRGS ! Graupel m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRHS ! Hail m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIS ! Ice crystal C. source
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRS ! Snow instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRG ! Graupel instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRH ! Hail instant precip
-
-!
-!* 0.2 Declarations of local variables :
-!
-INTEGER :: JK, JL, JN ! Loop index
-INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE ! Physical domain
-INTEGER :: ISEDIM ! Case number of sedimentation
-!
-LOGICAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: GSEDIM ! Test where to compute the SED processes
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: ZW ! Work array
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)+1) &
- :: ZWSEDR, & ! Sedimentation of MMR
- ZWSEDC ! Sedimentation of number conc.
-!
-REAL, DIMENSION(:), ALLOCATABLE &
- :: ZRIS, & ! Pristine ice m.r. source
- ZCIS, & ! Pristine ice conc. source
- ZRSS, & ! Snow/aggregate m.r. source
- ZRGS, & ! Graupel/hail m.r. source
- ZRHS, & ! Graupel/hail m.r. source
- ZRIT, & ! Pristine ice m.r. at t
- ZCIT, & ! Pristine ice conc. at t
- ZRHODREF, & ! RHO Dry REFerence
- ZRHODJ, & ! RHO times Jacobian
- ZZW, & ! Work array
- ZZX, & ! Work array
- ZZY, & ! Work array
- ZLBDAI, & ! Slope parameter of the ice crystal distr.
- ZRTMIN
-!
-INTEGER , DIMENSION(SIZE(PRHODREF)) :: I1,I2,I3 ! Indexes for PACK replacement
-!
-REAL :: ZTSPLITG ! Small time step for rain sedimentation
-!
-INTEGER :: IKMAX
-!
-!!!!!!!!!!! Entiers pour niveaux inversés dans AROME !!!!!!!!!!!!!!!!!!!!!!!!!!!
-INTEGER :: IBOTTOM, INVLVL
-!
-!-------------------------------------------------------------------------------
-!
-! Physical domain
-!
-IIB=1+JPHEXT
-IIE=SIZE(PZZ,1) - JPHEXT
-IJB=1+JPHEXT
-IJE=SIZE(PZZ,2) - JPHEXT
-IKB=1+JPVEXT
-IKE=SIZE(PZZ,3) - JPVEXT
-!
-!!!!!!!!!!! Entiers pour niveaux inversés dans AROME !!!!!!!!!!!!!!!!!!!!!!!!!!!
-IBOTTOM=IKE
-INVLVL=-1
-!
-ZWSEDR(:,:,:)=0.
-ZWSEDC(:,:,:)=0.
-IKMAX=SIZE(PRHODREF,3)
-!
-! Time splitting and ZRTMIN
-!
-ALLOCATE(ZRTMIN(SIZE(XRTMIN)))
-ZRTMIN(:) = XRTMIN(:) / PTSTEP
-!
-ZTSPLITG= PTSTEP / FLOAT(KSPLITG)
-!
-PINPRS(:,:) = 0.
-PINPRG(:,:) = 0.
-PINPRH(:,:) = 0.
-!
-! ################################
-! Compute the sedimentation fluxes
-! ################################
-!
-DO JN = 1 , KSPLITG
- ! Computation only where enough ice, snow, graupel or hail
- GSEDIM(:,:,:) = .FALSE.
- GSEDIM(IIB:IIE,IJB:IJE,IKB:IKE) = PRSS(IIB:IIE,IJB:IJE,IKB:IKE)>ZRTMIN(5) &
- .OR. PRGS(IIB:IIE,IJB:IJE,IKB:IKE)>ZRTMIN(6) &
- .OR. PRHS(IIB:IIE,IJB:IJE,IKB:IKE)>ZRTMIN(7)
- IF( OSEDI ) THEN
- GSEDIM(IIB:IIE,IJB:IJE,IKB:IKE) = GSEDIM(IIB:IIE,IJB:IJE,IKB:IKE) &
- .OR. PRIS(IIB:IIE,IJB:IJE,IKB:IKE)>ZRTMIN(4)
- END IF
-!
- ISEDIM = COUNTJV( GSEDIM(:,:,:),I1(:),I2(:),I3(:))
- IF( ISEDIM >= 1 ) THEN
-!
- IF( JN==1 ) THEN
- IF( OSEDI ) THEN
- PCIS(:,:,:) = PCIS(:,:,:) * PTSTEP
- PRIS(:,:,:) = PRIS(:,:,:) * PTSTEP
- END IF
- PRSS(:,:,:) = PRSS(:,:,:) * PTSTEP
- PRGS(:,:,:) = PRGS(:,:,:) * PTSTEP
- PRHS(:,:,:) = PRHS(:,:,:) * PTSTEP
- DO JK = IKB , IKE
-!Dans AROME, PZZ = épaisseur de la couche
-! ZW(:,:,JK)=ZTSPLITG/(PZZ(:,:,JK+1)-PZZ(:,:,JK))
- ZW(:,:,JK)=ZTSPLITG/(PZZ(:,:,JK))
- END DO
- END IF
-!
- ALLOCATE(ZRHODREF(ISEDIM))
- DO JL = 1,ISEDIM
- ZRHODREF(JL) = PRHODREF(I1(JL),I2(JL),I3(JL))
- END DO
-!
- ALLOCATE(ZZW(ISEDIM)) ; ZZW(:) = 0.0
- ALLOCATE(ZZX(ISEDIM)) ; ZZX(:) = 0.0
- ALLOCATE(ZZY(ISEDIM)) ; ZZY(:) = 0.0
-!
-!* 2.21 for pristine ice
-!
- IF( OSEDI.AND.MAXVAL(PRIS(:,:,:))>ZRTMIN(4) ) THEN
- ALLOCATE(ZRIS(ISEDIM))
- ALLOCATE(ZCIS(ISEDIM))
- ALLOCATE(ZRIT(ISEDIM))
- ALLOCATE(ZCIT(ISEDIM))
- ALLOCATE(ZLBDAI(ISEDIM))
- DO JL = 1,ISEDIM
- ZRIS(JL) = PRIS(I1(JL),I2(JL),I3(JL))
- ZCIS(JL) = PCIS(I1(JL),I2(JL),I3(JL))
- ZRIT(JL) = PRIT(I1(JL),I2(JL),I3(JL))
- ZCIT(JL) = PCIT(I1(JL),I2(JL),I3(JL))
- END DO
- ZLBDAI(:) = 1.E10
- WHERE (ZRIT(:)>XRTMIN(4) .AND. ZCIT(:)>XCTMIN(4))
- ZLBDAI(:) = ( XLBI*ZCIT(:) / ZRIT(:) )**XLBEXI
- END WHERE
- WHERE( ZRIS(:)>ZRTMIN(4) )
- ZZY(:) = ZRHODREF(:)**(-XCEXVT) * ZLBDAI(:)**(-XDI)
- ZZW(:) = XFSEDRI * ZRIS(:) * ZZY(:) * ZRHODREF(:)
- ZZX(:) = XFSEDCI * ZCIS(:) * ZZY(:) * ZRHODREF(:)
- END WHERE
- ZWSEDR(:,:,1:IKMAX) = UNPACK( ZZW(:),MASK=GSEDIM(:,:,:),FIELD=0.0 )
- ZWSEDC(:,:,1:IKMAX) = UNPACK( ZZX(:),MASK=GSEDIM(:,:,:),FIELD=0.0 )
- DO JK = IKB+1 , IKE
- PRIS(:,:,JK) = PRIS(:,:,JK) + ZW(:,:,JK)* &
- (ZWSEDR(:,:,JK+1*INVLVL)-ZWSEDR(:,:,JK))/PRHODREF(:,:,JK)
- PCIS(:,:,JK) = PCIS(:,:,JK) + ZW(:,:,JK)* &
- (ZWSEDC(:,:,JK+1*INVLVL)-ZWSEDC(:,:,JK))/PRHODREF(:,:,JK)
- END DO
- PRIS(:,:,1) = PRIS(:,:,1) + ZW(:,:,1)* &
- (0.-ZWSEDR(:,:,1))/PRHODREF(:,:,1)
- PCIS(:,:,1) = PCIS(:,:,1) + ZW(:,:,1)* &
- (0.-ZWSEDC(:,:,1))/PRHODREF(:,:,1)
- DEALLOCATE(ZRIS)
- DEALLOCATE(ZCIS)
- DEALLOCATE(ZRIT)
- DEALLOCATE(ZCIT)
- DEALLOCATE(ZLBDAI)
- END IF
-!
-!* 2.22 for aggregates
-!
- ZZW(:) = 0.
- IF( MAXVAL(PRSS(:,:,:))>ZRTMIN(5) ) THEN
- ALLOCATE(ZRSS(ISEDIM))
- DO JL = 1,ISEDIM
- ZRSS(JL) = PRSS(I1(JL),I2(JL),I3(JL))
- END DO
- WHERE( ZRSS(:)>ZRTMIN(5) )
-! Correction BVIE ZRHODREF
-! ZZW(:) = XFSEDS * ZRSS(:)**XEXSEDS * ZRHODREF(:)**(XEXSEDS-XCEXVT)
- ZZW(:) = XFSEDS * ZRSS(:)**XEXSEDS * ZRHODREF(:)**(-XCEXVT) * ZRHODREF(:)
- END WHERE
- ZWSEDR(:,:,1:IKMAX) = UNPACK( ZZW(:),MASK=GSEDIM(:,:,:),FIELD=0.0 )
- DO JK = IKB+1 , IKE
- PRSS(:,:,JK) = PRSS(:,:,JK) + ZW(:,:,JK)* &
- (ZWSEDR(:,:,JK+1*INVLVL)-ZWSEDR(:,:,JK))/PRHODREF(:,:,JK)
- END DO
- PRSS(:,:,1) = PRSS(:,:,1) + ZW(:,:,1)* &
- (0.-ZWSEDR(:,:,1))/PRHODREF(:,:,1)
- DEALLOCATE(ZRSS)
- ELSE
- ZWSEDR(:,:,IBOTTOM) = 0.0
- END IF
-!
- PINPRS(:,:) = PINPRS(:,:) + ZWSEDR(:,:,IBOTTOM)/XRHOLW/KSPLITG ! in m/s
-!
-!* 2.23 for graupeln
-!
- ZZW(:) = 0.
- IF( MAXVAL(PRGS(:,:,:))>ZRTMIN(6) ) THEN
- ALLOCATE(ZRGS(ISEDIM))
- DO JL = 1,ISEDIM
- ZRGS(JL) = PRGS(I1(JL),I2(JL),I3(JL))
- END DO
- WHERE( ZRGS(:)>ZRTMIN(6) )
-! Correction BVIE ZRHODREF
-! ZZW(:) = XFSEDG * ZRGS(:)**XEXSEDG * ZRHODREF(:)**(XEXSEDG-XCEXVT)
- ZZW(:) = XFSEDG * ZRGS(:)**XEXSEDG * ZRHODREF(:)**(-XCEXVT) * ZRHODREF(:)
- END WHERE
- ZWSEDR(:,:,1:IKMAX) = UNPACK( ZZW(:),MASK=GSEDIM(:,:,:),FIELD=0.0 )
- DO JK = IKB+1 , IKE
- PRGS(:,:,JK) = PRGS(:,:,JK) + ZW(:,:,JK)* &
- (ZWSEDR(:,:,JK+1*INVLVL)-ZWSEDR(:,:,JK))/PRHODREF(:,:,JK)
- END DO
- PRGS(:,:,1) = PRGS(:,:,1) + ZW(:,:,1)* &
- (0.-ZWSEDR(:,:,1))/PRHODREF(:,:,1)
- DEALLOCATE(ZRGS)
- ELSE
- ZWSEDR(:,:,IBOTTOM) = 0.0
- END IF
-!
- PINPRG(:,:) = PINPRG(:,:) + ZWSEDR(:,:,IBOTTOM)/XRHOLW/KSPLITG ! in m/s
-!
-!* 2.23 for hail
-!
- ZZW(:) = 0.
- IF( MAXVAL(PRHS(:,:,:))>ZRTMIN(7) ) THEN
- ALLOCATE(ZRHS(ISEDIM))
- DO JL = 1,ISEDIM
- ZRHS(JL) = PRHS(I1(JL),I2(JL),I3(JL))
- END DO
- WHERE( ZRHS(:)>ZRTMIN(7) )
-! Correction BVIE ZRHODREF
-! ZZW(:) = XFSEDH * ZRHS(:)**XEXSEDH * ZRHODREF(:)**(XEXSEDH-XCEXVT)
- ZZW(:) = XFSEDH * ZRHS(:)**XEXSEDH * ZRHODREF(:)**(-XCEXVT) * ZRHODREF(:)
- END WHERE
- ZWSEDR(:,:,1:IKMAX) = UNPACK( ZZW(:),MASK=GSEDIM(:,:,:),FIELD=0.0 )
- DO JK = IKB+1 , IKE
- PRHS(:,:,JK) = PRHS(:,:,JK) + ZW(:,:,JK)* &
- (ZWSEDR(:,:,JK+1*INVLVL)-ZWSEDR(:,:,JK))/PRHODREF(:,:,JK)
- END DO
- PRHS(:,:,1) = PRHS(:,:,1) + ZW(:,:,1)* &
- (0.-ZWSEDR(:,:,1))/PRHODREF(:,:,1)
- DEALLOCATE(ZRHS)
- ELSE
- ZWSEDR(:,:,IBOTTOM) = 0.0
- END IF
-!
- PINPRH(:,:) = PINPRH(:,:) + ZWSEDR(:,:,IBOTTOM)/XRHOLW/KSPLITG ! in m/s
-!
-!* 2.24 End of sedimentation
-!
- DEALLOCATE(ZRHODREF)
- DEALLOCATE(ZZW)
- DEALLOCATE(ZZX)
- DEALLOCATE(ZZY)
- IF( JN==KSPLITG ) THEN
- IF( OSEDI ) THEN
- PRIS(:,:,:) = PRIS(:,:,:) / PTSTEP
- PCIS(:,:,:) = PCIS(:,:,:) / PTSTEP
- END IF
- PRSS(:,:,:) = PRSS(:,:,:) / PTSTEP
- PRGS(:,:,:) = PRGS(:,:,:) / PTSTEP
- PRHS(:,:,:) = PRHS(:,:,:) / PTSTEP
- END IF
- END IF
-END DO
-!
-DEALLOCATE(ZRTMIN)
-!
-END SUBROUTINE LIMA_COLD_SEDIMENTATION
-!
-!-------------------------------------------------------------------------------
diff --git a/src/arome/micro/lima_cold_slow_processes.F90 b/src/arome/micro/lima_cold_slow_processes.F90
deleted file mode 100644
index a342f7d22..000000000
--- a/src/arome/micro/lima_cold_slow_processes.F90
+++ /dev/null
@@ -1,583 +0,0 @@
-! #####################
- MODULE MODI_LIMA_COLD_SLOW_PROCESSES
-! #####################
-!
-INTERFACE
- SUBROUTINE LIMA_COLD_SLOW_PROCESSES (PTSTEP, KMI, HFMFILE, HLUOUT, &
- OCLOSE_OUT, PZZ, PRHODJ, &
- PRHODREF, PEXNREF, PPABST, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
- PTHS, PRVS, PRIS, PRSS, &
- PCIT, PCIS, &
- YDDDH, YDLDDH, YDMDDH )
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-REAL, INTENT(IN) :: PTSTEP ! Time step
-INTEGER, INTENT(IN) :: KMI ! Model index
-!
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Cloud ice m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGT ! Graupel m.r. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRSS ! Snow/aggregate m.r. source
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCIT ! Ice crystal C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIS ! Ice crystal C. source
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-
-END SUBROUTINE LIMA_COLD_SLOW_PROCESSES
-END INTERFACE
-END MODULE MODI_LIMA_COLD_SLOW_PROCESSES
-!
-! ######################################################################
- SUBROUTINE LIMA_COLD_SLOW_PROCESSES (PTSTEP, KMI, HFMFILE, HLUOUT, &
- OCLOSE_OUT, PZZ, PRHODJ, &
- PRHODREF, PEXNREF, PPABST, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
- PTHS, PRVS, PRIS, PRSS, &
- PCIT, PCIS, &
- YDDDH, YDLDDH, YDMDDH )
-! ######################################################################
-!
-!! 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)
-!! - aggregation of ice on snow
-!!
-!!
-!! REFERENCE
-!! ---------
-!!
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!! C. Barthe * LACy * jan. 2014 add budgets
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_PARAMETERS, ONLY : JPHEXT, JPVEXT
-USE MODD_CST, ONLY : XP00, XRD, XRV, XMV, XMD, XCPD, XCPV, &
- XCL, XCI, XTT, XLSTT, XALPI, XBETAI, XGAMI
-USE MODD_PARAM_LIMA, ONLY : LSNOW_LIMA, XRTMIN, XCTMIN, XALPHAI, XALPHAS, &
- XNUI
-USE MODD_PARAM_LIMA_COLD, ONLY : XLBI, XLBEXI, XLBS, XLBEXS, XBI, 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
-USE MODI_LIMA_FUNCTIONS, ONLY : COUNTJV
-USE MODD_BUDGET
-USE MODD_NSV, ONLY : NSV_LIMA_NI
-USE MODE_BUDGET, ONLY: BUDGET_DDH
-
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-REAL, INTENT(IN) :: PTSTEP ! Time step
-INTEGER, INTENT(IN) :: KMI ! Model index
-!
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Cloud ice m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGT ! Graupel m.r. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRSS ! Snow/aggregate m.r. source
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCIT ! Ice crystal C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIS ! Ice crystal C. source
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-!* 0.2 Declarations of local variables :
-!
-LOGICAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: GMICRO ! Computations only where necessary
-INTEGER :: IMICRO
-INTEGER , DIMENSION(SIZE(GMICRO)) :: I1,I2,I3 ! Used to replace PACK
-INTEGER :: JL ! and PACK intrinsics
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRRT ! Rain water m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRIT ! Pristine ice m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRGT ! Graupel/hail m.r. at t
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZCIT ! Pristine ice conc. at t
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVS ! Water vapor m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRSS ! Snow/aggregate m.r. source
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZTHS ! Theta source
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZCIS ! Pristine ice conc. source
-!
-REAL, DIMENSION(:), ALLOCATABLE &
- :: ZRHODREF, & ! RHO Dry REFerence
- ZRHODJ, & ! RHO times Jacobian
- ZZT, & ! Temperature
- ZPRES, & ! Pressure
- ZEXNREF, & ! EXNer Pressure REFerence
- ZZW, & ! Work array
- ZZX, & ! Work array
- ZLSFACT, & ! L_s/(Pi_ref*C_ph)
- ZSSI, & ! Supersaturation over ice
- ZLBDAI, & ! Slope parameter of the ice crystal distr.
- ZLBDAS, & ! Slope parameter of the aggregate distr.
- ZAI, & ! Thermodynamical function
- ZCJ, & ! used to compute the ventilation coefficient
- ZKA, & ! Thermal conductivity of the air
- ZDV, & ! Diffusivity of water vapor in the air
- ZVISCA ! Viscosity of air
-!
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZZW1 ! Work arrays
-!
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: ZT, ZW ! Temperature
-!
-INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE ! Physical domain
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZRTMIN, ZCTMIN
-!
-!-------------------------------------------------------------------------------
-!
-! Physical domain
-!
-IIB=1+JPHEXT
-IIE=SIZE(PZZ,1) - JPHEXT
-IJB=1+JPHEXT
-IJE=SIZE(PZZ,2) - JPHEXT
-IKB=1+JPVEXT
-IKE=SIZE(PZZ,3) - JPVEXT
-!
-! Physical limitations
-!
-ALLOCATE(ZRTMIN(SIZE(XRTMIN)))
-ALLOCATE(ZCTMIN(SIZE(XCTMIN)))
-ZRTMIN(:) = XRTMIN(:) / PTSTEP
-ZCTMIN(:) = XCTMIN(:) / PTSTEP
-!
-! Temperature
-ZT(:,:,:) = PTHT(:,:,:) * ( PPABST(:,:,:)/XP00 ) ** (XRD/XCPD)
-!
-! Looking for regions where computations are necessary
-!
-GMICRO(:,:,:) = .FALSE.
-GMICRO(IIB:IIE,IJB:IJE,IKB:IKE) = &
- PRIT(IIB:IIE,IJB:IJE,IKB:IKE)>XRTMIN(4) .OR. &
- PRST(IIB:IIE,IJB:IJE,IKB:IKE)>XRTMIN(5)
-!
-IMICRO = COUNTJV( GMICRO(:,:,:),I1(:),I2(:),I3(:))
-!
-IF( IMICRO >= 1 ) THEN
-!
-!------------------------------------------------------------------------------
-!
-!
-!* 1. Optimization : packing variables
-! --------------------------------
-!
-!
-!
- ALLOCATE(ZRVT(IMICRO))
- ALLOCATE(ZRCT(IMICRO))
- ALLOCATE(ZRRT(IMICRO))
- ALLOCATE(ZRIT(IMICRO))
- ALLOCATE(ZRST(IMICRO))
- ALLOCATE(ZRGT(IMICRO))
-!
- ALLOCATE(ZCIT(IMICRO))
-!
- ALLOCATE(ZRVS(IMICRO))
- ALLOCATE(ZRIS(IMICRO))
- ALLOCATE(ZRSS(IMICRO))
-!
- ALLOCATE(ZTHS(IMICRO))
-!
- ALLOCATE(ZCIS(IMICRO))
-!
- ALLOCATE(ZRHODREF(IMICRO))
- ALLOCATE(ZZT(IMICRO))
- ALLOCATE(ZPRES(IMICRO))
- ALLOCATE(ZEXNREF(IMICRO))
- DO JL=1,IMICRO
- ZRVT(JL) = PRVT(I1(JL),I2(JL),I3(JL))
- ZRCT(JL) = PRCT(I1(JL),I2(JL),I3(JL))
- ZRRT(JL) = PRRT(I1(JL),I2(JL),I3(JL))
- ZRIT(JL) = PRIT(I1(JL),I2(JL),I3(JL))
- ZRST(JL) = PRST(I1(JL),I2(JL),I3(JL))
- ZRGT(JL) = PRGT(I1(JL),I2(JL),I3(JL))
-!
- ZCIT(JL) = PCIT(I1(JL),I2(JL),I3(JL))
-!
- ZRVS(JL) = PRVS(I1(JL),I2(JL),I3(JL))
- ZRIS(JL) = PRIS(I1(JL),I2(JL),I3(JL))
- ZRSS(JL) = PRSS(I1(JL),I2(JL),I3(JL))
-!
- ZTHS(JL) = PTHS(I1(JL),I2(JL),I3(JL))
-!
- ZCIS(JL) = PCIS(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) = PPABST(I1(JL),I2(JL),I3(JL))
- ZEXNREF(JL) = PEXNREF(I1(JL),I2(JL),I3(JL))
- ENDDO
-!
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- ALLOCATE(ZRHODJ(IMICRO))
- ZRHODJ(:) = PACK( PRHODJ(:,:,:),MASK=GMICRO(:,:,:) )
- END IF
-!
-!
-!------------------------------------------------------------------------------
-!
-!
-!* 2. Microphysical computations
-! --------------------------
-!
-!
- ALLOCATE(ZZW(IMICRO))
- ALLOCATE(ZZX(IMICRO))
- ALLOCATE(ZLSFACT(IMICRO))
- ALLOCATE(ZSSI(IMICRO))
- ALLOCATE(ZLBDAI(IMICRO))
- ALLOCATE(ZLBDAS(IMICRO))
- ALLOCATE(ZAI(IMICRO))
- ALLOCATE(ZCJ(IMICRO))
- ALLOCATE(ZKA(IMICRO))
- ALLOCATE(ZDV(IMICRO))
- ALLOCATE(ZZW1(IMICRO,7))
-!
-! Preliminary computations
-!
- ZZW(:) = ZEXNREF(:)*( XCPD+XCPV*ZRVT(:)+XCL*(ZRCT(:)+ZRRT(:)) &
- +XCI*(ZRIT(:)+ZRST(:)+ZRGT(:)) )
-!
- ZLSFACT(:) = (XLSTT+(XCPV-XCI)*(ZZT(:)-XTT))/ZZW(:) ! L_s/(Pi_ref*C_ph)
-!
- ZZW(:) = EXP( XALPI - XBETAI/ZZT(:) - XGAMI*ALOG(ZZT(:) ) )
- ZSSI(:) = ZRVT(:)*( ZPRES(:)-ZZW(:) ) / ( (XMV/XMD) * ZZW(:) ) - 1.0
- ! Supersaturation over ice
-! Distribution parameters for ice and snow
- ZLBDAI(:) = 1.E10
- WHERE (ZRIT(:)>XRTMIN(4) .AND. ZCIT(:)>XCTMIN(4))
- ZLBDAI(:) = ( XLBI*ZCIT(:) / ZRIT(:) )**XLBEXI
- END WHERE
- ZLBDAS(:) = 1.E10
- WHERE (ZRST(:)>XRTMIN(5) )
- ZLBDAS(:) = XLBS*( ZRHODREF(:)*ZRST(:) )**XLBEXS
- END WHERE
-!
- ZKA(:) = 2.38E-2 + 0.0071E-2 * ( ZZT(:) - XTT ) ! k_a
- ZDV(:) = 0.211E-4 * (ZZT(:)/XTT)**1.94 * (XP00/ZPRES(:)) ! D_v
-!
-! Thermodynamical function ZAI = A_i(T,P)
- ZAI(:) = ( XLSTT + (XCPV-XCI)*(ZZT(:)-XTT) )**2 / (ZKA(:)*XRV*ZZT(:)**2) &
- + ( XRV*ZZT(:) ) / (ZDV(:)*ZZW(:))
-! ZCJ = c^prime_j/c_i (in the ventilation factor) ( c_i from v(D)=c_i*D^(d_i) )
- ZCJ(:) = XSCFAC * ZRHODREF(:)**0.3 / SQRT( 1.718E-5+0.0049E-5*(ZZT(:)-XTT) )
-!
-!
-!
-!
-!* 2.1 Conversion of snow to r_i: RSCNVI
-! ----------------------------------------
-!
-!
- WHERE ( ZRST(:)>XRTMIN(5) )
- ZLBDAS(:) = MIN( XLBDAS_MAX, &
- XLBS*( ZRHODREF(:)*MAX( ZRST(:),XRTMIN(5) ) )**XLBEXS )
- END WHERE
- ZZW(:) = 0.0
- WHERE ( ZLBDAS(:)<XLBDASCNVI_MAX .AND. (ZRST(:)>XRTMIN(5)) &
- .AND. (ZSSI(:)<0.0) )
- ZZW(:) = (ZLBDAS(:)*XDSCNVI_LIM)**(XALPHAS)
- ZZX(:) = ( -ZSSI(:)/ZAI(:) ) * (XCCS*ZLBDAS(:)**XCXS) * (ZZW(:)**XNUI) &
- * EXP(-ZZW(:))
-!
-! Correction BVIE RHODREF
-! ZZW(:) = MIN( ( XR0DEPSI+XR1DEPSI*ZCJ(:) )*ZZX(:)/ZRHODREF(:),ZRSS(:) )
- ZZW(:) = MIN( ( XR0DEPSI+XR1DEPSI*ZCJ(:) )*ZZX(:),ZRSS(:) )
- ZRIS(:) = ZRIS(:) + ZZW(:)
- ZRSS(:) = ZRSS(:) - ZZW(:)
-!
- ZZW(:) = ZZW(:)*( XC0DEPSI+XC1DEPSI*ZCJ(:) )/( XR0DEPSI+XR1DEPSI*ZCJ(:) )
- ZCIS(:) = ZCIS(:) + ZZW(:)
- END WHERE
-!
-! Budget storage
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GMICRO(:,:,:),FIELD=PRIS)*PRHODJ(:,:,:),&
- 9,'CNVI_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH ( &
- UNPACK(ZRSS(:),MASK=GMICRO(:,:,:),FIELD=PRSS)*PRHODJ(:,:,:),&
- 10,'CNVI_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH ( &
- UNPACK(ZCIS(:),MASK=GMICRO(:,:,:),FIELD=PCIS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NI,'CNVI_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
-!
-!
-!* 2.2 Deposition of water vapor on r_s: RVDEPS
-! -----------------------------------------------
-!
-!
- ZZW(:) = 0.0
- WHERE ( (ZRST(:)>XRTMIN(5)) .AND. (ZRSS(:)>ZRTMIN(5)) )
-!Correction BVIE rhodref
-! ZZW(:) = ( ZSSI(:)/(ZRHODREF(:)*ZAI(:)) ) * &
- ZZW(:) = ( ZSSI(:)/(ZAI(:)) ) * &
- ( X0DEPS*ZLBDAS(:)**XEX0DEPS + X1DEPS*ZCJ(:)*ZLBDAS(:)**XEX1DEPS )
- ZZW(:) = MIN( ZRVS(:),ZZW(:) )*(0.5+SIGN(0.5,ZZW(:))) &
- - MIN( ZRSS(:),ABS(ZZW(:)) )*(0.5-SIGN(0.5,ZZW(:)))
- ZRSS(:) = ZRSS(:) + ZZW(:)
- ZRVS(:) = ZRVS(:) - ZZW(:)
- ZTHS(:) = ZTHS(:) + ZZW(:)*ZLSFACT(:)
- END WHERE
-!
-! Budget storage
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'DEPS_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RV) CALL BUDGET_DDH ( &
- UNPACK(ZRVS(:),MASK=GMICRO(:,:,:),FIELD=PRVS)*PRHODJ(:,:,:),&
- 6,'DEPS_BU_RRV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH ( &
- UNPACK(ZRSS(:),MASK=GMICRO(:,:,:),FIELD=PRSS)*PRHODJ(:,:,:),&
- 10,'DEPS_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- END IF
-!
-!
-!* 2.3 Conversion of pristine ice to r_s: RICNVS
-! ------------------------------------------------
-!
-!
- ZZW(:) = 0.0
- WHERE ( (ZLBDAI(:)<XLBDAICNVS_LIM) .AND. (ZCIT(:)>XCTMIN(4)) &
- .AND. (ZSSI(:)>0.0) )
- ZZW(:) = (ZLBDAI(:)*XDICNVS_LIM)**(XALPHAI)
- ZZX(:) = ( ZSSI(:)/ZAI(:) )*ZCIT(:) * (ZZW(:)**XNUI) *EXP(-ZZW(:))
-!
-! Correction BVIE
-! ZZW(:) = MAX( MIN( ( XR0DEPIS + XR1DEPIS*ZCJ(:) )*ZZX(:)/ZRHODREF(:) &
- ZZW(:) = MAX( MIN( ( XR0DEPIS + XR1DEPIS*ZCJ(:) )*ZZX(:) &
- ,ZRIS(:) ) + ZRTMIN(5), ZRTMIN(5) ) - ZRTMIN(5)
- ZRIS(:) = ZRIS(:) - ZZW(:)
- ZRSS(:) = ZRSS(:) + ZZW(:)
-!
- ZZW(:) = MIN( ZZW(:)*(( XC0DEPIS+XC1DEPIS*ZCJ(:) ) &
- /( XR0DEPIS+XR1DEPIS*ZCJ(:) )),ZCIS(:) )
- ZCIS(:) = ZCIS(:) - ZZW(:)
- END WHERE
-!
-! Budget storage
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GMICRO(:,:,:),FIELD=PRIS)*PRHODJ(:,:,:),&
- 9,'CNVS_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH ( &
- UNPACK(ZRSS(:),MASK=GMICRO(:,:,:),FIELD=PRSS)*PRHODJ(:,:,:),&
- 10,'CNVS_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH ( &
- UNPACK(ZCIS(:),MASK=GMICRO(:,:,:),FIELD=PCIS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NI,'CNVS_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
-!
-!
-!* 2.4 Aggregation of r_i on r_s: CIAGGS and RIAGGS
-! ---------------------------------------------------
-!
-!
- WHERE ( (ZRIT(:)>XRTMIN(4)) .AND. (ZRST(:)>XRTMIN(5)) .AND. (ZRIS(:)>ZRTMIN(4)) &
- .AND. (ZCIS(:)>ZCTMIN(4)) )
- ZZW1(:,3) = (ZLBDAI(:) / ZLBDAS(:))**3
- ZZW1(:,1) = (ZCIT(:)*(XCCS*ZLBDAS(:)**XCXS)*EXP( XCOLEXIS*(ZZT(:)-XTT) )) &
- / (ZLBDAI(:)**3)
- ZZW1(:,2) = MIN( ZZW1(:,1)*(XAGGS_CLARGE1+XAGGS_CLARGE2*ZZW1(:,3)),ZCIS(:) )
- ZCIS(:) = ZCIS(:) - ZZW1(:,2)
-!
- ZZW1(:,1) = ZZW1(:,1) / ZLBDAI(:)**XBI
- ZZW1(:,2) = MIN( ZZW1(:,1)*(XAGGS_RLARGE1+XAGGS_RLARGE2*ZZW1(:,3)),ZRIS(:) )
- ZRIS(:) = ZRIS(:) - ZZW1(:,2)
- ZRSS(:) = ZRSS(:) + ZZW1(:,2)
- END WHERE
-!
-! Budget storage
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GMICRO(:,:,:),FIELD=PRIS)*PRHODJ(:,:,:), &
- 9,'AGGS_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH ( &
- UNPACK(ZRSS(:),MASK=GMICRO(:,:,:),FIELD=PRSS)*PRHODJ(:,:,:), &
- 10,'AGGS_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH ( &
- UNPACK(ZCIS(:),MASK=GMICRO(:,:,:),FIELD=PCIS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NI,'AGGS_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
-!
-!
-!------------------------------------------------------------------------------
-!
-!
-!* 3. Unpacking & Deallocating
-! ------------------------
-!
-!
-!
- ZW(:,:,:) = PRVS(:,:,:)
- PRVS(:,:,:) = UNPACK( ZRVS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRIS(:,:,:)
- PRIS(:,:,:) = UNPACK( ZRIS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRSS(:,:,:)
- PRSS(:,:,:) = UNPACK( ZRSS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
-!
- ZW(:,:,:) = PCIS(:,:,:)
- PCIS(:,:,:) = UNPACK( ZCIS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
-!
- ZW(:,:,:) = PTHS(:,:,:)
- PTHS(:,:,:) = UNPACK( ZTHS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
-!
- DEALLOCATE(ZRVT)
- DEALLOCATE(ZRCT)
- DEALLOCATE(ZRRT)
- DEALLOCATE(ZRIT)
- DEALLOCATE(ZRST)
- DEALLOCATE(ZRGT)
- DEALLOCATE(ZCIT)
- DEALLOCATE(ZRVS)
- DEALLOCATE(ZRIS)
- DEALLOCATE(ZRSS)
- DEALLOCATE(ZTHS)
- DEALLOCATE(ZCIS)
- DEALLOCATE(ZRHODREF)
- DEALLOCATE(ZZT)
- DEALLOCATE(ZPRES)
- DEALLOCATE(ZEXNREF)
- DEALLOCATE(ZZW)
- DEALLOCATE(ZZX)
- DEALLOCATE(ZLSFACT)
- DEALLOCATE(ZSSI)
- DEALLOCATE(ZLBDAI)
- DEALLOCATE(ZLBDAS)
- DEALLOCATE(ZAI)
- DEALLOCATE(ZCJ)
- DEALLOCATE(ZKA)
- DEALLOCATE(ZDV)
- DEALLOCATE(ZZW1)
- IF (NBUMOD==KMI .AND. LBU_ENABLE) DEALLOCATE(ZRHODJ)
-!
-!
-ELSE
-!
-! Advance the budget calls
-!
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) THEN
- ZW(:,:,:) = PTHS(:,:,:)*PRHODJ(:,:,:)
- CALL BUDGET_DDH (ZW,4,'DEPS_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- ENDIF
- IF (LBUDGET_RV) THEN
- ZW(:,:,:) = PRVS(:,:,:)*PRHODJ(:,:,:)
- CALL BUDGET_DDH (ZW,6,'DEPS_BU_RRV',YDDDH, YDLDDH, YDMDDH)
- ENDIF
- IF (LBUDGET_RI) THEN
- ZW(:,:,:) = PRIS(:,:,:)*PRHODJ(:,:,:)
- CALL BUDGET_DDH (ZW,9,'CNVI_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (ZW,9,'CNVS_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (ZW,9,'AGGS_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- ENDIF
- IF (LBUDGET_RS) THEN
- ZW(:,:,:) = PRSS(:,:,:)*PRHODJ(:,:,:)
- CALL BUDGET_DDH (ZW,10,'CNVI_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (ZW,10,'DEPS_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (ZW,10,'CNVS_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (ZW,10,'AGGS_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- ENDIF
- IF (LBUDGET_SV) THEN
- ZW(:,:,:) = PCIS(:,:,:)*PRHODJ(:,:,:)
- CALL BUDGET_DDH (ZW,12+NSV_LIMA_NI,'CNVI_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (ZW,12+NSV_LIMA_NI,'CNVS_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (ZW,12+NSV_LIMA_NI,'AGGS_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- ENDIF
- ENDIF
-!
-END IF
-!
-DEALLOCATE(ZRTMIN)
-DEALLOCATE(ZCTMIN)
-!
-END SUBROUTINE LIMA_COLD_SLOW_PROCESSES
diff --git a/src/arome/micro/lima_meyers.F90 b/src/arome/micro/lima_meyers.F90
deleted file mode 100644
index a10953731..000000000
--- a/src/arome/micro/lima_meyers.F90
+++ /dev/null
@@ -1,486 +0,0 @@
-! #######################
- MODULE MODI_LIMA_MEYERS
-! #######################
-!
-INTERFACE
- SUBROUTINE LIMA_MEYERS (OHHONI, PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT, &
- PZZ, PRHODJ, PRHODREF, PEXNREF, PPABST, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, PCCT, &
- PTHS, PRVS, PRCS, PRIS, &
- PCCS, PCIS, PINS, &
- YDDDH, YDLDDH, YDMDDH )
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-LOGICAL, INTENT(IN) :: OHHONI ! enable haze freezing
-REAL, INTENT(IN) :: PTSTEP ! Time step
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Cloud ice m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGT ! Graupel m.r. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCCT ! Cloud water C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCCS ! Cloud water C. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIS ! Ice crystal C. source
-!
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PINS ! Activated ice nuclei C. source
- !for DEPOSITION and CONTACT
- !for IMMERSION
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-END SUBROUTINE LIMA_MEYERS
-END INTERFACE
-END MODULE MODI_LIMA_MEYERS
-!
-! ######################################################################
- SUBROUTINE LIMA_MEYERS (OHHONI, PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT, &
- PZZ, PRHODJ, PRHODREF, PEXNREF, PPABST, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, PCCT, &
- PTHS, PRVS, PRCS, PRIS, &
- PCCS, PCIS, PINS, &
- YDDDH, YDLDDH, YDMDDH )
-! ######################################################################
-!!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the heterogeneous nucleation
-!! following Phillips (2008).
-!!
-!!
-!!** METHOD
-!! ------
-!! The parameterization of Phillips (2008) is based on observed nucleation
-!! in the CFDC for a range of T and Si values. Phillips therefore defines a
-!! reference activity spectrum, that is, for given T and Si values, the
-!! reference concentration of primary ice crystals.
-!!
-!! The activation of IFN is closely related to their total surface. Thus,
-!! the activable fraction of each IFN specie is determined by an integration
-!! over the particle size distributions.
-!!
-!! Subroutine organisation :
-!!
-!! 1- Preliminary computations
-!! 2- Check where computations are necessary, and pack variables
-!! 3- Compute the saturation over water and ice
-!! 4- Compute the reference activity spectrum
-!! -> CALL LIMA_PHILLIPS_REF_SPECTRUM
-!! Integrate over the size distributions to compute the IFN activable fraction
-!! -> CALL LIMA_PHILLIPS_INTEG
-!! 5- Heterogeneous nucleation of insoluble IFN
-!! 6- Heterogeneous nucleation of coated IFN
-!! 7- Unpack variables & deallocations
-!!
-!!
-!! REFERENCE
-!! ---------
-!!
-!! Phillips et al., 2008: An empirical parameterization of heterogeneous
-!! ice nucleation for multiple chemical species of aerosols, J. Atmos. Sci.
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!! C. Barthe * LACy * jan. 2014 add budgets
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_PARAMETERS
-USE MODD_CST
-USE MODD_PARAM_LIMA
-USE MODD_PARAM_LIMA_COLD
-USE MODD_BUDGET
-USE MODE_BUDGET, ONLY: BUDGET_DDH
-USE MODD_NSV, ONLY : NSV_LIMA_NC, NSV_LIMA_NI
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-USE MODI_LIMA_FUNCTIONS, ONLY : COUNTJV
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-LOGICAL, INTENT(IN) :: OHHONI ! enable haze freezing
-REAL, INTENT(IN) :: PTSTEP ! Time step
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Cloud ice m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGT ! Graupel m.r. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCCT ! Cloud water C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCCS ! Cloud water C. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIS ! Ice crystal C. source
-!
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PINS ! Activated ice nuclei C. source
- !for DEPOSITION and CONTACT
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-!
-!* 0.2 Declarations of local variables :
-!
-!
-INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE ! Physical domain
-INTEGER :: JL ! Loop index
-INTEGER :: INEGT ! Case number of nucleation
-!
-LOGICAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: GNEGT ! Test where to compute the nucleation
-!
-INTEGER, DIMENSION(SIZE(PRHODREF)) :: I1,I2,I3 ! Indexes for PACK replacement
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRRT ! Rain water m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRIT ! Pristine ice m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRGT ! Graupel/hail m.r. at t
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZCCT ! Cloud water conc. at t
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVS ! Water vapor m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRCS ! Cloud water m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZCCS ! Cloud water conc. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZCIS ! Pristine ice conc. source
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZTHS ! Theta source
-!
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZINS ! Nucleated Ice nuclei conc. source
- ! by Deposition/Contact
-!
-REAL, DIMENSION(:), ALLOCATABLE &
- :: ZRHODREF, & ! RHO Dry REFerence
- ZRHODJ, & ! RHO times Jacobian
- ZZT, & ! Temperature
- ZPRES, & ! Pressure
- ZEXNREF, & ! EXNer Pressure REFerence
- ZZW, & ! Work array
- ZZX, & ! Work array
- ZZY, & ! Work array
- ZLSFACT, & ! L_s/(Pi_ref*C_ph)
- ZLVFACT, & ! L_v/(Pi_ref*C_ph)
- ZSSI
-!
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: ZW, ZT ! work arrays
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZTCELSIUS
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 1. PRELIMINARY COMPUTATIONS
-! ------------------------
-!
-!
-! Physical domain
-!
-IIB=1+JPHEXT
-IIE=SIZE(PZZ,1) - JPHEXT
-IJB=1+JPHEXT
-IJE=SIZE(PZZ,2) - JPHEXT
-IKB=1+JPVEXT
-IKE=SIZE(PZZ,3) - JPVEXT
-!
-! Temperature
-!
-ZT(:,:,:) = PTHT(:,:,:) * ( PPABST(:,:,:)/XP00 ) ** (XRD/XCPD)
-!
-! Saturation over ice
-!
-ZW(:,:,:) = EXP( XALPI - XBETAI/ZT(:,:,:) - XGAMI*ALOG(ZT(:,:,:) ) )
-ZW(:,:,:) = PRVT(:,:,:)*( PPABST(:,:,:)-ZW(:,:,:) ) / ( (XMV/XMD) * ZW(:,:,:) )
-!
-!
-!-------------------------------------------------------------------------------
-!
-! optimization by looking for locations where
-! the temperature is negative only !!!
-!
-GNEGT(:,:,:) = .FALSE.
-GNEGT(IIB:IIE,IJB:IJE,IKB:IKE) = ZT(IIB:IIE,IJB:IJE,IKB:IKE)<XTT .AND. &
- ZW(IIB:IIE,IJB:IJE,IKB:IKE)>0.8
-INEGT = COUNTJV( GNEGT(:,:,:),I1(:),I2(:),I3(:))
-IF( INEGT >= 1 ) THEN
- ALLOCATE(ZRVT(INEGT))
- ALLOCATE(ZRCT(INEGT))
- ALLOCATE(ZRRT(INEGT))
- ALLOCATE(ZRIT(INEGT))
- ALLOCATE(ZRST(INEGT))
- ALLOCATE(ZRGT(INEGT))
-!
- ALLOCATE(ZCCT(INEGT))
-!
- ALLOCATE(ZRVS(INEGT))
- ALLOCATE(ZRCS(INEGT))
- ALLOCATE(ZRIS(INEGT))
-!
- ALLOCATE(ZTHS(INEGT))
-!
- ALLOCATE(ZCCS(INEGT))
- ALLOCATE(ZINS(INEGT,1))
- ALLOCATE(ZCIS(INEGT))
-!
- ALLOCATE(ZRHODREF(INEGT))
- ALLOCATE(ZZT(INEGT))
- ALLOCATE(ZPRES(INEGT))
- ALLOCATE(ZEXNREF(INEGT))
- DO JL=1,INEGT
- ZRVT(JL) = PRVT(I1(JL),I2(JL),I3(JL))
- ZRCT(JL) = PRCT(I1(JL),I2(JL),I3(JL))
- ZRRT(JL) = PRRT(I1(JL),I2(JL),I3(JL))
- ZRIT(JL) = PRIT(I1(JL),I2(JL),I3(JL))
- ZRST(JL) = PRST(I1(JL),I2(JL),I3(JL))
- ZRGT(JL) = PRGT(I1(JL),I2(JL),I3(JL))
-!
- ZCCT(JL) = PCCT(I1(JL),I2(JL),I3(JL))
-!
- ZRVS(JL) = PRVS(I1(JL),I2(JL),I3(JL))
- ZRCS(JL) = PRCS(I1(JL),I2(JL),I3(JL))
- ZRIS(JL) = PRIS(I1(JL),I2(JL),I3(JL))
-!
- ZTHS(JL) = PTHS(I1(JL),I2(JL),I3(JL))
-!
- ZCCS(JL) = PCCS(I1(JL),I2(JL),I3(JL))
- ZCIS(JL) = PCIS(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) = PPABST(I1(JL),I2(JL),I3(JL))
- ZEXNREF(JL) = PEXNREF(I1(JL),I2(JL),I3(JL))
- ENDDO
- ALLOCATE(ZZW(INEGT))
- ALLOCATE(ZZX(INEGT))
- ALLOCATE(ZZY(INEGT))
- ALLOCATE(ZLSFACT(INEGT))
- ALLOCATE(ZLVFACT(INEGT))
- ALLOCATE(ZSSI(INEGT))
- ALLOCATE(ZTCELSIUS(INEGT))
-!
- ZZW(:) = ZEXNREF(:)*( XCPD+XCPV*ZRVT(:)+XCL*(ZRCT(:)+ZRRT(:)) &
- +XCI*(ZRIT(:)+ZRST(:)+ZRGT(:)) )
- ZTCELSIUS(:) = MAX( ZZT(:)-XTT,-50.0 )
- ZLSFACT(:) = (XLSTT+(XCPV-XCI)*ZTCELSIUS(:))/ZZW(:) ! L_s/(Pi_ref*C_ph)
- ZLVFACT(:) = (XLVTT+(XCPV-XCL)*ZTCELSIUS(:))/ZZW(:) ! L_v/(Pi_ref*C_ph)
-!
- ZZW(:) = EXP( XALPI - XBETAI/ZZT(:) - XGAMI*ALOG(ZZT(:)) ) ! es_i
- ZSSI(:) = ZRVT(:)*(ZPRES(:)-ZZW(:))/((XMV/XMD)*ZZW(:)) - 1.0
- ! Supersaturation over ice
-!
-!* compute the heterogeneous nucleation by deposition: RVHNDI
-!
- DO JL=1,INEGT
- ZINS(JL,1) = PINS(I1(JL),I2(JL),I3(JL),1)
- END DO
- ZZW(:) = 0.0
- ZZX(:) = 0.0
- ZZY(:) = 0.0
-!
- WHERE( ZZT(:)<XTT-5.0 .AND. ZSSI(:)>0.0 )
- ZZY(:) = XNUC_DEP*EXP( XEXSI_DEP*100.*MIN(1.,ZSSI(:))+XEX_DEP)/(PTSTEP*ZRHODREF(:))
- ZZX(:) = MAX( ZZY(:)-ZINS(:,1) , 0.0 )
- ZZW(:) = MIN( XMNU0*ZZX(:) , ZRVS(:) )
- END WHERE
-!
- ZINS(:,1) = ZINS(:,1) + ZZX(:)
- ZW(:,:,:) = PINS(:,:,:,1)
- PINS(:,:,:,1) = UNPACK( ZINS(:,1), MASK=GNEGT(:,:,:), FIELD=ZW(:,:,:) )
-!
- ZRVS(:) = ZRVS(:) - ZZW(:)
- ZRIS(:) = ZRIS(:) + ZZW(:)
- ZTHS(:) = ZTHS(:) + ZZW(:) * (ZLSFACT(:)-ZLVFACT(:)) ! f(L_s*(RVHNDI))
- ZCIS(:) = ZCIS(:) + ZZX(:)
-!
-!
-! Budget storage
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GNEGT(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'HIND_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RV) CALL BUDGET_DDH ( &
- UNPACK(ZRVS(:),MASK=GNEGT(:,:,:),FIELD=PRVS)*PRHODJ(:,:,:),&
- 6,'HIND_BU_RRV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GNEGT(:,:,:),FIELD=PRIS)*PRHODJ(:,:,:),&
- 9,'HIND_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH ( UNPACK(ZCIS(:),MASK=GNEGT(:,:,:),FIELD=PCIS)*PRHODJ(:,:,:),&
- 12+NSV_LIMA_NI,'HIND_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
- END IF
-!
-!* compute the heterogeneous nucleation by contact: RVHNCI
-!
- DO JL=1,INEGT
- ZINS(JL,1) = PINS(I1(JL),I2(JL),I3(JL),1)
- END DO
- ZZW(:) = 0.0
- ZZX(:) = 0.0
- ZZY(:) = 0.0
-!
- WHERE( ZZT(:)<XTT-2.0 .AND. ZCCT(:)>XCTMIN(2) .AND. ZRCT(:)>XRTMIN(2) )
- ZZY(:) = MIN( XNUC_CON * EXP( XEXTT_CON*ZTCELSIUS(:)+XEX_CON ) &
- /(PTSTEP*ZRHODREF(:)) , ZCCS(:) )
- ZZX(:) = MAX( ZZY(:)-ZINS(:,1),0.0 )
- ZZW(:) = MIN( (ZRCT(:)/ZCCT(:))*ZZX(:),ZRCS(:) )
- END WHERE
-!
- ZINS(:,1) = ZINS(:,1) + ZZX(:)
- ZW(:,:,:) = PINS(:,:,:,1)
- PINS(:,:,:,1) = UNPACK( ZINS(:,1), MASK=GNEGT(:,:,:), FIELD=ZW(:,:,:) )
-!
- ZRCS(:) = ZRCS(:) - ZZW(:)
- ZRIS(:) = ZRIS(:) + ZZW(:)
- ZTHS(:) = ZTHS(:) + ZZW(:)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_s*(RVHNCI))
- ZCCS(:) = ZCCS(:) - ZZX(:)
- ZCIS(:) = ZCIS(:) + ZZX(:)
-!
-!* unpack variables
-!
- ZW(:,:,:) = PRVS(:,:,:)
- PRVS(:,:,:) = UNPACK( ZRVS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRCS(:,:,:)
- PRCS(:,:,:) = UNPACK( ZRCS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRIS(:,:,:)
- PRIS(:,:,:) = UNPACK( ZRIS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PTHS(:,:,:)
- PTHS(:,:,:) = UNPACK( ZTHS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PCCS(:,:,:)
- PCCS(:,:,:) = UNPACK( ZCCS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PCIS(:,:,:)
- PCIS(:,:,:) = UNPACK( ZCIS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
-!
-! Budget storage
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:), 4,'HINC_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:), 7,'HINC_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:), 9,'HINC_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH ( PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,'HINC_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH ( PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'HINC_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
- END IF
-
-!
- DEALLOCATE(ZRVT)
- DEALLOCATE(ZRCT)
- DEALLOCATE(ZRRT)
- DEALLOCATE(ZRIT)
- DEALLOCATE(ZRST)
- DEALLOCATE(ZRGT)
-!
- DEALLOCATE(ZCCT)
-!
- DEALLOCATE(ZRVS)
- DEALLOCATE(ZRCS)
- DEALLOCATE(ZRIS)
-!
- DEALLOCATE(ZTHS)
-!
- DEALLOCATE(ZCCS)
- DEALLOCATE(ZINS)
- DEALLOCATE(ZCIS)
-!
- DEALLOCATE(ZRHODREF)
- DEALLOCATE(ZZT)
- DEALLOCATE(ZTCELSIUS)
- DEALLOCATE(ZPRES)
- DEALLOCATE(ZEXNREF)
- DEALLOCATE(ZSSI)
- DEALLOCATE(ZZW)
- DEALLOCATE(ZZX)
- DEALLOCATE(ZZY)
- DEALLOCATE(ZLSFACT)
- DEALLOCATE(ZLVFACT)
-!
-ELSE
-!
-! Advance the budget calls
-!
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'HIND_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RV) CALL BUDGET_DDH (PRVS(:,:,:)*PRHODJ(:,:,:),6,'HIND_BU_RRV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9,'HIND_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'HIND_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'HINC_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:),7,'HINC_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9,'HINC_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH (PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,'HINC_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'HINC_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
- END IF
-!
-END IF
-
-
-
-
-!
-!-------------------------------------------------------------------------------
-!
-END SUBROUTINE LIMA_MEYERS
diff --git a/src/arome/micro/lima_mixed.F90 b/src/arome/micro/lima_mixed.F90
deleted file mode 100644
index 000b50376..000000000
--- a/src/arome/micro/lima_mixed.F90
+++ /dev/null
@@ -1,816 +0,0 @@
-! ######################
- MODULE MODI_LIMA_MIXED
-! ######################
-!
-INTERFACE
- SUBROUTINE LIMA_MIXED (OSEDI, OHHONI, KSPLITG, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, KRR, PZZ, PRHODJ, &
- PRHODREF, PEXNREF, PPABST, PW_NU, &
- PTHM, PPABSM, &
- PTHT, PRT, PSVT, &
- PTHS, PRS, PSVS, &
- YDDDH, YDLDDH, YDMDDH )
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-LOGICAL, INTENT(IN) :: OSEDI ! switch to activate the
- ! cloud ice sedimentation
-LOGICAL, INTENT(IN) :: OHHONI ! enable haze freezing
-INTEGER, INTENT(IN) :: KSPLITG ! Number of small time step
- ! integration for ice sedimendation
-REAL, INTENT(IN) :: PTSTEP ! Time step
-INTEGER, INTENT(IN) :: KMI ! Model index
-!
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-INTEGER, INTENT(IN) :: KRR ! Number of moist variables
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PW_NU ! updraft velocity used for
- ! the nucleation param.
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHM ! Theta at time t-dt
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSM ! abs. pressure at time t-dt
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! m.r. at t
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PSVT ! Concentrations at t
-
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRS ! m.r. source
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PSVS ! Concentrations source
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-END SUBROUTINE LIMA_MIXED
-END INTERFACE
-END MODULE MODI_LIMA_MIXED
-!
-! #######################################################################
- SUBROUTINE LIMA_MIXED (OSEDI, OHHONI, KSPLITG, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, KRR, PZZ, PRHODJ, &
- PRHODREF, PEXNREF, PPABST, PW_NU, &
- PTHM, PPABSM, &
- PTHT, PRT, PSVT, &
- PTHS, PRS, PSVS, &
- YDDDH, YDLDDH, YDMDDH )
-! #######################################################################
-!
-!!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the mixed-phase
-!! microphysical processes
-!!
-!!
-!!** METHOD
-!! ------
-!!
-!! REFERENCE
-!! ---------
-!!
-!! Most of the parameterizations come from the ICE3 scheme, described in
-!! the MESO-NH scientific documentation.
-!!
-!! Cohard, J.-M. and J.-P. Pinty, 2000: A comprehensive two-moment warm
-!! microphysical bulk scheme.
-!! Part I: Description and tests
-!! Part II: 2D experiments with a non-hydrostatic model
-!! Accepted for publication in Quart. J. Roy. Meteor. Soc.
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!! C. Barthe * LACy * jan. 2014 add budgets
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE YOMLUN , ONLY : NULOUT
-!
-USE MODD_PARAMETERS, ONLY : JPHEXT, JPVEXT
-USE MODD_CST, ONLY : XP00, XRD, XRV, XMV, XMD, XCPD, XCPV, &
- XCL, XCI, XTT, XLSTT, XLVTT, &
- XALPI, XBETAI, XGAMI
-USE MODD_PARAM_LIMA, ONLY : NMOD_IFN, XRTMIN, XCTMIN, LWARM_LIMA, LCOLD_LIMA, &
- NMOD_CCN, NMOD_IMM, LRAIN_LIMA, LHAIL_LIMA
-USE MODD_PARAM_LIMA_WARM, ONLY : XLBC, XLBEXC, XLBR, XLBEXR
-USE MODD_PARAM_LIMA_COLD, ONLY : XLBI, XLBEXI, XLBS, XLBEXS, XSCFAC
-USE MODD_PARAM_LIMA_MIXED, ONLY : XLBG, XLBEXG, XLBH, XLBEXH
-!USE MODD_BUDGET, ONLY : LBU_ENABLE, NBUMOD
-!
-USE MODD_NSV
-!
-USE MODD_BUDGET
-USE MODE_BUDGET, ONLY: BUDGET_DDH
-!
-USE MODI_LIMA_FUNCTIONS, ONLY : COUNTJV
-USE MODI_LIMA_MIXED_SLOW_PROCESSES
-USE MODI_LIMA_MIXED_FAST_PROCESSES
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-LOGICAL, INTENT(IN) :: OSEDI ! switch to activate the
- ! cloud ice sedimentation
-LOGICAL, INTENT(IN) :: OHHONI ! enable haze freezing
-INTEGER, INTENT(IN) :: KSPLITG ! Number of small time step
- ! integration for ice sedimendation
-REAL, INTENT(IN) :: PTSTEP ! Time step
-INTEGER, INTENT(IN) :: KMI ! Model index
-!
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-INTEGER, INTENT(IN) :: KRR ! Number of moist variables
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PW_NU ! updraft velocity used for
- ! the nucleation param.
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHM ! Theta at time t-dt
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSM ! abs. pressure at time t-dt
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! m.r. at t
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PSVT ! Concentrations at t
-
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PRS ! m.r. source
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PSVS ! Concentrations source
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-!* 0.2 Declarations of local variables :
-!
-!3D microphysical variables
-REAL, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,2),SIZE(PZZ,3)) &
- :: 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, & ! Snow/aggregate m.r. at t
- PRGT, & ! Graupel m.r. at t
- PRHT, & ! Hail m.r. at t
- !
- PRVS, & ! Water vapor m.r. source
- PRCS, & ! Cloud water m.r. source
- PRRS, & ! Rain water m.r. source
- PRIS, & ! Pristine ice m.r. source
- PRSS, & ! Snow/aggregate m.r. source
- PRGS, & ! Graupel m.r. source
- PRHS, & ! Hail m.r. source
- !
- PCCT, & ! Cloud water C. at t
- PCRT, & ! Rain water C. at t
- PCIT, & ! Ice crystal C. at t
- !
- PCCS, & ! Cloud water C. source
- PCRS, & ! Rain water C. source
- PCIS ! Ice crystal C. source
-!
-REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: PNFS ! CCN C. available source
- !used as Free ice nuclei for
- !HOMOGENEOUS nucleation of haze
-REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: PNAS ! Cloud C. nuclei C. source
- !used as Free ice nuclei for
- !IMMERSION freezing
-REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: PIFS ! Free ice nuclei C. source
- !for DEPOSITION and CONTACT
-REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: PINS ! Activated ice nuclei C. source
- !for DEPOSITION and CONTACT
-REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: PNIS ! Activated ice nuclei C. source
- !for IMMERSION
-REAL, DIMENSION(:,:,:), ALLOCATABLE :: PNHS ! Hom. freezing of CCN
-!
-! Replace PACK
-LOGICAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: GMICRO
-INTEGER :: IMICRO
-INTEGER , DIMENSION(SIZE(GMICRO)) :: I1,I2,I3 ! Used to replace the COUNT
-INTEGER :: JL ! and PACK intrinsics
-!
-! Packed microphysical variables
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRRT ! Rain water m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRIT ! Pristine ice m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRGT ! Graupel m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRHT ! Hail m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZCCT ! Cloud water conc. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZCRT ! Rain water conc. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZCIT ! Pristine ice conc. at t
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVS ! Water vapor m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRCS ! Cloud water m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRRS ! Rain water m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRSS ! Snow/aggregate m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRGS ! Graupel m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRHS ! Hail m.r. source
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZTHS ! Theta source
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZCCS ! Cloud water conc. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZCRS ! Rain water conc. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZCIS ! Pristine ice conc. source
-!
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZIFS ! Free Ice nuclei conc. source
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZINS ! Nucleated Ice nuclei conc. source
-!
-! Other packed variables
-REAL, DIMENSION(:), ALLOCATABLE &
- :: ZRHODREF, & ! RHO Dry REFerence
- ZRHODJ, & ! RHO times Jacobian
- ZZT, & ! Temperature
- ZPRES, & ! Pressure
- ZEXNREF, & ! EXNer Pressure REFerence
- ZZW, & ! Work array
- ZLSFACT, & ! L_s/(Pi_ref*C_ph)
- ZLVFACT, & ! L_v/(Pi_ref*C_ph)
- ZSSI, & ! Supersaturation over ice
- ZLBDAC, & ! Slope parameter of the cloud droplet distr.
- ZLBDAR, & ! Slope parameter of the raindrop distr.
- ZLBDAI, & ! Slope parameter of the ice crystal distr.
- ZLBDAS, & ! Slope parameter of the aggregate distr.
- ZLBDAG, & ! Slope parameter of the graupel distr.
- ZLBDAH, & ! Slope parameter of the hail distr.
- ZAI, & ! Thermodynamical function
- ZCJ, & ! used to compute the ventilation coefficient
- ZKA, & ! Thermal conductivity of the air
- ZDV ! Diffusivity of water vapor in the air
-!
-! 3D Temperature
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: ZT, ZW
-!
-!
-INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE ! Physical domain
-INTEGER :: JMOD_IFN ! Loop index
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 0. 3D MICROPHYSCAL VARIABLES
-! -------------------------
-!
-!
-! Prepare 3D water mixing ratios
-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.
-PRHT(:,:,:) = 0.
-PRHS(:,:,:) = 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)
-IF ( KRR .GE. 7 ) PRHT(:,:,:) = PRT(:,:,:,7)
-IF ( KRR .GE. 7 ) PRHS(:,:,:) = PRS(:,:,:,7)
-!
-! Prepare 3D number concentrations
-PCCT(:,:,:) = 0.
-PCRT(:,:,:) = 0.
-PCIT(:,:,:) = 0.
-PCCS(:,:,:) = 0.
-PCRS(:,:,:) = 0.
-PCIS(:,:,:) = 0.
-!
-IF ( LWARM_LIMA ) PCCT(:,:,:) = PSVT(:,:,:,NSV_LIMA_NC)
-IF ( LWARM_LIMA .AND. LRAIN_LIMA ) PCRT(:,:,:) = PSVT(:,:,:,NSV_LIMA_NR)
-IF ( LCOLD_LIMA ) PCIT(:,:,:) = PSVT(:,:,:,NSV_LIMA_NI)
-!
-IF ( LWARM_LIMA ) PCCS(:,:,:) = PSVS(:,:,:,NSV_LIMA_NC)
-IF ( LWARM_LIMA .AND. LRAIN_LIMA ) PCRS(:,:,:) = PSVS(:,:,:,NSV_LIMA_NR)
-IF ( LCOLD_LIMA ) PCIS(:,:,:) = PSVS(:,:,:,NSV_LIMA_NI)
-!
-IF ( 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) )
- 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)
-ELSE
- ALLOCATE( PNFS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),1) )
- ALLOCATE( PNAS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),1) )
- PNFS(:,:,:,:) = 0.
- PNAS(:,:,:,:) = 0.
-END IF
-!
-IF ( 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)
-ELSE
- ALLOCATE( PIFS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),1) )
- ALLOCATE( PINS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),1) )
- PIFS(:,:,:,:) = 0.
- PINS(:,:,:,:) = 0.
-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)
-ELSE
- ALLOCATE( PNIS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),1) )
- PNIS(:,:,:,:) = 0.0
-END IF
-!
-IF ( OHHONI ) THEN
- ALLOCATE( PNHS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3)) )
- PNHS(:,:,:) = PSVS(:,:,:,NSV_LIMA_HOM_HAZE)
-ELSE
- ALLOCATE( PNHS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3)) )
- PNHS(:,:,:) = 0.0
-END IF
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 1. Pack variables, computations only where necessary
-! -------------------------------------------------
-!
-! Physical domain
-!
-IIB=1+JPHEXT
-IIE=SIZE(PZZ,1) - JPHEXT
-IJB=1+JPHEXT
-IJE=SIZE(PZZ,2) - JPHEXT
-IKB=1+JPVEXT
-IKE=SIZE(PZZ,3) - JPVEXT
-!
-! Temperature
-ZT(:,:,:) = PTHT(:,:,:) * ( PPABST(:,:,:)/XP00 ) ** (XRD/XCPD)
-!
-! Looking for regions where computations are necessary
-GMICRO(:,:,:) = .FALSE.
-GMICRO(IIB:IIE,IJB:IJE,IKB:IKE) = PRCT(IIB:IIE,IJB:IJE,IKB:IKE)>XRTMIN(2) .OR. &
- PRRT(IIB:IIE,IJB:IJE,IKB:IKE)>XRTMIN(3) .OR. &
- PRIT(IIB:IIE,IJB:IJE,IKB:IKE)>XRTMIN(4) .OR. &
- PRST(IIB:IIE,IJB:IJE,IKB:IKE)>XRTMIN(5) .OR. &
- PRGT(IIB:IIE,IJB:IJE,IKB:IKE)>XRTMIN(6) .OR. &
- PRHT(IIB:IIE,IJB:IJE,IKB:IKE)>XRTMIN(7)
-!
-IMICRO = COUNTJV( GMICRO(:,:,:),I1(:),I2(:),I3(:))
-!
-IF( IMICRO >= 1 ) THEN
-!
- ALLOCATE(ZRVT(IMICRO))
- ALLOCATE(ZRCT(IMICRO))
- ALLOCATE(ZRRT(IMICRO))
- ALLOCATE(ZRIT(IMICRO))
- ALLOCATE(ZRST(IMICRO))
- ALLOCATE(ZRGT(IMICRO))
- ALLOCATE(ZRHT(IMICRO))
- !
- ALLOCATE(ZCCT(IMICRO))
- ALLOCATE(ZCRT(IMICRO))
- ALLOCATE(ZCIT(IMICRO))
- !
- ALLOCATE(ZRVS(IMICRO))
- ALLOCATE(ZRCS(IMICRO))
- ALLOCATE(ZRRS(IMICRO))
- ALLOCATE(ZRIS(IMICRO))
- ALLOCATE(ZRSS(IMICRO))
- ALLOCATE(ZRGS(IMICRO))
- ALLOCATE(ZRHS(IMICRO))
- ALLOCATE(ZTHS(IMICRO))
- !
- ALLOCATE(ZCCS(IMICRO))
- ALLOCATE(ZCRS(IMICRO))
- ALLOCATE(ZCIS(IMICRO))
- ALLOCATE(ZIFS(IMICRO,NMOD_IFN))
- ALLOCATE(ZINS(IMICRO,NMOD_IFN))
- !
- ALLOCATE(ZRHODREF(IMICRO))
- ALLOCATE(ZZT(IMICRO))
- ALLOCATE(ZPRES(IMICRO))
- ALLOCATE(ZEXNREF(IMICRO))
- DO JL=1,IMICRO
- ZRVT(JL) = PRVT(I1(JL),I2(JL),I3(JL))
- ZRCT(JL) = PRCT(I1(JL),I2(JL),I3(JL))
- ZRRT(JL) = PRRT(I1(JL),I2(JL),I3(JL))
- ZRIT(JL) = PRIT(I1(JL),I2(JL),I3(JL))
- ZRST(JL) = PRST(I1(JL),I2(JL),I3(JL))
- ZRGT(JL) = PRGT(I1(JL),I2(JL),I3(JL))
- ZRHT(JL) = PRHT(I1(JL),I2(JL),I3(JL))
- !
- ZCCT(JL) = PCCT(I1(JL),I2(JL),I3(JL))
- ZCRT(JL) = PCRT(I1(JL),I2(JL),I3(JL))
- ZCIT(JL) = PCIT(I1(JL),I2(JL),I3(JL))
- !
- ZRVS(JL) = PRVS(I1(JL),I2(JL),I3(JL))
- ZRCS(JL) = PRCS(I1(JL),I2(JL),I3(JL))
- ZRRS(JL) = PRRS(I1(JL),I2(JL),I3(JL))
- ZRIS(JL) = PRIS(I1(JL),I2(JL),I3(JL))
- ZRSS(JL) = PRSS(I1(JL),I2(JL),I3(JL))
- ZRGS(JL) = PRGS(I1(JL),I2(JL),I3(JL))
- ZRHS(JL) = PRHS(I1(JL),I2(JL),I3(JL))
- ZTHS(JL) = PTHS(I1(JL),I2(JL),I3(JL))
- !
- ZCCS(JL) = PCCS(I1(JL),I2(JL),I3(JL))
- ZCRS(JL) = PCRS(I1(JL),I2(JL),I3(JL))
- ZCIS(JL) = PCIS(I1(JL),I2(JL),I3(JL))
- DO JMOD_IFN = 1, NMOD_IFN
- ZIFS(JL,JMOD_IFN) = PIFS(I1(JL),I2(JL),I3(JL),JMOD_IFN)
- ZINS(JL,JMOD_IFN) = PINS(I1(JL),I2(JL),I3(JL),JMOD_IFN)
- ENDDO
- !
- ZRHODREF(JL) = PRHODREF(I1(JL),I2(JL),I3(JL))
- ZZT(JL) = ZT(I1(JL),I2(JL),I3(JL))
- ZPRES(JL) = PPABST(I1(JL),I2(JL),I3(JL))
- ZEXNREF(JL) = PEXNREF(I1(JL),I2(JL),I3(JL))
- ENDDO
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- ALLOCATE(ZRHODJ(IMICRO))
- ZRHODJ(:) = PACK( PRHODJ(:,:,:),MASK=GMICRO(:,:,:) )
- END IF
-!
-! Atmospheric parameters
-!
- ALLOCATE(ZZW(IMICRO))
- ALLOCATE(ZLSFACT(IMICRO))
- ALLOCATE(ZLVFACT(IMICRO))
- ALLOCATE(ZSSI(IMICRO))
- ALLOCATE(ZAI(IMICRO))
- ALLOCATE(ZCJ(IMICRO))
- ALLOCATE(ZKA(IMICRO))
- ALLOCATE(ZDV(IMICRO))
-!
- ZZW(:) = ZEXNREF(:)*( XCPD+XCPV*ZRVT(:)+XCL*(ZRCT(:)+ZRRT(:)) &
- +XCI*(ZRIT(:)+ZRST(:)+ZRGT(:)) )
-!
- ZLSFACT(:) = (XLSTT+(XCPV-XCI)*(ZZT(:)-XTT))/ZZW(:) ! L_s/(Pi_ref*C_ph)
- ZLVFACT(:) = (XLVTT+(XCPV-XCL)*(ZZT(:)-XTT))/ZZW(:) ! L_v/(Pi_ref*C_ph)
-!
- ZZW(:) = EXP( XALPI - XBETAI/ZZT(:) - XGAMI*ALOG(ZZT(:) ) )
- ZSSI(:) = ZRVT(:)*( ZPRES(:)-ZZW(:) ) / ( (XMV/XMD) * ZZW(:) ) - 1.0
- ! Supersaturation over ice
-!
- ZKA(:) = 2.38E-2 + 0.0071E-2 * ( ZZT(:) - XTT ) ! k_a
- ZDV(:) = 0.211E-4 * (ZZT(:)/XTT)**1.94 * (XP00/ZPRES(:)) ! D_v
-!
-! Thermodynamical function ZAI = A_i(T,P)
- ZAI(:) = ( XLSTT + (XCPV-XCI)*(ZZT(:)-XTT) )**2 / (ZKA(:)*XRV*ZZT(:)**2) &
- + ( XRV*ZZT(:) ) / (ZDV(:)*ZZW(:))
-! ZCJ = c^prime_j (in the ventilation factor)
- ZCJ(:) = XSCFAC * ZRHODREF(:)**0.3 / SQRT( 1.718E-5+0.0049E-5*(ZZT(:)-XTT) )
-!
-!
-! Particle distribution parameters
-!
- ALLOCATE(ZLBDAC(IMICRO))
- ALLOCATE(ZLBDAR(IMICRO))
- ALLOCATE(ZLBDAI(IMICRO))
- ALLOCATE(ZLBDAS(IMICRO))
- ALLOCATE(ZLBDAG(IMICRO))
- ALLOCATE(ZLBDAH(IMICRO))
- ZLBDAC(:) = 1.E10
- WHERE (ZRCT(:)>XRTMIN(2) .AND. ZCCT(:)>XCTMIN(2))
- ZLBDAC(:) = ( XLBC*ZCCT(:) / ZRCT(:) )**XLBEXC
- END WHERE
- ZLBDAR(:) = 1.E10
- WHERE (ZRRT(:)>XRTMIN(3) .AND. ZCRT(:)>XCTMIN(3))
- ZLBDAR(:) = ( XLBR*ZCRT(:) / ZRRT(:) )**XLBEXR
- END WHERE
- ZLBDAI(:) = 1.E10
- WHERE (ZRIT(:)>XRTMIN(4) .AND. ZCIT(:)>XCTMIN(4))
- ZLBDAI(:) = ( XLBI*ZCIT(:) / ZRIT(:) )**XLBEXI
- END WHERE
- ZLBDAS(:) = 1.E10
- WHERE (ZRST(:)>XRTMIN(5) )
- ZLBDAS(:) = XLBS*( ZRHODREF(:)*ZRST(:) )**XLBEXS
- END WHERE
- ZLBDAG(:) = 1.E10
- WHERE (ZRGT(:)>XRTMIN(6) )
- ZLBDAG(:) = XLBG*( ZRHODREF(:)*ZRGT(:) )**XLBEXG
- END WHERE
- ZLBDAH(:) = 1.E10
- WHERE (ZRHT(:)>XRTMIN(7) )
- ZLBDAH(:) = XLBH*( ZRHODREF(:)*ZRHT(:) )**XLBEXH
- END WHERE
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 2. Compute the slow processes involving cloud water and graupel
-! ------------------------------------------------------------
-!
- CALL LIMA_MIXED_SLOW_PROCESSES(ZRHODREF, ZZT, ZSSI, PTSTEP, &
- ZLSFACT, ZLVFACT, ZAI, ZCJ, &
- ZRGT, ZCIT, &
- ZRVS, ZRCS, ZRIS, ZRGS, ZTHS, &
- ZCCS, ZCIS, ZIFS, ZINS, &
- ZLBDAI, ZLBDAG, &
- ZRHODJ, GMICRO, PRHODJ, KMI, &
- PTHS, PRVS, PRCS, PRIS, PRGS, &
- PCCS, PCIS, &
- YDDDH, YDLDDH, YDMDDH )
-!
-!-------------------------------------------------------------------------------
-!
-!
-! 3. Compute the fast RS and RG processes
-! ------------------------------------
-!
- CALL LIMA_MIXED_FAST_PROCESSES(ZRHODREF, ZZT, ZPRES, PTSTEP, &
- ZLSFACT, ZLVFACT, ZKA, ZDV, ZCJ, &
- ZRVT, ZRCT, ZRRT, ZRIT, ZRST, ZRGT, &
- ZRHT, ZCCT, ZCRT, ZCIT, &
- ZRCS, ZRRS, ZRIS, ZRSS, ZRGS, ZRHS, &
- ZTHS, ZCCS, ZCRS, ZCIS, &
- ZLBDAC, ZLBDAR, ZLBDAS, ZLBDAG, ZLBDAH, &
- ZRHODJ, GMICRO, PRHODJ, KMI, PTHS, &
- PRCS, PRRS, PRIS, PRSS, PRGS, PRHS, &
- PCCS, PCRS, PCIS, &
- YDDDH, YDLDDH, YDMDDH )
-!
-!-------------------------------------------------------------------------------
-!
-!
-!
-! 4. Unpack variables
-! ----------------
-!
-!
- ZW(:,:,:) = PRVS(:,:,:)
- PRVS(:,:,:) = UNPACK( ZRVS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRCS(:,:,:)
- PRCS(:,:,:) = UNPACK( ZRCS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRRS(:,:,:)
- PRRS(:,:,:) = UNPACK( ZRRS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRIS(:,:,:)
- PRIS(:,:,:) = UNPACK( ZRIS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRSS(:,:,:)
- PRSS(:,:,:) = UNPACK( ZRSS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRGS(:,:,:)
- PRGS(:,:,:) = UNPACK( ZRGS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRHS(:,:,:)
- PRHS(:,:,:) = UNPACK( ZRHS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
-!
- ZW(:,:,:) = PTHS(:,:,:)
- PTHS(:,:,:) = UNPACK( ZTHS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
-!
- ZW(:,:,:) = PCCS(:,:,:)
- PCCS(:,:,:) = UNPACK( ZCCS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PCRS(:,:,:)
- PCRS(:,:,:) = UNPACK( ZCRS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PCIS(:,:,:)
- PCIS(:,:,:) = UNPACK( ZCIS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
-!
- DO JMOD_IFN = 1, NMOD_IFN
- ZW(:,:,:) = PIFS(:,:,:,JMOD_IFN)
- PIFS(:,:,:,JMOD_IFN) = UNPACK( ZIFS(:,JMOD_IFN),MASK=GMICRO(:,:,:), &
- FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PINS(:,:,:,JMOD_IFN)
- PINS(:,:,:,JMOD_IFN) = UNPACK( ZINS(:,JMOD_IFN),MASK=GMICRO(:,:,:), &
- FIELD=ZW(:,:,:) )
- ENDDO
-!
- DEALLOCATE(ZRVT)
- DEALLOCATE(ZRCT)
- DEALLOCATE(ZRRT)
- DEALLOCATE(ZRIT)
- DEALLOCATE(ZRST)
- DEALLOCATE(ZRGT)
- DEALLOCATE(ZRHT)
-!
- DEALLOCATE(ZCCT)
- DEALLOCATE(ZCRT)
- DEALLOCATE(ZCIT)
-!
- DEALLOCATE(ZRVS)
- DEALLOCATE(ZRCS)
- DEALLOCATE(ZRRS)
- DEALLOCATE(ZRIS)
- DEALLOCATE(ZRSS)
- DEALLOCATE(ZRGS)
- DEALLOCATE(ZRHS)
- DEALLOCATE(ZTHS)
-!
- DEALLOCATE(ZCCS)
- DEALLOCATE(ZCRS)
- DEALLOCATE(ZCIS)
- DEALLOCATE(ZIFS)
- DEALLOCATE(ZINS)
-!
- DEALLOCATE(ZRHODREF)
- DEALLOCATE(ZZT)
- DEALLOCATE(ZPRES)
- DEALLOCATE(ZEXNREF)
-!
- DEALLOCATE(ZZW)
- DEALLOCATE(ZLSFACT)
- DEALLOCATE(ZLVFACT)
- DEALLOCATE(ZSSI)
- DEALLOCATE(ZAI)
- DEALLOCATE(ZCJ)
- DEALLOCATE(ZKA)
- DEALLOCATE(ZDV)
-!
- DEALLOCATE(ZLBDAC)
- DEALLOCATE(ZLBDAR)
- DEALLOCATE(ZLBDAI)
- DEALLOCATE(ZLBDAS)
- DEALLOCATE(ZLBDAG)
- DEALLOCATE(ZLBDAH)
-!
- IF (NBUMOD==KMI .AND. LBU_ENABLE) DEALLOCATE(ZRHODJ)
-!
-!
-ELSE
-!
-! Advance the budget calls
-!
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
-
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'DEPG_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RV) CALL BUDGET_DDH (PRVS(:,:,:)*PRHODJ(:,:,:),6,'DEPG_BU_RRV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH (PRGS(:,:,:)*PRHODJ(:,:,:),11,'DEPG_BU_RRG',YDDDH, YDLDDH, YDMDDH)
-
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'IMLT_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:),7,'IMLT_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9,'IMLT_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,'IMLT_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'IMLT_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'BERFI_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:),7,'BERFI_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9,'BERFI_BU_RRI',YDDDH, YDLDDH, YDMDDH)
-
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'RIM_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:),7,'RIM_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH (PRSS(:,:,:)*PRHODJ(:,:,:),10,'RIM_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH (PRGS(:,:,:)*PRHODJ(:,:,:),11,'RIM_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,'RIM_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9,'HMS_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH (PRSS(:,:,:)*PRHODJ(:,:,:),10,'HMS_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'HMS_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'ACC_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH (PRRS(:,:,:)*PRHODJ(:,:,:),8,'ACC_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH (PRSS(:,:,:)*PRHODJ(:,:,:),10,'ACC_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH (PRGS(:,:,:)*PRHODJ(:,:,:),11,'ACC_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCRS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NR,'ACC_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
- IF (LBUDGET_RS) CALL BUDGET_DDH (PRSS(:,:,:)*PRHODJ(:,:,:),10,'CMEL_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH (PRGS(:,:,:)*PRHODJ(:,:,:),11,'CMEL_BU_RRG',YDDDH, YDLDDH, YDMDDH)
-
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'CFRZ_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH (PRRS(:,:,:)*PRHODJ(:,:,:),8,'CFRZ_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9,'CFRZ_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH (PRGS(:,:,:)*PRHODJ(:,:,:),11,'CFRZ_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCRS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NR,'CFRZ_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'CFRZ_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'WETG_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:),7,'WETG_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH (PRRS(:,:,:)*PRHODJ(:,:,:),8,'WETG_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9,'WETG_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH (PRSS(:,:,:)*PRHODJ(:,:,:),10,'WETG_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH (PRGS(:,:,:)*PRHODJ(:,:,:),11,'WETG_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RH) CALL BUDGET_DDH (PRHS(:,:,:)*PRHODJ(:,:,:),12,'WETG_BU_RRH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,'WETG_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCRS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NR,'WETG_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'WETG_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'DRYG_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:),7,'DRYG_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH (PRRS(:,:,:)*PRHODJ(:,:,:),8,'DRYG_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9,'DRYG_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH (PRSS(:,:,:)*PRHODJ(:,:,:),10,'DRYG_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH (PRGS(:,:,:)*PRHODJ(:,:,:),11,'DRYG_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,'DRYG_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCRS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NR,'DRYG_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'DRYG_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9,'HMG_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH (PRGS(:,:,:)*PRHODJ(:,:,:),11,'HMG_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'HMG_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'GMLT_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH (PRRS(:,:,:)*PRHODJ(:,:,:),8,'GMLT_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH (PRGS(:,:,:)*PRHODJ(:,:,:),11,'GMLT_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCRS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NR,'GMLT_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
- IF (LHAIL_LIMA) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'WETH_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:),7,'WETH_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH (PRRS(:,:,:)*PRHODJ(:,:,:),8,'WETH_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9,'WETH_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH (PRSS(:,:,:)*PRHODJ(:,:,:),10,'WETH_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH (PRGS(:,:,:)*PRHODJ(:,:,:),11,'WETH_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RH) CALL BUDGET_DDH (PRHS(:,:,:)*PRHODJ(:,:,:),12,'WETH_BU_RRH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,'WETH_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCRS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NR,'WETH_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'WETH_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
- IF (LBUDGET_RG) CALL BUDGET_DDH (PRGS(:,:,:)*PRHODJ(:,:,:),11,'COHG_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RH) CALL BUDGET_DDH (PRHS(:,:,:)*PRHODJ(:,:,:),12,'COHG_BU_RRH',YDDDH, YDLDDH, YDMDDH)
-
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'HMLT_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH (PRRS(:,:,:)*PRHODJ(:,:,:),8,'HMLT_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RH) CALL BUDGET_DDH (PRHS(:,:,:)*PRHODJ(:,:,:),12,'HMLT_BU_RRH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCRS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NR,'HMLT_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- ENDIF
-
- ENDIF
-!
-END IF ! IMICRO >= 1
-!
-!------------------------------------------------------------------------------
-!
-!
-!* 5. REPORT 3D MICROPHYSICAL VARIABLES IN PRS AND PSVS
-! -------------------------------------------------
-!
-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(:,:,:)
-IF ( KRR .GE. 7 ) PRS(:,:,:,7) = PRHS(:,:,:)
-!
-! Prepare 3D number concentrations
-!
-PSVS(:,:,:,NSV_LIMA_NC) = PCCS(:,:,:)
-IF ( LRAIN_LIMA ) PSVS(:,:,:,NSV_LIMA_NR) = PCRS(:,:,:)
-PSVS(:,:,:,NSV_LIMA_NI) = PCIS(:,:,:)
-!
-IF ( 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 ( 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 ( NMOD_IMM .GE. 1 ) THEN
- PSVS(:,:,:,NSV_LIMA_IMM_NUCL:NSV_LIMA_IMM_NUCL+NMOD_IMM-1) = PNIS(:,:,:,:)
-END IF
-!
-IF (ALLOCATED(PNFS)) DEALLOCATE(PNFS)
-IF (ALLOCATED(PNAS)) DEALLOCATE(PNAS)
-IF (ALLOCATED(PIFS)) DEALLOCATE(PIFS)
-IF (ALLOCATED(PINS)) DEALLOCATE(PINS)
-IF (ALLOCATED(PNIS)) DEALLOCATE(PNIS)
-IF (ALLOCATED(PNHS)) DEALLOCATE(PNHS)
-!
-!-------------------------------------------------------------------------------
-!
-END SUBROUTINE LIMA_MIXED
diff --git a/src/arome/micro/lima_mixed_fast_processes.F90 b/src/arome/micro/lima_mixed_fast_processes.F90
deleted file mode 100644
index 9bcfa9bb6..000000000
--- a/src/arome/micro/lima_mixed_fast_processes.F90
+++ /dev/null
@@ -1,1341 +0,0 @@
-! #####################################
- MODULE MODI_LIMA_MIXED_FAST_PROCESSES
-! #####################################
-!
-INTERFACE
- SUBROUTINE LIMA_MIXED_FAST_PROCESSES (ZRHODREF, ZZT, ZPRES, PTSTEP, &
- ZLSFACT, ZLVFACT, ZKA, ZDV, ZCJ, &
- ZRVT, ZRCT, ZRRT, ZRIT, ZRST, ZRGT, &
- ZRHT, ZCCT, ZCRT, ZCIT, &
- ZRCS, ZRRS, ZRIS, ZRSS, ZRGS, ZRHS, &
- ZTHS, ZCCS, ZCRS, ZCIS, &
- ZLBDAC, ZLBDAR, ZLBDAS, ZLBDAG, ZLBDAH, &
- ZRHODJ, GMICRO, PRHODJ, KMI, PTHS, &
- PRCS, PRRS, PRIS, PRSS, PRGS, PRHS, &
- PCCS, PCRS, PCIS, &
- YDDDH, YDLDDH, YDMDDH )
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZRHODREF ! RHO Dry REFerence
-REAL, DIMENSION(:), INTENT(IN) :: ZZT ! Temperature
-REAL, DIMENSION(:), INTENT(IN) :: ZPRES ! Pressure
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZLSFACT ! L_s/(Pi_ref*C_ph)
-REAL, DIMENSION(:), INTENT(IN) :: ZLVFACT ! L_v/(Pi_ref*C_ph)
-REAL, DIMENSION(:), INTENT(IN) :: ZKA ! Thermal conductivity of the air
-REAL, DIMENSION(:), INTENT(IN) :: ZDV ! Diffusivity of water vapor in the air
-REAL, DIMENSION(:), INTENT(IN) :: ZCJ ! Ventilation coefficient ?
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZRRT ! Rain water m.r. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZRIT ! Pristine ice m.r. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZRGT ! Graupel m.r. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZRHT ! Hail m.r. at t
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZCCT ! Cloud water conc. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZCRT ! Rain water conc. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZCIT ! Pristine ice conc. at t
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRCS ! Cloud water m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRRS ! Rain water m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRSS ! Snow/aggregate m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRGS ! Graupel/hail m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRHS ! Hail m.r. source
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: ZTHS ! Theta source
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: ZCCS ! Cloud water conc. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZCRS ! Rain water conc. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZCIS ! Pristine ice conc. source
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZLBDAC ! Slope param of the cloud droplet distr.
-REAL, DIMENSION(:), INTENT(IN) :: ZLBDAR ! Slope param of the raindrop distr
-REAL, DIMENSION(:), INTENT(IN) :: ZLBDAS ! Slope param of the aggregate distr.
-REAL, DIMENSION(:), INTENT(IN) :: ZLBDAG ! Slope param of the graupel distr.
-REAL, DIMENSION(:), INTENT(IN) :: ZLBDAH ! Slope param of the hail distr.
-!
-! used for budget storage
-REAL, DIMENSION(:), INTENT(IN) :: ZRHODJ
-LOGICAL, DIMENSION(:,:,:), INTENT(IN) :: GMICRO
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ
-INTEGER, INTENT(IN) :: KMI
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRSS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCCS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCRS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCIS
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-END SUBROUTINE LIMA_MIXED_FAST_PROCESSES
-END INTERFACE
-END MODULE MODI_LIMA_MIXED_FAST_PROCESSES
-!
-! #######################################################################
- SUBROUTINE LIMA_MIXED_FAST_PROCESSES (ZRHODREF, ZZT, ZPRES, PTSTEP, &
- ZLSFACT, ZLVFACT, ZKA, ZDV, ZCJ, &
- ZRVT, ZRCT, ZRRT, ZRIT, ZRST, ZRGT, &
- ZRHT, ZCCT, ZCRT, ZCIT, &
- ZRCS, ZRRS, ZRIS, ZRSS, ZRGS, ZRHS, &
- ZTHS, ZCCS, ZCRS, ZCIS, &
- ZLBDAC, ZLBDAR, ZLBDAS, ZLBDAG, ZLBDAH, &
- ZRHODJ, GMICRO, PRHODJ, KMI, PTHS, &
- PRCS, PRRS, PRIS, PRSS, PRGS, PRHS, &
- PCCS, PCRS, PCIS, &
- YDDDH, YDLDDH, YDMDDH )
-! #######################################################################
-!
-!!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the mixed-phase
-!! fast processes :
-!!
-!! - Fast RS processes :
-!! - Cloud droplet riming of the aggregates
-!! - Hallett-Mossop ice multiplication process due to snow riming
-!! - Rain accretion onto the aggregates
-!! - Conversion-Melting of the aggregates
-!!
-!! - Fast RG processes :
-!! - Rain contact freezing
-!! - Wet/Dry growth of the graupel
-!! - Hallett-Mossop ice multiplication process due to graupel riming
-!! - Melting of the graupeln
-!!
-!!
-!!** METHOD
-!! ------
-!!
-!!
-!! REFERENCE
-!! ---------
-!!
-!! Most of the parameterizations come from the ICE3 scheme, described in
-!! the MESO-NH scientific documentation.
-!!
-!! Cohard, J.-M. and J.-P. Pinty, 2000: A comprehensive two-moment warm
-!! microphysical bulk scheme.
-!! Part I: Description and tests
-!! Part II: 2D experiments with a non-hydrostatic model
-!! Accepted for publication in Quart. J. Roy. Meteor. Soc.
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!! C. Barthe * LACy * jan. 2014 add budgets
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE YOMLUN , ONLY : NULOUT
-!
-USE MODD_CST
-USE MODD_PARAM_LIMA
-USE MODD_PARAM_LIMA_COLD
-USE MODD_PARAM_LIMA_MIXED
-!
-USE MODD_NSV
-USE MODD_BUDGET
-USE MODE_BUDGET, ONLY: BUDGET_DDH
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZRHODREF ! RHO Dry REFerence
-REAL, DIMENSION(:), INTENT(IN) :: ZZT ! Temperature
-REAL, DIMENSION(:), INTENT(IN) :: ZPRES ! Pressure
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZLSFACT ! L_s/(Pi_ref*C_ph)
-REAL, DIMENSION(:), INTENT(IN) :: ZLVFACT ! L_v/(Pi_ref*C_ph)
-REAL, DIMENSION(:), INTENT(IN) :: ZKA ! Thermal conductivity of the air
-REAL, DIMENSION(:), INTENT(IN) :: ZDV ! Diffusivity of water vapor in the air
-REAL, DIMENSION(:), INTENT(IN) :: ZCJ ! Ventilation coefficient ?
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZRRT ! Rain water m.r. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZRIT ! Pristine ice m.r. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZRGT ! Graupel/hail m.r. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZRHT ! Hail m.r. at t
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZCCT ! Cloud water conc. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZCRT ! Rain water conc. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZCIT ! Pristine ice conc. at t
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRCS ! Cloud water m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRRS ! Rain water m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRSS ! Snow/aggregate m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRGS ! Graupel/hail m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRHS ! Hail m.r. source
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: ZTHS ! Theta source
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: ZCCS ! Cloud water conc. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZCRS ! Rain water conc. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZCIS ! Pristine ice conc. source
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZLBDAC ! Slope param of the cloud droplet distr.
-REAL, DIMENSION(:), INTENT(IN) :: ZLBDAR ! Slope param of the raindrop distr
-REAL, DIMENSION(:), INTENT(IN) :: ZLBDAS ! Slope param of the aggregate distr.
-REAL, DIMENSION(:), INTENT(IN) :: ZLBDAG ! Slope param of the graupel distr.
-REAL, DIMENSION(:), INTENT(IN) :: ZLBDAH ! Slope param of the hail distr.
-!
-! used for budget storage
-REAL, DIMENSION(:), INTENT(IN) :: ZRHODJ
-LOGICAL, DIMENSION(:,:,:), INTENT(IN) :: GMICRO
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ
-INTEGER, INTENT(IN) :: KMI
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRSS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCCS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCRS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCIS
-
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-!
-!* 0.2 Declarations of local variables :
-!
-LOGICAL, DIMENSION(SIZE(ZZT)) :: GRIM, GACC, GDRY, GWET, GHAIL ! Test where to compute
-INTEGER :: IGRIM, IGACC, IGDRY, IGWET, IHAIL
-INTEGER :: JJ
-INTEGER, DIMENSION(:), ALLOCATABLE :: IVEC1,IVEC2 ! Vectors of indices
-REAL, DIMENSION(:), ALLOCATABLE :: ZVEC1,ZVEC2, ZVEC3 ! Work vectors
-REAL, DIMENSION(SIZE(ZZT)) :: ZZW, ZZX
-REAL, DIMENSION(SIZE(ZZT)) :: ZRDRYG, ZRWETG
-REAL, DIMENSION(SIZE(ZZT),7) :: ZZW1
-REAL :: NHAIL
-REAL :: ZTHRH, ZTHRC
-!
-!-------------------------------------------------------------------------------
-!
-! #################
-! FAST RS PROCESSES
-! #################
-!
-IF (LSNOW_LIMA) THEN
-!
-!
-!* 1.1 Cloud droplet riming of the aggregates
-! -------------------------------------------
-!
-!
-ZZW1(:,:) = 0.0
-!
-GRIM(:) = (ZRCT(:)>XRTMIN(2)) .AND. (ZRST(:)>XRTMIN(5)) .AND. (ZRCS(:)>XRTMIN(2)/PTSTEP) .AND. (ZZT(:)<XTT)
-IGRIM = COUNT( GRIM(:) )
-!
-IF( IGRIM>0 ) THEN
-!
-! 1.1.0 allocations
-!
- ALLOCATE(ZVEC1(IGRIM))
- ALLOCATE(ZVEC2(IGRIM))
- ALLOCATE(IVEC1(IGRIM))
- ALLOCATE(IVEC2(IGRIM))
-!
-! 1.1.1 select the ZLBDAS
-!
- ZVEC1(:) = PACK( ZLBDAS(:),MASK=GRIM(:) )
-!
-! 1.1.2 find the next lower indice for the ZLBDAS in the geometrical
-! set of Lbda_s used to tabulate some moments of the incomplete
-! gamma function
-!
- ZVEC2(1:IGRIM) = MAX( 1.00001, MIN( FLOAT(NGAMINC)-0.00001, &
- XRIMINTP1 * LOG( ZVEC1(1:IGRIM) ) + XRIMINTP2 ) )
- IVEC2(1:IGRIM) = INT( ZVEC2(1:IGRIM) )
- ZVEC2(1:IGRIM) = ZVEC2(1:IGRIM) - FLOAT( IVEC2(1:IGRIM) )
-!
-! 1.1.3 perform the linear interpolation of the normalized
-! "2+XDS"-moment of the incomplete gamma function
-!
- ZVEC1(1:IGRIM) = XGAMINC_RIM1( IVEC2(1:IGRIM)+1 )* ZVEC2(1:IGRIM) &
- - XGAMINC_RIM1( IVEC2(1:IGRIM) )*(ZVEC2(1:IGRIM) - 1.0)
- ZZW(:) = UNPACK( VECTOR=ZVEC1(:),MASK=GRIM,FIELD=0.0 )
-!
-! 1.1.4 riming of the small sized aggregates
-!
- WHERE ( GRIM(:) )
- ZZW1(:,1) = MIN( ZRCS(:), &
- XCRIMSS * ZZW(:) * ZRCT(:) & ! RCRIMSS
- * ZLBDAS(:)**XEXCRIMSS &
- * ZRHODREF(:)**(-XCEXVT) )
- ZRCS(:) = ZRCS(:) - ZZW1(:,1)
- ZRSS(:) = ZRSS(:) + ZZW1(:,1)
- ZTHS(:) = ZTHS(:) + ZZW1(:,1)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(RCRIMSS))
-!
- ZCCS(:) = MAX( ZCCS(:)-ZZW1(:,1)*(ZCCT(:)/ZRCT(:)),0.0 ) ! Lambda_c**3
- END WHERE
-!
-! 1.1.5 perform the linear interpolation of the normalized
-! "XBS"-moment of the incomplete gamma function
-!
- ZVEC1(1:IGRIM) = XGAMINC_RIM2( IVEC2(1:IGRIM)+1 )* ZVEC2(1:IGRIM) &
- - XGAMINC_RIM2( IVEC2(1:IGRIM) )*(ZVEC2(1:IGRIM) - 1.0)
- ZZW(:) = UNPACK( VECTOR=ZVEC1(:),MASK=GRIM,FIELD=0.0 )
-!
-! 1.1.6 riming-conversion of the large sized aggregates into graupeln
-!
-!
- WHERE ( GRIM(:) .AND. (ZRSS(:)>XRTMIN(5)/PTSTEP) )
- ZZW1(:,2) = MIN( ZRCS(:), &
- XCRIMSG * ZRCT(:) & ! RCRIMSG
- * ZLBDAS(:)**XEXCRIMSG &
- * ZRHODREF(:)**(-XCEXVT) &
- - ZZW1(:,1) )
- ZZW1(:,3) = MIN( ZRSS(:), &
- XSRIMCG * ZLBDAS(:)**XEXSRIMCG & ! RSRIMCG
- * (1.0 - ZZW(:) )/(PTSTEP*ZRHODREF(:)))
- ZRCS(:) = ZRCS(:) - ZZW1(:,2)
- ZRSS(:) = ZRSS(:) - ZZW1(:,3)
- ZRGS(:) = ZRGS(:) + ZZW1(:,2) + ZZW1(:,3)
- ZTHS(:) = ZTHS(:) + ZZW1(:,2)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(RCRIMSG))
-!
- ZCCS(:) = MAX( ZCCS(:)-ZZW1(:,2)*(ZCCT(:)/ZRCT(:)),0.0 ) ! Lambda_c**3
- END WHERE
- DEALLOCATE(IVEC2)
- DEALLOCATE(IVEC1)
- DEALLOCATE(ZVEC2)
- DEALLOCATE(ZVEC1)
-END IF
-!
-! Budget storage
-IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'RIM_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH ( &
- UNPACK(ZRCS(:),MASK=GMICRO(:,:,:),FIELD=PRCS)*PRHODJ(:,:,:), &
- 7,'RIM_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH ( &
- UNPACK(ZRSS(:),MASK=GMICRO(:,:,:),FIELD=PRSS)*PRHODJ(:,:,:), &
- 10,'RIM_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH ( &
- UNPACK(ZRGS(:),MASK=GMICRO(:,:,:),FIELD=PRGS)*PRHODJ(:,:,:), &
- 11,'RIM_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH (UNPACK(ZCCS(:),MASK=GMICRO(:,:,:),FIELD=PCCS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NC,'RIM_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
-END IF
-!
-!
-!* 1.2 Hallett-Mossop ice multiplication process due to snow riming
-! -----------------------------------------------------------------
-!
-!
-GRIM(:) = (ZZT(:)<XHMTMAX) .AND. (ZZT(:)>XHMTMIN) &
- .AND. (ZRST(:)>XRTMIN(5)) .AND. (ZRCT(:)>XRTMIN(2))
-IGRIM = COUNT( GRIM(:) )
-IF( IGRIM>0 ) THEN
- ALLOCATE(ZVEC1(IGRIM))
- ALLOCATE(ZVEC2(IGRIM))
- ALLOCATE(IVEC2(IGRIM))
-!
- ZVEC1(:) = PACK( ZLBDAC(:),MASK=GRIM(:) )
- ZVEC2(1:IGRIM) = MAX( 1.00001, MIN( FLOAT(NGAMINC)-0.00001, &
- XHMLINTP1 * LOG( ZVEC1(1:IGRIM) ) + XHMLINTP2 ) )
- IVEC2(1:IGRIM) = INT( ZVEC2(1:IGRIM) )
- ZVEC2(1:IGRIM) = ZVEC2(1:IGRIM) - FLOAT( IVEC2(1:IGRIM) )
- ZVEC1(1:IGRIM) = XGAMINC_HMC( IVEC2(1:IGRIM)+1 )* ZVEC2(1:IGRIM) &
- - XGAMINC_HMC( IVEC2(1:IGRIM) )*(ZVEC2(1:IGRIM) - 1.0)
- ZZX(:) = UNPACK( VECTOR=ZVEC1(:),MASK=GRIM,FIELD=0.0 ) ! Large droplets
-!
- WHERE ( GRIM(:) .AND. ZZX(:)<0.99 )
- ZZW1(:,5) = (ZZW1(:,1)+ZZW1(:,2))*(ZCCT(:)/ZRCT(:))*(1.0-ZZX(:))* &
- XHM_FACTS* &
- MAX( 0.0, MIN( (ZZT(:)-XHMTMIN)/3.0,(XHMTMAX-ZZT(:))/2.0 ) ) ! CCHMSI
- ZCIS(:) = ZCIS(:) + ZZW1(:,5)
-!
- ZZW1(:,6) = ZZW1(:,5) * XMNU0 ! RCHMSI
- ZRIS(:) = ZRIS(:) + ZZW1(:,6)
- ZRSS(:) = ZRSS(:) - ZZW1(:,6)
- END WHERE
- DEALLOCATE(IVEC2)
- DEALLOCATE(ZVEC2)
- DEALLOCATE(ZVEC1)
-END IF
-!
-! Budget storage
-IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GMICRO,FIELD=PRIS)*PRHODJ(:,:,:), &
- 9,'HMS_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH ( &
- UNPACK(ZRSS(:),MASK=GMICRO,FIELD=PRSS)*PRHODJ(:,:,:), &
- 10,'HMS_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH ( &
- UNPACK(ZCIS(:),MASK=GMICRO,FIELD=PCIS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NI,'HMS_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-END IF
-!
-!
-!* 1.3 Rain accretion onto the aggregates
-! ---------------------------------------
-!
-!
-ZZW1(:,2:3) = 0.0
-GACC(:) = (ZRRT(:)>XRTMIN(3)) .AND. (ZRST(:)>XRTMIN(5)) .AND. (ZRRS(:)>XRTMIN(3)/PTSTEP) .AND. (ZZT(:)<XTT)
-IGACC = COUNT( GACC(:) )
-!
-IF( IGACC>0 ) THEN
-!
-! 1.3.0 allocations
-!
- ALLOCATE(ZVEC1(IGACC))
- ALLOCATE(ZVEC2(IGACC))
- ALLOCATE(ZVEC3(IGACC))
- ALLOCATE(IVEC1(IGACC))
- ALLOCATE(IVEC2(IGACC))
-!
-! 1.3.1 select the (ZLBDAS,ZLBDAR) couplet
-!
- ZVEC1(:) = PACK( ZLBDAS(:),MASK=GACC(:) )
- ZVEC2(:) = PACK( ZLBDAR(:),MASK=GACC(:) )
-!
-! 1.3.2 find the next lower indice for the ZLBDAS and for the ZLBDAR
-! in the geometrical set of (Lbda_s,Lbda_r) couplet use to
-! tabulate the RACCSS-kernel
-!
- ZVEC1(1:IGACC) = MAX( 1.00001, MIN( FLOAT(NACCLBDAS)-0.00001, &
- XACCINTP1S * LOG( ZVEC1(1:IGACC) ) + XACCINTP2S ) )
- IVEC1(1:IGACC) = INT( ZVEC1(1:IGACC) )
- ZVEC1(1:IGACC) = ZVEC1(1:IGACC) - FLOAT( IVEC1(1:IGACC) )
-!
- ZVEC2(1:IGACC) = MAX( 1.00001, MIN( FLOAT(NACCLBDAR)-0.00001, &
- XACCINTP1R * LOG( ZVEC2(1:IGACC) ) + XACCINTP2R ) )
- IVEC2(1:IGACC) = INT( ZVEC2(1:IGACC) )
- ZVEC2(1:IGACC) = ZVEC2(1:IGACC) - FLOAT( IVEC2(1:IGACC) )
-!
-! 1.3.3 perform the bilinear interpolation of the normalized
-! RACCSS-kernel
-!
- DO JJ = 1,IGACC
- ZVEC3(JJ) = ( XKER_RACCSS(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_RACCSS(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * ZVEC1(JJ) &
- - ( XKER_RACCSS(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_RACCSS(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * (ZVEC1(JJ) - 1.0)
- END DO
- ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GACC,FIELD=0.0 )
-!
-! 1.3.4 raindrop accretion on the small sized aggregates
-!
- WHERE ( GACC(:) )
- ZZW1(:,2) = & !! coef of RRACCS
- XFRACCSS*( ZLBDAS(:)**XCXS )*( ZRHODREF(:)**(-XCEXVT-1.) ) &
- *( XLBRACCS1/((ZLBDAS(:)**2) ) + &
- XLBRACCS2/( ZLBDAS(:) * ZLBDAR(:) ) + &
- XLBRACCS3/( (ZLBDAR(:)**2)) )/ZLBDAR(:)**3
- ZZW1(:,4) = MIN( ZRRS(:),ZZW1(:,2)*ZZW(:) ) ! RRACCSS
- ZRRS(:) = ZRRS(:) - ZZW1(:,4)
- ZRSS(:) = ZRSS(:) + ZZW1(:,4)
- ZTHS(:) = ZTHS(:) + ZZW1(:,4)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(RRACCSS))
-!
- ZCRS(:) = MAX( ZCRS(:)-ZZW1(:,4)*(ZCRT(:)/ZRRT(:)),0.0 ) ! Lambda_r**3
- END WHERE
-!
-! 1.3.4b perform the bilinear interpolation of the normalized
-! RACCS-kernel
-!
- DO JJ = 1,IGACC
- ZVEC3(JJ) = ( XKER_RACCS(IVEC2(JJ)+1,IVEC1(JJ)+1)* ZVEC1(JJ) &
- - XKER_RACCS(IVEC2(JJ)+1,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
- * ZVEC2(JJ) &
- - ( XKER_RACCS(IVEC2(JJ) ,IVEC1(JJ)+1)* ZVEC1(JJ) &
- - XKER_RACCS(IVEC2(JJ) ,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
- * (ZVEC2(JJ) - 1.0)
- END DO
- ZZW1(:,2) = ZZW1(:,2)*UNPACK( VECTOR=ZVEC3(:),MASK=GACC(:),FIELD=0.0 ) !! RRACCS
-!
-! 1.3.5 perform the bilinear interpolation of the normalized
-! SACCRG-kernel
-!
- DO JJ = 1,IGACC
- ZVEC3(JJ) = ( XKER_SACCRG(IVEC2(JJ)+1,IVEC1(JJ)+1)* ZVEC1(JJ) &
- - XKER_SACCRG(IVEC2(JJ)+1,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
- * ZVEC2(JJ) &
- - ( XKER_SACCRG(IVEC2(JJ) ,IVEC1(JJ)+1)* ZVEC1(JJ) &
- - XKER_SACCRG(IVEC2(JJ) ,IVEC1(JJ) )*(ZVEC1(JJ) - 1.0) ) &
- * (ZVEC2(JJ) - 1.0)
- END DO
- ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GACC,FIELD=0.0 )
-!
-! 1.3.6 raindrop accretion-conversion of the large sized aggregates
-! into graupeln
-!
- WHERE ( GACC(:) .AND. (ZRSS(:)>XRTMIN(5)/PTSTEP) )
- ZZW1(:,2) = MIN( ZRRS(:),ZZW1(:,2)-ZZW1(:,4) ) ! RRACCSG
- ZZW1(:,3) = MIN( ZRSS(:),XFSACCRG*ZZW(:)* & ! RSACCRG
- ( ZLBDAS(:)**(XCXS-XBS) )*( ZRHODREF(:)**(-XCEXVT-1.) ) &
- *( XLBSACCR1/((ZLBDAR(:)**2) ) + &
- XLBSACCR2/( ZLBDAR(:) * ZLBDAS(:) ) + &
- XLBSACCR3/( (ZLBDAS(:)**2)) ) )
- ZRRS(:) = ZRRS(:) - ZZW1(:,2)
- ZRSS(:) = ZRSS(:) - ZZW1(:,3)
- ZRGS(:) = ZRGS(:) + ZZW1(:,2)+ZZW1(:,3)
- ZTHS(:) = ZTHS(:) + ZZW1(:,2)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(RRACCSG))
-!
- ZCRS(:) = MAX( ZCRS(:)-ZZW1(:,2)*(ZCRT(:)/ZRRT(:)),0.0 ) ! Lambda_r**3
- END WHERE
- DEALLOCATE(IVEC2)
- DEALLOCATE(IVEC1)
- DEALLOCATE(ZVEC3)
- DEALLOCATE(ZVEC2)
- DEALLOCATE(ZVEC1)
-END IF
-!
-IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'ACC_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH ( &
- UNPACK(ZRRS(:),MASK=GMICRO(:,:,:),FIELD=PRRS)*PRHODJ(:,:,:), &
- 8,'ACC_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH ( &
- UNPACK(ZRSS(:),MASK=GMICRO(:,:,:),FIELD=PRSS)*PRHODJ(:,:,:), &
- 10,'ACC_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH ( &
- UNPACK(ZRGS(:),MASK=GMICRO(:,:,:),FIELD=PRGS)*PRHODJ(:,:,:), &
- 11,'ACC_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH (UNPACK(ZCRS(:),MASK=GMICRO(:,:,:),FIELD=PCRS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NR,'ACC_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
-END IF
-!
-!
-!* 1.4 Conversion-Melting of the aggregates
-! -----------------------------------------
-!
-!
-ZZW(:) = 0.0
-WHERE( (ZRST(:)>XRTMIN(5)) .AND. (ZRSS(:)>XRTMIN(5)/PTSTEP) .AND. (ZZT(:)>XTT) )
- ZZW(:) = ZRVT(:)*ZPRES(:)/((XMV/XMD)+ZRVT(:)) ! Vapor pressure
- ZZW(:) = ZKA(:)*(XTT-ZZT(:)) + &
- ( ZDV(:)*(XLVTT + ( XCPV - XCL ) * ( ZZT(:) - XTT )) &
- *(XESTT-ZZW(:))/(XRV*ZZT(:)) )
-!
-! compute RSMLT
-!
- ZZW(:) = MIN( ZRSS(:), XFSCVMG*MAX( 0.0,( -ZZW(:) * &
- ( X0DEPS* ZLBDAS(:)**XEX0DEPS + &
- X1DEPS*ZCJ(:)*ZLBDAS(:)**XEX1DEPS ) - &
- ( ZZW1(:,1)+ZZW1(:,4) ) * &
- ( ZRHODREF(:)*XCL*(XTT-ZZT(:))) ) / &
- ( ZRHODREF(:)*XLMTT ) ) )
-!
-! note that RSCVMG = RSMLT*XFSCVMG but no heat is exchanged (at the rate RSMLT)
-! because the graupeln produced by this process are still icy!!!
-!
- ZRSS(:) = ZRSS(:) - ZZW(:)
- ZRGS(:) = ZRGS(:) + ZZW(:)
-END WHERE
-!
-! Budget storage
-IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_RS) CALL BUDGET_DDH ( &
- UNPACK(ZRSS(:),MASK=GMICRO(:,:,:),FIELD=PRSS)*PRHODJ(:,:,:), &
- 10,'CMEL_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH ( &
- UNPACK(ZRGS(:),MASK=GMICRO(:,:,:),FIELD=PRGS)*PRHODJ(:,:,:), &
- 11,'CMEL_BU_RRG',YDDDH, YDLDDH, YDMDDH)
-END IF
-!
-END IF ! LSNOW_LIMA
-!
-!------------------------------------------------------------------------------
-!
-! #################
-! FAST RG PROCESSES
-! #################
-!
-!
-!* 2.1 Rain contact freezing
-! --------------------------
-!
-!
-ZZW1(:,3:4) = 0.0
-WHERE( (ZRIT(:)>XRTMIN(4)) .AND. (ZRRT(:)>XRTMIN(3)) .AND. (ZRIS(:)>XRTMIN(4)/PTSTEP) .AND. (ZRRS(:)>XRTMIN(3)/PTSTEP) )
- ZZW1(:,3) = MIN( ZRIS(:),XICFRR * ZRIT(:) * ZCRT(:) & ! RICFRRG
- * ZLBDAR(:)**XEXICFRR &
- * ZRHODREF(:)**(-XCEXVT-1.0) )
-!
- ZZW1(:,4) = MIN( ZRRS(:),XRCFRI * ZCIT(:) * ZCRT(:) & ! RRCFRIG
- * ZLBDAR(:)**XEXRCFRI &
- * ZRHODREF(:)**(-XCEXVT-2.0) )
- ZRIS(:) = ZRIS(:) - ZZW1(:,3)
- ZRRS(:) = ZRRS(:) - ZZW1(:,4)
- ZRGS(:) = ZRGS(:) + ZZW1(:,3)+ZZW1(:,4)
- ZTHS(:) = ZTHS(:) + ZZW1(:,4)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*RRCFRIG)
-!
- ZCIS(:) = MAX( ZCIS(:)-ZZW1(:,3)*(ZCIT(:)/ZRIT(:)),0.0 ) ! CICFRRG
- ZCRS(:) = MAX( ZCRS(:)-ZZW1(:,4)*(ZCRT(:)/ZRRT(:)),0.0 ) ! CRCFRIG
-END WHERE
-!
-IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'CFRZ_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH ( &
- UNPACK(ZRRS(:),MASK=GMICRO(:,:,:),FIELD=PRRS)*PRHODJ(:,:,:), &
- 8,'CFRZ_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GMICRO(:,:,:),FIELD=PRIS)*PRHODJ(:,:,:), &
- 9,'CFRZ_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH ( &
- UNPACK(ZRGS(:),MASK=GMICRO(:,:,:),FIELD=PRGS)*PRHODJ(:,:,:), &
- 11,'CFRZ_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH ( UNPACK(ZCRS(:),MASK=GMICRO(:,:,:),FIELD=PCRS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NR,'CFRZ_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH ( UNPACK(ZCIS(:),MASK=GMICRO(:,:,:),FIELD=PCIS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NI,'CFRZ_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
-END IF
-!
-!
-!* 2.2 Compute the Dry growth case
-! --------------------------------
-!
-!
-ZZW1(:,:) = 0.0
-WHERE( ((ZRCT(:)>XRTMIN(2)) .AND. (ZRGT(:)>XRTMIN(6)) .AND. (ZRCS(:)>XRTMIN(2)/PTSTEP)) .OR. &
- ((ZRIT(:)>XRTMIN(4)) .AND. (ZRGT(:)>XRTMIN(6)) .AND. (ZRIS(:)>XRTMIN(4)/PTSTEP)) )
- ZZW(:) = ZLBDAG(:)**(XCXG-XDG-2.0) * ZRHODREF(:)**(-XCEXVT)
- ZZW1(:,1) = MIN( ZRCS(:),XFCDRYG * ZRCT(:) * ZZW(:) ) ! RCDRYG
- ZZW1(:,2) = MIN( ZRIS(:),XFIDRYG * EXP( XCOLEXIG*(ZZT(:)-XTT) ) &
- * ZRIT(:) * ZZW(:) ) ! RIDRYG
-END WHERE
-!
-!* 2.2.1 accretion of aggregates on the graupeln
-! ----------------------------------------------
-!
-GDRY(:) = (ZRST(:)>XRTMIN(5)) .AND. (ZRGT(:)>XRTMIN(6)) .AND. (ZRSS(:)>XRTMIN(5)/PTSTEP)
-IGDRY = COUNT( GDRY(:) )
-!
-IF( IGDRY>0 ) THEN
-!
-!* 2.2.2 allocations
-!
- ALLOCATE(ZVEC1(IGDRY))
- ALLOCATE(ZVEC2(IGDRY))
- ALLOCATE(ZVEC3(IGDRY))
- ALLOCATE(IVEC1(IGDRY))
- ALLOCATE(IVEC2(IGDRY))
-!
-!* 2.2.3 select the (ZLBDAG,ZLBDAS) couplet
-!
- ZVEC1(:) = PACK( ZLBDAG(:),MASK=GDRY(:) )
- ZVEC2(:) = PACK( ZLBDAS(:),MASK=GDRY(:) )
-!
-!* 2.2.4 find the next lower indice for the ZLBDAG and for the ZLBDAS
-! in the geometrical set of (Lbda_g,Lbda_s) couplet use to
-! tabulate the SDRYG-kernel
-!
- ZVEC1(1:IGDRY) = MAX( 1.00001, MIN( FLOAT(NDRYLBDAG)-0.00001, &
- XDRYINTP1G * LOG( ZVEC1(1:IGDRY) ) + XDRYINTP2G ) )
- IVEC1(1:IGDRY) = INT( ZVEC1(1:IGDRY) )
- ZVEC1(1:IGDRY) = ZVEC1(1:IGDRY) - FLOAT( IVEC1(1:IGDRY) )
-!
- ZVEC2(1:IGDRY) = MAX( 1.00001, MIN( FLOAT(NDRYLBDAS)-0.00001, &
- XDRYINTP1S * LOG( ZVEC2(1:IGDRY) ) + XDRYINTP2S ) )
- IVEC2(1:IGDRY) = INT( ZVEC2(1:IGDRY) )
- ZVEC2(1:IGDRY) = ZVEC2(1:IGDRY) - FLOAT( IVEC2(1:IGDRY) )
-!
-!* 2.2.5 perform the bilinear interpolation of the normalized
-! SDRYG-kernel
-!
- DO JJ = 1,IGDRY
- ZVEC3(JJ) = ( XKER_SDRYG(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_SDRYG(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * ZVEC1(JJ) &
- - ( XKER_SDRYG(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_SDRYG(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * (ZVEC1(JJ) - 1.0)
- END DO
- ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GDRY,FIELD=0.0 )
-!
- WHERE( GDRY(:) )
- ZZW1(:,3) = MIN( ZRSS(:),XFSDRYG*ZZW(:) & ! RSDRYG
- * EXP( XCOLEXSG*(ZZT(:)-XTT) ) &
- *( ZLBDAS(:)**(XCXS-XBS) )*( ZLBDAG(:)**XCXG ) &
- *( ZRHODREF(:)**(-XCEXVT-1.) ) &
- *( XLBSDRYG1/( ZLBDAG(:)**2 ) + &
- XLBSDRYG2/( ZLBDAG(:) * ZLBDAS(:) ) + &
- XLBSDRYG3/( ZLBDAS(:)**2) ) )
- END WHERE
- DEALLOCATE(IVEC2)
- DEALLOCATE(IVEC1)
- DEALLOCATE(ZVEC3)
- DEALLOCATE(ZVEC2)
- DEALLOCATE(ZVEC1)
-END IF
-!
-!* 2.2.6 accretion of raindrops on the graupeln
-! ---------------------------------------------
-!
-GDRY(:) = (ZRRT(:)>XRTMIN(3)) .AND. (ZRGT(:)>XRTMIN(6)) .AND. (ZRRS(:)>XRTMIN(3))
-IGDRY = COUNT( GDRY(:) )
-!
-IF( IGDRY>0 ) THEN
-!
-!* 2.2.7 allocations
-!
- ALLOCATE(ZVEC1(IGDRY))
- ALLOCATE(ZVEC2(IGDRY))
- ALLOCATE(ZVEC3(IGDRY))
- ALLOCATE(IVEC1(IGDRY))
- ALLOCATE(IVEC2(IGDRY))
-!
-!* 2.2.8 select the (ZLBDAG,ZLBDAR) couplet
-!
- ZVEC1(:) = PACK( ZLBDAG(:),MASK=GDRY(:) )
- ZVEC2(:) = PACK( ZLBDAR(:),MASK=GDRY(:) )
-!
-!* 2.2.9 find the next lower indice for the ZLBDAG and for the ZLBDAR
-! in the geometrical set of (Lbda_g,Lbda_r) couplet use to
-! tabulate the RDRYG-kernel
-!
- ZVEC1(1:IGDRY) = MAX( 1.00001, MIN( FLOAT(NDRYLBDAG)-0.00001, &
- XDRYINTP1G * LOG( ZVEC1(1:IGDRY) ) + XDRYINTP2G ) )
- IVEC1(1:IGDRY) = INT( ZVEC1(1:IGDRY) )
- ZVEC1(1:IGDRY) = ZVEC1(1:IGDRY) - FLOAT( IVEC1(1:IGDRY) )
-!
- ZVEC2(1:IGDRY) = MAX( 1.00001, MIN( FLOAT(NDRYLBDAR)-0.00001, &
- XDRYINTP1R * LOG( ZVEC2(1:IGDRY) ) + XDRYINTP2R ) )
- IVEC2(1:IGDRY) = INT( ZVEC2(1:IGDRY) )
- ZVEC2(1:IGDRY) = ZVEC2(1:IGDRY) - FLOAT( IVEC2(1:IGDRY) )
-!
-!* 2.2.10 perform the bilinear interpolation of the normalized
-! RDRYG-kernel
-!
- DO JJ = 1,IGDRY
- ZVEC3(JJ) = ( XKER_RDRYG(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_RDRYG(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * ZVEC1(JJ) &
- - ( XKER_RDRYG(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_RDRYG(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * (ZVEC1(JJ) - 1.0)
- END DO
- ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GDRY,FIELD=0.0 )
-!
- WHERE( GDRY(:) )
- ZZW1(:,4) = MIN( ZRRS(:),XFRDRYG*ZZW(:) & ! RRDRYG
- *( ZLBDAR(:)**(-3) )*( ZLBDAG(:)**XCXG ) &
- *( ZRHODREF(:)**(-XCEXVT-1.) ) &
- *( XLBRDRYG1/( ZLBDAG(:)**2 ) + &
- XLBRDRYG2/( ZLBDAG(:) * ZLBDAR(:) ) + &
- XLBRDRYG3/( ZLBDAR(:)**2) ) )
- END WHERE
- DEALLOCATE(IVEC2)
- DEALLOCATE(IVEC1)
- DEALLOCATE(ZVEC3)
- DEALLOCATE(ZVEC2)
- DEALLOCATE(ZVEC1)
-END IF
-!
-ZRDRYG(:) = ZZW1(:,1) + ZZW1(:,2) + ZZW1(:,3) + ZZW1(:,4)
-!
-!
-!* 2.3 Compute the Wet growth case
-! --------------------------------
-!
-!
-ZZW(:) = 0.0
-ZRWETG(:) = 0.0
-WHERE( ZRGT(:)>XRTMIN(6) )
- ZZW1(:,5) = MIN( ZRIS(:), &
- ZZW1(:,2) / (XCOLIG*EXP(XCOLEXIG*(ZZT(:)-XTT)) ) ) ! RIWETG
- ZZW1(:,6) = MIN( ZRSS(:), &
- ZZW1(:,3) / (XCOLSG*EXP(XCOLEXSG*(ZZT(:)-XTT)) ) ) ! RSWETG
-!
- ZZW(:) = ZRVT(:)*ZPRES(:)/((XMV/XMD)+ZRVT(:)) ! Vapor pressure
- ZZW(:) = ZKA(:)*(XTT-ZZT(:)) + &
- ( ZDV(:)*(XLVTT + ( XCPV - XCL ) * ( ZZT(:) - XTT )) &
- *(XESTT-ZZW(:))/(XRV*ZZT(:)) )
-!
-! compute RWETG
-!
- ZRWETG(:) = MAX( 0.0, &
- ( ZZW(:) * ( X0DEPG* ZLBDAG(:)**XEX0DEPG + &
- X1DEPG*ZCJ(:)*ZLBDAG(:)**XEX1DEPG ) + &
- ( ZZW1(:,5)+ZZW1(:,6) ) * &
- ( ZRHODREF(:)*(XLMTT+(XCI-XCL)*(XTT-ZZT(:))) ) ) / &
- ( ZRHODREF(:)*(XLMTT-XCL*(XTT-ZZT(:))) ) )
-END WHERE
-!
-!
-!* 2.4 Select Wet or Dry case
-! ---------------------------
-!
-!
-! Wet case and partial conversion to hail
-!
-ZZW(:) = 0.0
-NHAIL = 0.
-IF (LHAIL_LIMA) NHAIL = 1.
-WHERE( ZRGT(:)>XRTMIN(6) .AND. ZZT(:)<XTT &
- .AND. ZRDRYG(:)>=ZRWETG(:) .AND. ZRWETG(:)>0.0 )
-!
- ZZW(:) = ZRWETG(:) - ZZW1(:,5) - ZZW1(:,6) ! RCWETG+RRWETG
-!
-! limitation of the available rainwater mixing ratio (RRWETH < RRS !)
-!
- ZZW1(:,7) = MAX( 0.0,MIN( ZZW(:),ZRRS(:)+ZZW1(:,1) ) )
- ZZX(:) = ZZW1(:,7) / ZZW(:)
- ZZW1(:,5) = ZZW1(:,5)*ZZX(:)
- ZZW1(:,6) = ZZW1(:,6)*ZZX(:)
- ZRWETG(:) = ZZW1(:,7) + ZZW1(:,5) + ZZW1(:,6)
-!
- ZRCS(:) = ZRCS(:) - ZZW1(:,1)
- ZRIS(:) = ZRIS(:) - ZZW1(:,5)
- ZRSS(:) = ZRSS(:) - ZZW1(:,6)
-!
-! assume a linear percent of conversion of graupel into hail
-!
- ZRGS(:) = ZRGS(:) + ZRWETG(:)
- ZZW(:) = ZRGS(:)*ZRDRYG(:)*NHAIL/(ZRWETG(:)+ZRDRYG(:))
- ZRGS(:) = ZRGS(:) - ZZW(:)
- ZRHS(:) = ZRHS(:) + ZZW(:)
- ZRRS(:) = MAX( 0.0,ZRRS(:) - ZZW1(:,7) + ZZW1(:,1) )
- ZTHS(:) = ZTHS(:) + ZZW1(:,7)*(ZLSFACT(:)-ZLVFACT(:))
- ! f(L_f*(RCWETG+RRWETG))
-!
- ZCCS(:) = MAX( ZCCS(:)-ZZW1(:,1)*(ZCCT(:)/MAX(ZRCT(:),XRTMIN(2))),0.0 )
- ZCIS(:) = MAX( ZCIS(:)-ZZW1(:,5)*(ZCIT(:)/MAX(ZRIT(:),XRTMIN(4))),0.0 )
- ZCRS(:) = MAX( ZCRS(:)-MAX( ZZW1(:,7)-ZZW1(:,1),0.0 ) &
- *(ZCRT(:)/MAX(ZRRT(:),XRTMIN(3))),0.0 )
-END WHERE
-!
-! Budget storage
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'WETG_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH ( &
- UNPACK(ZRCS(:),MASK=GMICRO(:,:,:),FIELD=PRCS)*PRHODJ(:,:,:), &
- 7,'WETG_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH ( &
- UNPACK(ZRRS(:),MASK=GMICRO(:,:,:),FIELD=PRRS)*PRHODJ(:,:,:), &
- 8,'WETG_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GMICRO(:,:,:),FIELD=PRIS)*PRHODJ(:,:,:), &
- 9,'WETG_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH ( &
- UNPACK(ZRSS(:),MASK=GMICRO(:,:,:),FIELD=PRSS)*PRHODJ(:,:,:), &
- 10,'WETG_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH ( &
- UNPACK(ZRGS(:),MASK=GMICRO(:,:,:),FIELD=PRGS)*PRHODJ(:,:,:), &
- 11,'WETG_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RH) CALL BUDGET_DDH ( &
- UNPACK(ZRHS(:),MASK=GMICRO(:,:,:),FIELD=PRHS)*PRHODJ(:,:,:), &
- 12,'WETG_BU_RRH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH (UNPACK(ZCCS(:),MASK=GMICRO(:,:,:),FIELD=PCCS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NC,'WETG_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (UNPACK(ZCRS(:),MASK=GMICRO(:,:,:),FIELD=PCRS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NR,'WETG_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (UNPACK(ZCIS(:),MASK=GMICRO(:,:,:),FIELD=PCIS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NI,'WETG_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
- END IF
-!
-! Dry case
-!
-WHERE( ZRGT(:)>XRTMIN(6) .AND. ZZT(:)<XTT &
- .AND. ZRDRYG(:)<ZRWETG(:) .AND. ZRDRYG(:)>0.0 ) ! case
- ZRCS(:) = ZRCS(:) - ZZW1(:,1)
- ZRIS(:) = ZRIS(:) - ZZW1(:,2)
- ZRSS(:) = ZRSS(:) - ZZW1(:,3)
- ZRRS(:) = ZRRS(:) - ZZW1(:,4)
- ZRGS(:) = ZRGS(:) + ZRDRYG(:)
- ZTHS(:) = ZTHS(:) + (ZZW1(:,1)+ZZW1(:,4))*(ZLSFACT(:)-ZLVFACT(:)) !
- ! f(L_f*(RCDRYG+RRDRYG))
-!
- ZCCS(:) = MAX( ZCCS(:)-ZZW1(:,1)*(ZCCT(:)/MAX(ZRCT(:),XRTMIN(2))),0.0 )
- ZCIS(:) = MAX( ZCIS(:)-ZZW1(:,2)*(ZCIT(:)/MAX(ZRIT(:),XRTMIN(4))),0.0 )
- ZCRS(:) = MAX( ZCRS(:)-ZZW1(:,4)*(ZCRT(:)/MAX(ZRRT(:),XRTMIN(3))),0.0 )
- ! Approximate rates
-END WHERE
-!
-! Budget storage
-IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'DRYG_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH ( &
- UNPACK(ZRCS(:),MASK=GMICRO(:,:,:),FIELD=PRCS)*PRHODJ(:,:,:), &
- 7,'DRYG_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH ( &
- UNPACK(ZRRS(:),MASK=GMICRO(:,:,:),FIELD=PRRS)*PRHODJ(:,:,:), &
- 8,'DRYG_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GMICRO(:,:,:),FIELD=PRIS)*PRHODJ(:,:,:), &
- 9,'DRYG_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH ( &
- UNPACK(ZRSS(:),MASK=GMICRO(:,:,:),FIELD=PRSS)*PRHODJ(:,:,:), &
- 10,'DRYG_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH ( &
- UNPACK(ZRGS(:),MASK=GMICRO(:,:,:),FIELD=PRGS)*PRHODJ(:,:,:), &
- 11,'DRYG_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH ( UNPACK(ZCCS(:),MASK=GMICRO(:,:,:),FIELD=PCCS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NC,'DRYG_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH ( UNPACK(ZCRS(:),MASK=GMICRO(:,:,:),FIELD=PCRS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NR,'DRYG_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH ( UNPACK(ZCIS(:),MASK=GMICRO(:,:,:),FIELD=PCIS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NI,'DRYG_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
-END IF
-!
-!
-!* 2.5 Hallett-Mossop ice multiplication process due to graupel riming
-! --------------------------------------------------------------------
-!
-!
-GDRY(:) = (ZZT(:)<XHMTMAX) .AND. (ZZT(:)>XHMTMIN) .AND. (ZRDRYG(:)<ZZW(:))&
- .AND. (ZRGT(:)>XRTMIN(6)) .AND. (ZRCT(:)>XRTMIN(2))
-IGDRY = COUNT( GDRY(:) )
-IF( IGDRY>0 ) THEN
- ALLOCATE(ZVEC1(IGDRY))
- ALLOCATE(ZVEC2(IGDRY))
- ALLOCATE(IVEC2(IGDRY))
-!
- ZVEC1(:) = PACK( ZLBDAC(:),MASK=GDRY(:) )
- ZVEC2(1:IGDRY) = MAX( 1.00001, MIN( FLOAT(NGAMINC)-0.00001, &
- XHMLINTP1 * LOG( ZVEC1(1:IGDRY) ) + XHMLINTP2 ) )
- IVEC2(1:IGDRY) = INT( ZVEC2(1:IGDRY) )
- ZVEC2(1:IGDRY) = ZVEC2(1:IGDRY) - FLOAT( IVEC2(1:IGDRY) )
- ZVEC1(1:IGDRY) = XGAMINC_HMC( IVEC2(1:IGDRY)+1 )* ZVEC2(1:IGDRY) &
- - XGAMINC_HMC( IVEC2(1:IGDRY) )*(ZVEC2(1:IGDRY) - 1.0)
- ZZX(:) = UNPACK( VECTOR=ZVEC1(:),MASK=GDRY,FIELD=0.0 ) ! Large droplets
-!
- WHERE ( GDRY(:) .AND. ZZX(:)<0.99 ) ! Dry case
- ZZW1(:,5) = ZZW1(:,1)*(ZCCT(:)/ZRCT(:))*(1.0-ZZX(:))*XHM_FACTG* &
- MAX( 0.0, MIN( (ZZT(:)-XHMTMIN)/3.0,(XHMTMAX-ZZT(:))/2.0 ) ) ! CCHMGI
- ZCIS(:) = ZCIS(:) + ZZW1(:,5)
-!
- ZZW1(:,6) = ZZW1(:,5) * XMNU0 ! RCHMGI
- ZRIS(:) = ZRIS(:) + ZZW1(:,6)
- ZRGS(:) = ZRGS(:) - ZZW1(:,6)
- END WHERE
- DEALLOCATE(IVEC2)
- DEALLOCATE(ZVEC2)
- DEALLOCATE(ZVEC1)
-END IF
-!
-! Budget storage
-IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GMICRO,FIELD=PRIS)*PRHODJ(:,:,:), &
- 9,'HMG_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH ( &
- UNPACK(ZRGS(:),MASK=GMICRO,FIELD=PRGS)*PRHODJ(:,:,:), &
- 11,'HMG_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH ( &
- UNPACK(ZCIS(:),MASK=GMICRO,FIELD=PCIS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NI,'HMG_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-END IF
-!
-!
-!* 2.6 Melting of the graupeln
-! ----------------------------
-!
-!
-ZZW(:) = 0.0
-WHERE( (ZRGT(:)>XRTMIN(6)) .AND. (ZRGS(:)>XRTMIN(6)/PTSTEP) .AND. (ZZT(:)>XTT) )
- ZZW(:) = ZRVT(:)*ZPRES(:)/((XMV/XMD)+ZRVT(:)) ! Vapor pressure
- ZZW(:) = ZKA(:)*(XTT-ZZT(:)) + &
- ( ZDV(:)*(XLVTT + ( XCPV - XCL ) * ( ZZT(:) - XTT )) &
- *(XESTT-ZZW(:))/(XRV*ZZT(:)) )
-!
-! compute RGMLTR
-!
- ZZW(:) = MIN( ZRGS(:), MAX( 0.0,( -ZZW(:) * &
- ( X0DEPG* ZLBDAG(:)**XEX0DEPG + &
- X1DEPG*ZCJ(:)*ZLBDAG(:)**XEX1DEPG ) - &
- ( ZZW1(:,1)+ZZW1(:,4) ) * &
- ( ZRHODREF(:)*XCL*(XTT-ZZT(:))) ) / &
- ( ZRHODREF(:)*XLMTT ) ) )
- ZRRS(:) = ZRRS(:) + ZZW(:)
- ZRGS(:) = ZRGS(:) - ZZW(:)
- ZTHS(:) = ZTHS(:) - ZZW(:)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(-RGMLTR))
-!
-! ZCRS(:) = MAX( ZCRS(:) + ZZW(:)*(XCCG*ZLBDAG(:)**XCXG/ZRGT(:)),0.0 )
- ZCRS(:) = ZCRS(:) + ZZW(:)*5.0E6 ! obtained after averaging
- ! Dshed=1mm and 500 microns
-END WHERE
-!
-IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'GMLT_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH ( &
- UNPACK(ZRRS(:),MASK=GMICRO(:,:,:),FIELD=PRRS)*PRHODJ(:,:,:), &
- 8,'GMLT_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH ( &
- UNPACK(ZRGS(:),MASK=GMICRO(:,:,:),FIELD=PRGS)*PRHODJ(:,:,:), &
- 11,'GMLT_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH ( UNPACK(ZCRS(:),MASK=GMICRO(:,:,:),FIELD=PCRS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NR,'GMLT_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
-END IF
-!
-!
-!------------------------------------------------------------------------------
-!
-! #################
-! FAST RH PROCESSES
-! #################
-!
-!
-IF (LHAIL_LIMA) THEN
-!
-GHAIL(:) = ZRHT(:)>XRTMIN(7)
-IHAIL = COUNT(GHAIL(:))
-!
-IF( IHAIL>0 ) THEN
-!
-!* 3.1 Wet growth of hail
-! ----------------------------
-!
- ZZW1(:,:) = 0.0
- WHERE( GHAIL(:) .AND. ( (ZRCT(:)>XRTMIN(2) .AND. ZRCS(:)>XRTMIN(2)/PTSTEP) .OR. &
- (ZRIT(:)>XRTMIN(4) .AND. ZRIS(:)>XRTMIN(4)/PTSTEP) ) )
- ZZW(:) = ZLBDAH(:)**(XCXH-XDH-2.0) * ZRHODREF(:)**(-XCEXVT)
- ZZW1(:,1) = MIN( ZRCS(:),XFWETH * ZRCT(:) * ZZW(:) ) ! RCWETH
- ZZW1(:,2) = MIN( ZRIS(:),XFWETH * ZRIT(:) * ZZW(:) ) ! RIWETH
- END WHERE
-!
-!* 3.1.1 accretion of aggregates on the hailstones
-! ------------------------------------------------
-!
- GWET(:) = GHAIL(:) .AND. (ZRST(:)>XRTMIN(5) .AND. ZRSS(:)>XRTMIN(5)/PTSTEP)
- IGWET = COUNT( GWET(:) )
-!
- IF( IGWET>0 ) THEN
-!
-!* 3.1.2 allocations
-!
- ALLOCATE(ZVEC1(IGWET))
- ALLOCATE(ZVEC2(IGWET))
- ALLOCATE(ZVEC3(IGWET))
- ALLOCATE(IVEC1(IGWET))
- ALLOCATE(IVEC2(IGWET))
-!
-!* 3.1.3 select the (ZLBDAH,ZLBDAS) couplet
-!
- ZVEC1(:) = PACK( ZLBDAH(:),MASK=GWET(:) )
- ZVEC2(:) = PACK( ZLBDAS(:),MASK=GWET(:) )
-!
-!* 3.1.4 find the next lower indice for the ZLBDAG and for the ZLBDAS
-! in the geometrical set of (Lbda_h,Lbda_s) couplet use to
-! tabulate the SWETH-kernel
-!
- ZVEC1(1:IGWET) = MAX( 1.00001, MIN( FLOAT(NWETLBDAH)-0.00001, &
- XWETINTP1H * LOG( ZVEC1(1:IGWET) ) + XWETINTP2H ) )
- IVEC1(1:IGWET) = INT( ZVEC1(1:IGWET) )
- ZVEC1(1:IGWET) = ZVEC1(1:IGWET) - FLOAT( IVEC1(1:IGWET) )
-!
- ZVEC2(1:IGWET) = MAX( 1.00001, MIN( FLOAT(NWETLBDAS)-0.00001, &
- XWETINTP1S * LOG( ZVEC2(1:IGWET) ) + XWETINTP2S ) )
- IVEC2(1:IGWET) = INT( ZVEC2(1:IGWET) )
- ZVEC2(1:IGWET) = ZVEC2(1:IGWET) - FLOAT( IVEC2(1:IGWET) )
-!
-!* 3.1.5 perform the bilinear interpolation of the normalized
-! SWETH-kernel
-!
- DO JJ = 1,IGWET
- ZVEC3(JJ) = ( XKER_SWETH(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_SWETH(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * ZVEC1(JJ) &
- - ( XKER_SWETH(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_SWETH(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * (ZVEC1(JJ) - 1.0)
- END DO
- ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GWET,FIELD=0.0 )
-!
- WHERE( GWET(:) )
- ZZW1(:,3) = MIN( ZRSS(:),XFSWETH*ZZW(:) & ! RSWETH
- *( ZLBDAS(:)**(XCXS-XBS) )*( ZLBDAH(:)**XCXH ) &
- *( ZRHODREF(:)**(-XCEXVT-1.) ) &
- *( XLBSWETH1/( ZLBDAH(:)**2 ) + &
- XLBSWETH2/( ZLBDAH(:) * ZLBDAS(:) ) + &
- XLBSWETH3/( ZLBDAS(:)**2) ) )
- END WHERE
- DEALLOCATE(IVEC2)
- DEALLOCATE(IVEC1)
- DEALLOCATE(ZVEC3)
- DEALLOCATE(ZVEC2)
- DEALLOCATE(ZVEC1)
- END IF
-!
-!* 3.1.6 accretion of graupeln on the hailstones
-! ----------------------------------------------
-!
- GWET(:) = GHAIL(:) .AND. (ZRGT(:)>XRTMIN(6) .AND. ZRGS(:)>XRTMIN(6)/PTSTEP)
- IGWET = COUNT( GWET(:) )
-!
- IF( IGWET>0 ) THEN
-!
-!* 3.1.7 allocations
-!
- ALLOCATE(ZVEC1(IGWET))
- ALLOCATE(ZVEC2(IGWET))
- ALLOCATE(ZVEC3(IGWET))
- ALLOCATE(IVEC1(IGWET))
- ALLOCATE(IVEC2(IGWET))
-!
-!* 3.1.8 select the (ZLBDAH,ZLBDAG) couplet
-!
- ZVEC1(:) = PACK( ZLBDAH(:),MASK=GWET(:) )
- ZVEC2(:) = PACK( ZLBDAG(:),MASK=GWET(:) )
-!
-!* 3.1.9 find the next lower indice for the ZLBDAH and for the ZLBDAG
-! in the geometrical set of (Lbda_h,Lbda_g) couplet use to
-! tabulate the GWETH-kernel
-!
- ZVEC1(1:IGWET) = MAX( 1.00001, MIN( FLOAT(NWETLBDAG)-0.00001, &
- XWETINTP1H * LOG( ZVEC1(1:IGWET) ) + XWETINTP2H ) )
- IVEC1(1:IGWET) = INT( ZVEC1(1:IGWET) )
- ZVEC1(1:IGWET) = ZVEC1(1:IGWET) - FLOAT( IVEC1(1:IGWET) )
-!
- ZVEC2(1:IGWET) = MAX( 1.00001, MIN( FLOAT(NWETLBDAG)-0.00001, &
- XWETINTP1G * LOG( ZVEC2(1:IGWET) ) + XWETINTP2G ) )
- IVEC2(1:IGWET) = INT( ZVEC2(1:IGWET) )
- ZVEC2(1:IGWET) = ZVEC2(1:IGWET) - FLOAT( IVEC2(1:IGWET) )
-!
-!* 3.1.10 perform the bilinear interpolation of the normalized
-! GWETH-kernel
-!
- DO JJ = 1,IGWET
- ZVEC3(JJ) = ( XKER_GWETH(IVEC1(JJ)+1,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_GWETH(IVEC1(JJ)+1,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * ZVEC1(JJ) &
- - ( XKER_GWETH(IVEC1(JJ) ,IVEC2(JJ)+1)* ZVEC2(JJ) &
- - XKER_GWETH(IVEC1(JJ) ,IVEC2(JJ) )*(ZVEC2(JJ) - 1.0) ) &
- * (ZVEC1(JJ) - 1.0)
- END DO
- ZZW(:) = UNPACK( VECTOR=ZVEC3(:),MASK=GWET,FIELD=0.0 )
-!
- WHERE( GWET(:) )
- ZZW1(:,5) = MAX(MIN( ZRGS(:),XFGWETH*ZZW(:) & ! RGWETH
- *( ZLBDAG(:)**(XCXG-XBG) )*( ZLBDAH(:)**XCXH ) &
- *( ZRHODREF(:)**(-XCEXVT-1.) ) &
- *( XLBGWETH1/( ZLBDAH(:)**2 ) + &
- XLBGWETH2/( ZLBDAH(:) * ZLBDAG(:) ) + &
- XLBGWETH3/( ZLBDAG(:)**2) ) ),0. )
- END WHERE
- DEALLOCATE(IVEC2)
- DEALLOCATE(IVEC1)
- DEALLOCATE(ZVEC3)
- DEALLOCATE(ZVEC2)
- DEALLOCATE(ZVEC1)
- END IF
-!
-!* 3.2 compute the Wet growth of hail
-! -------------------------------------
-!
- ZZW(:) = 0.0
- WHERE( GHAIL(:) .AND. ZZT(:)<XTT )
- ZZW(:) = ZRVT(:)*ZPRES(:)/((XMV/XMD)+ZRVT(:)) ! Vapor pressure
- ZZW(:) = ZKA(:)*(XTT-ZZT(:)) + &
- ( ZDV(:)*(XLVTT + ( XCPV - XCL ) * ( ZZT(:) - XTT )) &
- *(XESTT-ZZW(:))/(XRV*ZZT(:)) )
-!
-! compute RWETH
-!
- ZZW(:) = MAX(0., ( ZZW(:) * ( X0DEPH* ZLBDAH(:)**XEX0DEPH + &
- X1DEPH*ZCJ(:)*ZLBDAH(:)**XEX1DEPH ) + &
- ( ZZW1(:,2)+ZZW1(:,3)+ZZW1(:,5) ) * &
- ( ZRHODREF(:)*(XLMTT+(XCI-XCL)*(XTT-ZZT(:))) ) ) / &
- ( ZRHODREF(:)*(XLMTT-XCL*(XTT-ZZT(:))) ) )
-!
- ZZW1(:,6) = MAX( ZZW(:) - ZZW1(:,2) - ZZW1(:,3) - ZZW1(:,5),0.) ! RCWETH+RRWETH
- END WHERE
- WHERE ( GHAIL(:) .AND. ZZT(:)<XTT .AND. ZZW1(:,6)/=0.)
-!
-! limitation of the available rainwater mixing ratio (RRWETH < RRS !)
-!
- ZZW1(:,4) = MAX( 0.0,MIN( ZZW1(:,6),ZRRS(:)+ZZW1(:,1) ) )
- ZZX(:) = ZZW1(:,4) / ZZW1(:,6)
- ZZW1(:,2) = ZZW1(:,2)*ZZX(:)
- ZZW1(:,3) = ZZW1(:,3)*ZZX(:)
- ZZW1(:,5) = ZZW1(:,5)*ZZX(:)
- ZZW(:) = ZZW1(:,4) + ZZW1(:,2) + ZZW1(:,3) + ZZW1(:,5)
-!
-!* 3.2.1 integrate the Wet growth of hail
-!
- ZRCS(:) = ZRCS(:) - ZZW1(:,1)
- ZRIS(:) = ZRIS(:) - ZZW1(:,2)
- ZRSS(:) = ZRSS(:) - ZZW1(:,3)
- ZRGS(:) = ZRGS(:) - ZZW1(:,5)
- ZRHS(:) = ZRHS(:) + ZZW(:)
- ZRRS(:) = MAX( 0.0,ZRRS(:) - ZZW1(:,4) + ZZW1(:,1) )
- ZTHS(:) = ZTHS(:) + ZZW1(:,4)*(ZLSFACT(:)-ZLVFACT(:))
- ! f(L_f*(RCWETH+RRWETH))
-!
- ZCCS(:) = MAX( ZCCS(:)-ZZW1(:,1)*(ZCCT(:)/MAX(ZRCT(:),XRTMIN(2))),0.0 )
- ZCIS(:) = MAX( ZCIS(:)-ZZW1(:,2)*(ZCIT(:)/MAX(ZRIT(:),XRTMIN(4))),0.0 )
- ZCRS(:) = MAX( ZCRS(:)-MAX( ZZW1(:,4)-ZZW1(:,1),0.0 ) &
- *(ZCRT(:)/MAX(ZRRT(:),XRTMIN(3))),0.0 )
- END WHERE
-!
-END IF ! IHAIL>0
-!
-!
-IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:), &
- 4,'WETH_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH ( &
- UNPACK(ZRCS(:),MASK=GMICRO(:,:,:),FIELD=PRCS)*PRHODJ(:,:,:), &
- 7,'WETH_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH ( &
- UNPACK(ZRRS(:),MASK=GMICRO(:,:,:),FIELD=PRRS)*PRHODJ(:,:,:), &
- 8,'WETH_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GMICRO(:,:,:),FIELD=PRIS)*PRHODJ(:,:,:), &
- 9,'WETH_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RS) CALL BUDGET_DDH ( &
- UNPACK(ZRSS(:),MASK=GMICRO(:,:,:),FIELD=PRSS)*PRHODJ(:,:,:), &
- 10,'WETH_BU_RRS',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH ( &
- UNPACK(ZRGS(:),MASK=GMICRO(:,:,:),FIELD=PRGS)*PRHODJ(:,:,:), &
- 11,'WETH_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RH) CALL BUDGET_DDH ( &
- UNPACK(ZRHS(:),MASK=GMICRO(:,:,:),FIELD=PRHS)*PRHODJ(:,:,:), &
- 12,'WETH_BU_RRH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH (UNPACK(ZCCS(:),MASK=GMICRO(:,:,:),FIELD=PCCS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NC,'WETH_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (UNPACK(ZCRS(:),MASK=GMICRO(:,:,:),FIELD=PCRS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NR,'WETH_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (UNPACK(ZCIS(:),MASK=GMICRO(:,:,:),FIELD=PCIS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NI,'WETH_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
-END IF
-!
-!
-! Partial reconversion of hail to graupel when rc and rh are small
-!
-!
-!* 3.3 Conversion of the hailstones into graupel
-! -----------------------------------------------
-!
-IF ( IHAIL>0 ) THEN
- ZTHRH=0.01E-3
- ZTHRC=0.001E-3
- ZZW(:) = 0.0
- WHERE( ZRHT(:)<ZTHRH .AND. ZRCT(:)<ZTHRC .AND. ZZT(:)<XTT )
- ZZW(:) = MIN( 1.0,MAX( 0.0,1.0-(ZRCT(:)/ZTHRC) ) )
-!
-! assume a linear percent conversion rate of hail into graupel
-!
- ZZW(:) = ZRHS(:)*ZZW(:)
- ZRGS(:) = ZRGS(:) + ZZW(:) ! partial conversion
- ZRHS(:) = ZRHS(:) - ZZW(:) ! of hail into graupel
-!
- END WHERE
-END IF
-!
-IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_RG) CALL BUDGET_DDH ( &
- UNPACK(ZRGS(:),MASK=GMICRO(:,:,:),FIELD=PRGS)*PRHODJ(:,:,:), &
- 11,'COHG_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RH) CALL BUDGET_DDH ( &
- UNPACK(ZRHS(:),MASK=GMICRO(:,:,:),FIELD=PRHS)*PRHODJ(:,:,:), &
- 12,'COHG_BU_RRH',YDDDH, YDLDDH, YDMDDH)
-END IF
-!
-!
-!* 3.4 Melting of the hailstones
-!
-IF ( IHAIL>0 ) THEN
- ZZW(:) = 0.0
- WHERE( GHAIL(:) .AND. (ZRHS(:)>XRTMIN(7)/PTSTEP) .AND. (ZRHT(:)>XRTMIN(7)) .AND. (ZZT(:)>XTT) )
- ZZW(:) = ZRVT(:)*ZPRES(:)/((XMV/XMD)+ZRVT(:)) ! Vapor pressure
- ZZW(:) = ZKA(:)*(XTT-ZZT(:)) + &
- ( ZDV(:)*(XLVTT + ( XCPV - XCL ) * ( ZZT(:) - XTT )) &
- *(XESTT-ZZW(:))/(XRV*ZZT(:)) )
-!
-! compute RHMLTR
-!
- ZZW(:) = MIN( ZRHS(:), MAX( 0.0,( -ZZW(:) * &
- ( X0DEPH* ZLBDAH(:)**XEX0DEPH + &
- X1DEPH*ZCJ(:)*ZLBDAH(:)**XEX1DEPH ) - &
- ZZW1(:,6)*( ZRHODREF(:)*XCL*(XTT-ZZT(:))) ) / &
- ( ZRHODREF(:)*XLMTT ) ) )
- ZRRS(:) = ZRRS(:) + ZZW(:)
- ZRHS(:) = ZRHS(:) - ZZW(:)
- ZTHS(:) = ZTHS(:) - ZZW(:)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(-RHMLTR))
-!
- ZCRS(:) = MAX( ZCRS(:) + ZZW(:)*(XCCH*ZLBDAH(:)**XCXH/ZRHT(:)),0.0 )
-!
- END WHERE
-END IF
-!
-IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'HMLT_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH ( &
- UNPACK(ZRRS(:),MASK=GMICRO(:,:,:),FIELD=PRRS)*PRHODJ(:,:,:), &
- 8,'HMLT_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RH) CALL BUDGET_DDH ( &
- UNPACK(ZRHS(:),MASK=GMICRO(:,:,:),FIELD=PRHS)*PRHODJ(:,:,:), &
- 12,'HMLT_BU_RRH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH ( UNPACK(ZCRS(:),MASK=GMICRO(:,:,:),FIELD=PCRS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NR,'HMLT_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
-END IF
-!
-END IF
-!
-!------------------------------------------------------------------------------
-!
-END SUBROUTINE LIMA_MIXED_FAST_PROCESSES
diff --git a/src/arome/micro/lima_mixed_slow_processes.F90 b/src/arome/micro/lima_mixed_slow_processes.F90
deleted file mode 100644
index ff8f782ce..000000000
--- a/src/arome/micro/lima_mixed_slow_processes.F90
+++ /dev/null
@@ -1,297 +0,0 @@
-! #####################################
- MODULE MODI_LIMA_MIXED_SLOW_PROCESSES
-! #####################################
-!
-INTERFACE
- SUBROUTINE LIMA_MIXED_SLOW_PROCESSES(ZRHODREF, ZZT, ZSSI, PTSTEP, &
- ZLSFACT, ZLVFACT, ZAI, ZCJ, &
- ZRGT, ZCIT, &
- ZRVS, ZRCS, ZRIS, ZRGS, ZTHS, &
- ZCCS, ZCIS, ZIFS, ZINS, &
- ZLBDAI, ZLBDAG, &
- ZRHODJ, GMICRO, PRHODJ, KMI, &
- PTHS, PRVS, PRCS, PRIS, PRGS, &
- PCCS, PCIS, &
- YDDDH, YDLDDH, YDMDDH )
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZRHODREF ! RHO Dry REFerence
-REAL, DIMENSION(:), INTENT(IN) :: ZZT ! Temperature
-REAL, DIMENSION(:), INTENT(IN) :: ZSSI ! Supersaturation over ice
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZLSFACT ! L_s/(Pi_ref*C_ph)
-REAL, DIMENSION(:), INTENT(IN) :: ZLVFACT ! L_v/(Pi_ref*C_ph)
-REAL, DIMENSION(:), INTENT(IN) :: ZAI ! Thermodynamical function
-REAL, DIMENSION(:), INTENT(IN) :: ZCJ ! for the ventilation coefficient
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZRGT ! Graupel/hail m.r. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZCIT ! Pristine ice conc. at t
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRVS ! Water vapor m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRCS ! Cloud water m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRGS ! Graupel/hail m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZTHS ! Theta source
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: ZCCS ! Cloud water conc. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZCIS ! Pristine ice conc. source
-REAL, DIMENSION(:,:), INTENT(INOUT) :: ZIFS ! Free Ice nuclei conc. source
-REAL, DIMENSION(:,:), INTENT(INOUT) :: ZINS ! Nucleated Ice nuclei conc. source
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZLBDAI ! Slope parameter of the ice crystal distr.
-REAL, DIMENSION(:), INTENT(IN) :: ZLBDAG ! Slope parameter of the graupel distr.
-!
-! used for budget storage
-REAL, DIMENSION(:), INTENT(IN) :: ZRHODJ
-LOGICAL, DIMENSION(:,:,:), INTENT(IN) :: GMICRO
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ
-INTEGER, INTENT(IN) :: KMI
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCCS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCIS
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-END SUBROUTINE LIMA_MIXED_SLOW_PROCESSES
-END INTERFACE
-END MODULE MODI_LIMA_MIXED_SLOW_PROCESSES
-!
-! #######################################################################
- SUBROUTINE LIMA_MIXED_SLOW_PROCESSES(ZRHODREF, ZZT, ZSSI, PTSTEP, &
- ZLSFACT, ZLVFACT, ZAI, ZCJ, &
- ZRGT, ZCIT, &
- ZRVS, ZRCS, ZRIS, ZRGS, ZTHS, &
- ZCCS, ZCIS, ZIFS, ZINS, &
- ZLBDAI, ZLBDAG, &
- ZRHODJ, GMICRO, PRHODJ, KMI, &
- PTHS, PRVS, PRCS, PRIS, PRGS, &
- PCCS, PCIS, &
- YDDDH, YDLDDH, YDMDDH )
-! #######################################################################
-!
-!!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the mixed-phase
-!! slow processes :
-!!
-!! Deposition of water vapor on graupeln
-!! Cloud ice Melting
-!! Bergeron-Findeisen effect
-!!
-!!** METHOD
-!! ------
-!!
-!! REFERENCE
-!! ---------
-!!
-!! Most of the parameterizations come from the ICE3 scheme, described in
-!! the MESO-NH scientific documentation.
-!!
-!! Cohard, J.-M. and J.-P. Pinty, 2000: A comprehensive two-moment warm
-!! microphysical bulk scheme.
-!! Part I: Description and tests
-!! Part II: 2D experiments with a non-hydrostatic model
-!! Accepted for publication in Quart. J. Roy. Meteor. Soc.
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!! C. Barthe * LACy * jan. 2014 add budgets
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_CST, ONLY : XTT, XALPI, XBETAI, XGAMI, &
- XALPW, XBETAW, XGAMW
-USE MODD_PARAM_LIMA, ONLY : XRTMIN, XCTMIN, NMOD_IFN
-USE MODD_PARAM_LIMA_COLD, ONLY : XDI, X0DEPI, X2DEPI, XSCFAC
-USE MODD_PARAM_LIMA_MIXED, ONLY : XLBG, XLBEXG, XLBDAG_MAX, &
- X0DEPG, XEX0DEPG, X1DEPG, XEX1DEPG
-!
-USE MODD_NSV
-USE MODD_BUDGET
-USE MODE_BUDGET, ONLY: BUDGET_DDH
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZRHODREF ! RHO Dry REFerence
-REAL, DIMENSION(:), INTENT(IN) :: ZZT ! Temperature
-REAL, DIMENSION(:), INTENT(IN) :: ZSSI ! Supersaturation over ice
-REAL, INTENT(IN) :: PTSTEP ! Time step
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZLSFACT ! L_s/(Pi_ref*C_ph)
-REAL, DIMENSION(:), INTENT(IN) :: ZLVFACT ! L_v/(Pi_ref*C_ph)
-REAL, DIMENSION(:), INTENT(IN) :: ZAI ! Thermodynamical function
-REAL, DIMENSION(:), INTENT(IN) :: ZCJ ! for the ventilation coefficient
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZRGT ! Graupel/hail m.r. at t
-REAL, DIMENSION(:), INTENT(IN) :: ZCIT ! Pristine ice conc. at t
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRVS ! Water vapor m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRCS ! Cloud water m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZRGS ! Graupel/hail m.r. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZTHS ! Theta source
-!
-REAL, DIMENSION(:), INTENT(INOUT) :: ZCCS ! Cloud water conc. source
-REAL, DIMENSION(:), INTENT(INOUT) :: ZCIS ! Pristine ice conc. source
-REAL, DIMENSION(:,:), INTENT(INOUT) :: ZIFS ! Free Ice nuclei conc. source
-REAL, DIMENSION(:,:), INTENT(INOUT) :: ZINS ! Nucleated Ice nuclei conc. source
-!
-REAL, DIMENSION(:), INTENT(IN) :: ZLBDAI ! Slope parameter of the ice crystal distr.
-REAL, DIMENSION(:), INTENT(IN) :: ZLBDAG ! Slope parameter of the graupel distr.
-!
-! used for budget storage
-REAL, DIMENSION(:), INTENT(IN) :: ZRHODJ
-LOGICAL, DIMENSION(:,:,:), INTENT(IN) :: GMICRO
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ
-INTEGER, INTENT(IN) :: KMI
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCCS
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCIS
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-!* 0.2 Declarations of local variables :
-!
-REAL, DIMENSION(SIZE(ZZT)) :: ZZW, ZMASK ! Work vectors
-!
-INTEGER :: JMOD_IFN
-!
-!-------------------------------------------------------------------------------
-!
-!* 1 Deposition of water vapor on r_g: RVDEPG
-! ---------------------------------------------
-!
-!
- ZZW(:) = 0.0
- WHERE ( (ZRGT(:)>XRTMIN(6)) .AND. (ZRGS(:)>XRTMIN(6)/PTSTEP) )
-!Correction BVIE RHODREF
-! ZZW(:) = ( ZSSI(:)/(ZRHODREF(:)*ZAI(:)) ) * &
- ZZW(:) = ( ZSSI(:)/(ZAI(:)) ) * &
- ( X0DEPG*ZLBDAG(:)**XEX0DEPG + X1DEPG*ZCJ(:)*ZLBDAG(:)**XEX1DEPG )
- ZZW(:) = MIN( ZRVS(:),ZZW(:) )*(0.5+SIGN(0.5,ZZW(:))) &
- - MIN( ZRGS(:),ABS(ZZW(:)) )*(0.5-SIGN(0.5,ZZW(:)))
- ZRGS(:) = ZRGS(:) + ZZW(:)
- ZRVS(:) = ZRVS(:) - ZZW(:)
- ZTHS(:) = ZTHS(:) + ZZW(:)*ZLSFACT(:)
- END WHERE
-!
-! Budget storage
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'DEPG_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RV) CALL BUDGET_DDH ( &
- UNPACK(ZRVS(:),MASK=GMICRO(:,:,:),FIELD=PRVS)*PRHODJ(:,:,:),&
- 6,'DEPG_BU_RRV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RG) CALL BUDGET_DDH ( &
- UNPACK(ZRGS(:),MASK=GMICRO(:,:,:),FIELD=PRGS)*PRHODJ(:,:,:), &
- 11,'DEPG_BU_RRG',YDDDH, YDLDDH, YDMDDH)
- END IF
-!
-!
-!* 2 cloud ice Melting: RIMLTC and CIMLTC
-! -----------------------------------------
-!
-!
- ZMASK(:) = 1.0
- WHERE( (ZRIS(:)>XRTMIN(4)/PTSTEP) .AND. (ZZT(:)>XTT) )
- ZRCS(:) = ZRCS(:) + ZRIS(:)
- ZTHS(:) = ZTHS(:) - ZRIS(:)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(-RIMLTC))
- ZRIS(:) = 0.0
-!
- ZCCS(:) = ZCCS(:) + ZCIS(:)
- ZCIS(:) = 0.0
- ZMASK(:)= 0.0
- END WHERE
- DO JMOD_IFN = 1,NMOD_IFN
-! Correction BVIE aerosols not released but in droplets
-! ZIFS(:,JMOD_IFN) = ZIFS(:,JMOD_IFN) + ZINS(:,JMOD_IFN)*(1.-ZMASK(:))
- ZINS(:,JMOD_IFN) = ZINS(:,JMOD_IFN) * ZMASK(:)
- ENDDO
-!
-! Budget storage
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'IMLT_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH ( &
- UNPACK(ZRCS(:),MASK=GMICRO(:,:,:),FIELD=PRCS)*PRHODJ(:,:,:), &
- 7,'IMLT_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GMICRO(:,:,:),FIELD=PRIS)*PRHODJ(:,:,:), &
- 9,'IMLT_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH (UNPACK(ZCCS(:),MASK=GMICRO(:,:,:),FIELD=PCCS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NC,'IMLT_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (UNPACK(ZCIS(:),MASK=GMICRO(:,:,:),FIELD=PCIS)*PRHODJ(:,:,:), &
- 12+NSV_LIMA_NI,'IMLT_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
- END IF
-!
-!
-!* 3 Bergeron-Findeisen effect: RCBERI
-! --------------------------------------
-!
-!
- ZZW(:) = 0.0
- WHERE( (ZRCS(:)>XRTMIN(2)/PTSTEP) .AND. (ZRIS(:)>XRTMIN(4)/PTSTEP) .AND. (ZCIT(:)>XCTMIN(4)) )
- ZZW(:) = EXP( (XALPW-XALPI) - (XBETAW-XBETAI)/ZZT(:) &
- - (XGAMW-XGAMI)*ALOG(ZZT(:)) ) -1.0
- ! supersaturation of saturated water over ice
- ZZW(:) = MIN( ZRCS(:),( ZZW(:) / ZAI(:) ) * ZCIT(:) * &
- ( X0DEPI/ZLBDAI(:)+X2DEPI*ZCJ(:)*ZCJ(:)/ZLBDAI(:)**(XDI+2.0) ) )
- ZRCS(:) = ZRCS(:) - ZZW(:)
- ZRIS(:) = ZRIS(:) + ZZW(:)
- ZTHS(:) = ZTHS(:) + ZZW(:)*(ZLSFACT(:)-ZLVFACT(:)) ! f(L_f*(RCBERI))
- END WHERE
-!
-! Budget storage
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GMICRO(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'BERFI_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH ( &
- UNPACK(ZRCS(:),MASK=GMICRO(:,:,:),FIELD=PRCS)*PRHODJ(:,:,:), &
- 7,'BERFI_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GMICRO(:,:,:),FIELD=PRIS)*PRHODJ(:,:,:), &
- 9,'BERFI_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- END IF
-!
-!------------------------------------------------------------------------------
-!
-END SUBROUTINE LIMA_MIXED_SLOW_PROCESSES
diff --git a/src/arome/micro/lima_phillips.F90 b/src/arome/micro/lima_phillips.F90
deleted file mode 100644
index 6791798d4..000000000
--- a/src/arome/micro/lima_phillips.F90
+++ /dev/null
@@ -1,675 +0,0 @@
-! #########################
- MODULE MODI_LIMA_PHILLIPS
-! #########################
-!
-INTERFACE
- SUBROUTINE LIMA_PHILLIPS (OHHONI, PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT, &
- PZZ, PRHODJ, PRHODREF, PEXNREF, PPABST, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
- PTHS, PRVS, PRCS, PRIS, &
- PCIT, PCCS, PCIS, &
- PNAS, PIFS, PINS, PNIS, &
- YDDDH, YDLDDH, YDMDDH )
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-LOGICAL, INTENT(IN) :: OHHONI ! enable haze freezing
-REAL, INTENT(IN) :: PTSTEP ! Time step
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Cloud ice m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGT ! Graupel m.r. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCIT ! Ice crystal C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCCS ! Cloud water C. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIS ! Ice crystal C. source
-!
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNAS ! Cloud C. nuclei C. source
- !used as Free ice nuclei for
- !IMMERSION freezing
-!
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PIFS ! Free ice nuclei C. source
- !for DEPOSITION and CONTACT
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PINS ! Activated ice nuclei C. source
- !for DEPOSITION and CONTACT
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNIS ! Activated ice nuclei C. source
- !for IMMERSION
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-END SUBROUTINE LIMA_PHILLIPS
-END INTERFACE
-END MODULE MODI_LIMA_PHILLIPS
-!
-! ######################################################################
- SUBROUTINE LIMA_PHILLIPS (OHHONI, PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT, &
- PZZ, PRHODJ, PRHODREF, PEXNREF, PPABST, &
- PTHT, PRVT, PRCT, PRRT, PRIT, PRST, PRGT, &
- PTHS, PRVS, PRCS, PRIS, &
- PCIT, PCCS, PCIS, &
- PNAS, PIFS, PINS, PNIS, &
- YDDDH, YDLDDH, YDMDDH )
-! ######################################################################
-!!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the heterogeneous nucleation
-!! following Phillips (2008).
-!!
-!!
-!!** METHOD
-!! ------
-!! The parameterization of Phillips (2008) is based on observed nucleation
-!! in the CFDC for a range of T and Si values. Phillips therefore defines a
-!! reference activity spectrum, that is, for given T and Si values, the
-!! reference concentration of primary ice crystals.
-!!
-!! The activation of IFN is closely related to their total surface. Thus,
-!! the activable fraction of each IFN specie is determined by an integration
-!! over the particle size distributions.
-!!
-!! Subroutine organisation :
-!!
-!! 1- Preliminary computations
-!! 2- Check where computations are necessary, and pack variables
-!! 3- Compute the saturation over water and ice
-!! 4- Compute the reference activity spectrum
-!! -> CALL LIMA_PHILLIPS_REF_SPECTRUM
-!! Integrate over the size distributions to compute the IFN activable fraction
-!! -> CALL LIMA_PHILLIPS_INTEG
-!! 5- Heterogeneous nucleation of insoluble IFN
-!! 6- Heterogeneous nucleation of coated IFN
-!! 7- Unpack variables & deallocations
-!!
-!!
-!! REFERENCE
-!! ---------
-!!
-!! Phillips et al., 2008: An empirical parameterization of heterogeneous
-!! ice nucleation for multiple chemical species of aerosols, J. Atmos. Sci.
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!! C. Barthe * LACy * jan. 2014 add budgets
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_PARAMETERS, ONLY : JPHEXT, JPVEXT
-USE MODD_CST, ONLY : XP00, XRD, XMV, XMD, XCPD, XCPV, XCL, XCI, &
- XTT, XLSTT, XLVTT, XALPI, XBETAI, XGAMI, &
- XALPW, XBETAW, XGAMW, XPI
-USE MODD_PARAM_LIMA, ONLY : NMOD_IFN, NSPECIE, XFRAC, &
- NMOD_CCN, NMOD_IMM, NIND_SPECIE, NINDICE_CCN_IMM, &
- XDSI0, XRTMIN, XCTMIN, NPHILLIPS
-USE MODD_PARAM_LIMA_COLD, ONLY : XMNU0
-!
-USE MODI_LIMA_FUNCTIONS, ONLY : COUNTJV
-USE MODI_LIMA_PHILLIPS_REF_SPECTRUM
-USE MODI_LIMA_PHILLIPS_INTEG
-!
-USE MODD_BUDGET
-USE MODE_BUDGET, ONLY: BUDGET_DDH
-USE MODD_NSV, ONLY : NSV_LIMA_NC, NSV_LIMA_NI, NSV_LIMA_IFN_FREE
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-LOGICAL, INTENT(IN) :: OHHONI ! enable haze freezing
-REAL, INTENT(IN) :: PTSTEP ! Time step
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRIT ! Cloud ice m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRGT ! Graupel m.r. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRIS ! Pristine ice m.r. source
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCIT ! Ice crystal C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCCS ! Cloud water C. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCIS ! Ice crystal C. source
-!
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNAS ! Cloud C. nuclei C. source
- !used as Free ice nuclei for
- !IMMERSION freezing
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PIFS ! Free ice nuclei C. source
- !for DEPOSITION and CONTACT
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PINS ! Activated ice nuclei C. source
- !for DEPOSITION and CONTACT
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNIS ! Activated ice nuclei C. source
- !for IMMERSION
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-!
-!* 0.2 Declarations of local variables :
-!
-!
-INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE ! Physical domain
-INTEGER :: JL, JMOD_CCN, JMOD_IFN, JSPECIE, JMOD_IMM ! Loop index
-INTEGER :: INEGT ! Case number of sedimentation, nucleation,
-!
-LOGICAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: GNEGT ! Test where to compute the nucleation
-!
-INTEGER, DIMENSION(SIZE(PRHODREF)) :: I1,I2,I3 ! Indexes for PACK replacement
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRRT ! Rain water m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRIT ! Pristine ice m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRST ! Snow/aggregate m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZRGT ! Graupel/hail m.r. at t
-REAL, DIMENSION(:), ALLOCATABLE :: ZCIT ! Pristine ice conc. at t
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZRVS ! Water vapor m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRCS ! Cloud water m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZRIS ! Pristine ice m.r. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZCCS ! Cloud water conc. source
-REAL, DIMENSION(:), ALLOCATABLE :: ZCIS ! Pristine ice conc. source
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZTHS ! Theta source
-!
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZNAS ! Cloud Cond. nuclei conc. source
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZIFS ! Free Ice nuclei conc. source
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZINS ! Nucleated Ice nuclei conc. source
- !by Deposition/Contact
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZNIS ! Nucleated Ice nuclei conc. source
- !by Immersion
-!
-REAL, DIMENSION(:), ALLOCATABLE &
- :: ZRHODREF, & ! RHO Dry REFerence
- ZRHODJ, & ! RHO times Jacobian
- ZZT, & ! Temperature
- ZPRES, & ! Pressure
- ZEXNREF, & ! EXNer Pressure REFerence
- ZZW, & ! Work array
- ZZX, & ! Work array
- ZZY, & ! Work array
- ZLSFACT, & ! L_s/(Pi_ref*C_ph)
- ZLVFACT, & ! L_v/(Pi_ref*C_ph)
- ZLBDAC, & ! Slope parameter of the cloud droplet distr.
- ZSI, &
- ZSW, &
- ZSI_W
-!
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: ZW, ZT ! work arrays
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZRTMIN, ZCTMIN
-!
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZSI0, & ! Si threshold in H_X for X={DM,BC,O}
- Z_FRAC_ACT ! Activable frac. of each AP species
-REAL, DIMENSION(:), ALLOCATABLE :: ZTCELSIUS, ZZT_SI0_BC
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 1. PRELIMINARY COMPUTATIONS
-! ------------------------
-!
-!
-! Physical domain
-!
-IIB=1+JPHEXT
-IIE=SIZE(PZZ,1) - JPHEXT
-IJB=1+JPHEXT
-IJE=SIZE(PZZ,2) - JPHEXT
-IKB=1+JPVEXT
-IKE=SIZE(PZZ,3) - JPVEXT
-!
-! Physical limitations
-!
-ALLOCATE(ZRTMIN(SIZE(XRTMIN)))
-ALLOCATE(ZCTMIN(SIZE(XCTMIN)))
-ZRTMIN(:) = XRTMIN(:) / PTSTEP
-ZCTMIN(:) = XCTMIN(:) / PTSTEP
-!
-! Temperature
-!
-ZT(:,:,:) = PTHT(:,:,:) * ( PPABST(:,:,:)/XP00 ) ** (XRD/XCPD)
-!
-! Saturation over ice
-!
-ZW(:,:,:) = EXP( XALPI - XBETAI/ZT(:,:,:) - XGAMI*ALOG(ZT(:,:,:) ) )
-ZW(:,:,:) = PRVT(:,:,:)*( PPABST(:,:,:)-ZW(:,:,:) ) / ( (XMV/XMD) * ZW(:,:,:) )
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 2. COMPUTATIONS ONLY WHERE NECESSARY : PACK
-! ----------------------------------------
-!
-!
-GNEGT(:,:,:) = .FALSE.
-GNEGT(IIB:IIE,IJB:IJE,IKB:IKE) = ZT(IIB:IIE,IJB:IJE,IKB:IKE)<XTT-2.0 .AND. &
- ZW(IIB:IIE,IJB:IJE,IKB:IKE)>0.95
-INEGT = COUNTJV( GNEGT(:,:,:),I1(:),I2(:),I3(:))
-!
-IF (INEGT > 0) THEN
-!
-ALLOCATE(ZRVT(INEGT))
-ALLOCATE(ZRCT(INEGT))
-ALLOCATE(ZRRT(INEGT))
-ALLOCATE(ZRIT(INEGT))
-ALLOCATE(ZRST(INEGT))
-ALLOCATE(ZRGT(INEGT))
-!
-ALLOCATE(ZCIT(INEGT))
-!
-ALLOCATE(ZRVS(INEGT))
-ALLOCATE(ZRCS(INEGT))
-ALLOCATE(ZRIS(INEGT))
-!
-ALLOCATE(ZTHS(INEGT))
-!
-ALLOCATE(ZCCS(INEGT))
-ALLOCATE(ZCIS(INEGT))
-!
-ALLOCATE(ZNAS(INEGT,NMOD_CCN))
-ALLOCATE(ZIFS(INEGT,NMOD_IFN))
-ALLOCATE(ZINS(INEGT,NMOD_IFN))
-ALLOCATE(ZNIS(INEGT,NMOD_IMM))
-!
-ALLOCATE(ZRHODREF(INEGT))
-ALLOCATE(ZZT(INEGT))
-ALLOCATE(ZPRES(INEGT))
-ALLOCATE(ZEXNREF(INEGT))
-!
-DO JL=1,INEGT
- ZRVT(JL) = PRVT(I1(JL),I2(JL),I3(JL))
- ZRCT(JL) = PRCT(I1(JL),I2(JL),I3(JL))
- ZRRT(JL) = PRRT(I1(JL),I2(JL),I3(JL))
- ZRIT(JL) = PRIT(I1(JL),I2(JL),I3(JL))
- ZRST(JL) = PRST(I1(JL),I2(JL),I3(JL))
- ZRGT(JL) = PRGT(I1(JL),I2(JL),I3(JL))
-!
- ZCIT(JL) = PCIT(I1(JL),I2(JL),I3(JL))
-!
- ZRVS(JL) = PRVS(I1(JL),I2(JL),I3(JL))
- ZRCS(JL) = PRCS(I1(JL),I2(JL),I3(JL))
- ZRIS(JL) = PRIS(I1(JL),I2(JL),I3(JL))
-!
- ZTHS(JL) = PTHS(I1(JL),I2(JL),I3(JL))
-!
- ZCCS(JL) = PCCS(I1(JL),I2(JL),I3(JL))
- ZCIS(JL) = PCIS(I1(JL),I2(JL),I3(JL))
-!
- DO JMOD_CCN = 1, NMOD_CCN
- ZNAS(JL,JMOD_CCN) = PNAS(I1(JL),I2(JL),I3(JL),JMOD_CCN)
- ENDDO
- DO JMOD_IFN = 1, NMOD_IFN
- ZIFS(JL,JMOD_IFN) = PIFS(I1(JL),I2(JL),I3(JL),JMOD_IFN)
- ZINS(JL,JMOD_IFN) = PINS(I1(JL),I2(JL),I3(JL),JMOD_IFN)
- ENDDO
- DO JMOD_IMM = 1, NMOD_IMM
- ZNIS(JL,JMOD_IMM) = PNIS(I1(JL),I2(JL),I3(JL),JMOD_IMM)
- ENDDO
- ZRHODREF(JL) = PRHODREF(I1(JL),I2(JL),I3(JL))
- ZZT(JL) = ZT(I1(JL),I2(JL),I3(JL))
- ZPRES(JL) = PPABST(I1(JL),I2(JL),I3(JL))
- ZEXNREF(JL) = PEXNREF(I1(JL),I2(JL),I3(JL))
-ENDDO
-!
-! PACK : done
-! Prepare computations
-!
-ALLOCATE( ZLSFACT (INEGT) )
-ALLOCATE( ZLVFACT (INEGT) )
-ALLOCATE( ZSI (INEGT) )
-ALLOCATE( ZTCELSIUS (INEGT) )
-ALLOCATE( ZZT_SI0_BC (INEGT) )
-ALLOCATE( ZLBDAC (INEGT) )
-ALLOCATE( ZSI0 (INEGT,NSPECIE) )
-ALLOCATE( Z_FRAC_ACT (INEGT,NSPECIE) ) ; Z_FRAC_ACT(:,:) = 0.0
-ALLOCATE( ZSW (INEGT) )
-ALLOCATE( ZSI_W (INEGT) )
-!
-ALLOCATE( ZZW (INEGT) ) ; ZZW(:) = 0.0
-ALLOCATE( ZZX (INEGT) ) ; ZZX(:) = 0.0
-ALLOCATE( ZZY (INEGT) ) ; ZZY(:) = 0.0
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 3. COMPUTE THE SATURATION OVER WATER AND ICE
-! -----------------------------------------
-!
-!
-ZTCELSIUS(:) = ZZT(:)-XTT ! T [°C]
-ZZW(:) = ZEXNREF(:)*( XCPD+XCPV*ZRVT(:)+XCL*(ZRCT(:)+ZRRT(:)) &
- +XCI*(ZRIT(:)+ZRST(:)+ZRGT(:)) )
-ZLSFACT(:) = (XLSTT+(XCPV-XCI)*ZTCELSIUS(:))/ZZW(:) ! L_s/(Pi_ref*C_ph)
-ZLVFACT(:) = (XLVTT+(XCPV-XCL)*ZTCELSIUS(:))/ZZW(:) ! L_v/(Pi_ref*C_ph)
-!
-ZZW(:) = EXP( XALPI - XBETAI/ZZT(:) - XGAMI*ALOG(ZZT(:) ) ) ! es_i
-ZSI(:) = ZRVT(:)*(ZPRES(:)-ZZW(:))/((XMV/XMD)*ZZW(:)) ! Saturation over ice
-!
-ZZY(:) = EXP( XALPW - XBETAW/ZZT(:) - XGAMW*ALOG(ZZT(:) ) ) ! es_w
-ZSW(:) = ZRVT(:)*(ZPRES(:)-ZZY(:))/((XMV/XMD)*ZZY(:)) ! Saturation over water
-!
-ZSI_W(:)= ZZY(:)/ZZW(:) ! Saturation over ice at water saturation: es_w/es_i
-!
-! Saturation parameters for H_X, with X={Dust/Metallic (2 modes), Black Carbon, Organic}
-!
-ZSI0(:,1) = 1.0 + 10.0**( -1.0261 + 3.1656E-3* ZTCELSIUS(:) &
- + 5.3938E-4*(ZTCELSIUS(:)**2) &
- + 8.2584E-6*(ZTCELSIUS(:)**3) ) ! with T [°C]
-ZSI0(:,2) = ZSI0(:,1) ! DM2 = DM1
-ZSI0(:,3) = 0.0 ! BC
-ZZT_SI0_BC(:) = MAX( 198.0, MIN( 239.0,ZZT(:) ) )
-ZSI0(:,3) = (-3.118E-5*ZZT_SI0_BC(:)+1.085E-2)*ZZT_SI0_BC(:)+0.5652 - XDSI0(3)
-IF (NPHILLIPS == 8) THEN
- ZSI0(:,4) = ZSI0(:,3) ! O = BC
-ELSE IF (NPHILLIPS == 13) THEN
- ZSI0(:,4) = 1.15 ! BIO
-END IF
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 4. COMPUTE THE ACTIVABLE FRACTION OF EACH IFN SPECIE
-! -------------------------------------------------
-!
-!
-! Computation of the reference activity spectrum ( ZZY = N_{IN,1,*} )
-!
-CALL LIMA_PHILLIPS_REF_SPECTRUM(ZZT, ZSI, ZSI_W, ZZY)
-!
-! For each aerosol species (DM1, DM2, BC, O), compute the fraction that may be activated
-! Z_FRAC_ACT(INEGT,NSPECIE) = fraction of each species that may be activated
-!
-CALL LIMA_PHILLIPS_INTEG(ZZT, ZSI, ZSI0, ZSW, ZZY, Z_FRAC_ACT)
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 5. COMPUTE THE HETEROGENEOUS NUCLEATION OF INSOLUBLE IFN
-! -----------------------------------------------------
-!
-!
-!
-DO JMOD_IFN = 1,NMOD_IFN ! IFN modes
- ZZX(:)=0.
- DO JSPECIE = 1, NSPECIE ! Each IFN mode is mixed with DM1, DM2, BC, O
- ZZX(:)=ZZX(:)+XFRAC(JSPECIE,JMOD_IFN)*(ZIFS(:,JMOD_IFN)+ZINS(:,JMOD_IFN))* &
- Z_FRAC_ACT(:,JSPECIE)
- END DO
-! Now : ZZX(:) = number of activable AP.
-! Activated AP at this time step = activable AP - already activated AP
- ZZX(:) = MIN( ZIFS(:,JMOD_IFN), MAX( (ZZX(:)-ZINS(:,JMOD_IFN)),0.0 ))
-! Correction BVIE division by PTSTEP ?
-! ZZW(:) = MIN( XMNU0*ZZX(:) / PTSTEP , ZRVS(:) )
- ZZW(:) = MIN( XMNU0*ZZX(:), ZRVS(:) )
-!
-! Update the concentrations and MMR
-!
- ZIFS(:,JMOD_IFN) = ZIFS(:,JMOD_IFN) - ZZX(:)
- ZW(:,:,:) = PIFS(:,:,:,JMOD_IFN)
- PIFS(:,:,:,JMOD_IFN) = UNPACK( ZIFS(:,JMOD_IFN), MASK=GNEGT(:,:,:), &
- FIELD=ZW(:,:,:) )
-!
- ZINS(:,JMOD_IFN) = ZINS(:,JMOD_IFN) + ZZX(:)
- ZW(:,:,:) = PINS(:,:,:,JMOD_IFN)
- PINS(:,:,:,JMOD_IFN) = UNPACK( ZINS(:,JMOD_IFN), MASK=GNEGT(:,:,:), &
- FIELD=ZW(:,:,:) )
-!
- ZRVS(:) = ZRVS(:) - ZZW(:)
- ZRIS(:) = ZRIS(:) + ZZW(:)
- ZTHS(:) = ZTHS(:) + ZZW(:)*ZLSFACT(:) !-ZLVFACT(:)) ! f(L_s*(RVHNDI))
- ZCIS(:) = ZCIS(:) + ZZX(:)
-END DO
-!
-!
-! Budget storage
-IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GNEGT(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'HIND_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RV) CALL BUDGET_DDH ( &
- UNPACK(ZRVS(:),MASK=GNEGT(:,:,:),FIELD=PRVS)*PRHODJ(:,:,:),&
- 6,'HIND_BU_RRV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GNEGT(:,:,:),FIELD=PRIS)*PRHODJ(:,:,:),&
- 9,'HIND_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH ( UNPACK(ZCIS(:),MASK=GNEGT(:,:,:),FIELD=PCIS)*PRHODJ(:,:,:),&
- 12+NSV_LIMA_NI,'HIND_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- IF (NMOD_IFN.GE.1) THEN
- DO JL=1, NMOD_IFN
- CALL BUDGET_DDH ( PIFS(:,:,:,JL)*PRHODJ(:,:,:),12+NSV_LIMA_IFN_FREE+JL-1,'HIND_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END DO
- END IF
- END IF
-END IF
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 6. COMPUTE THE HETEROGENEOUS NUCLEATION OF COATED IFN
-! --------------------------------------------------
-!
-!
-! Heterogeneous nucleation by immersion of the activated CCN
-! Currently, we represent coated IFN as a pure aerosol type (NIND_SPECIE)
-!
-!
-DO JMOD_IMM = 1,NMOD_IMM ! Coated IFN modes
- JMOD_CCN = NINDICE_CCN_IMM(JMOD_IMM) ! Corresponding CCN mode
- IF (JMOD_CCN .GT. 0) THEN
-!
-! OLD LIMA : Compute the appropriate mean diameter and sigma
-! XMDIAM_IMM = MIN( XMDIAM_IFN(NIND_SPECIE) , XR_MEAN_CCN(JMOD_CCN)*2. )
-! XSIGMA_IMM = MIN( XSIGMA_IFN(JSPECIE) , EXP(XLOGSIG_CCN(JMOD_CCN)) )
-!
- ZZW(:) = MIN( ZCCS(:) , ZNAS(:,JMOD_CCN) )
- ZZX(:)= ( ZZW(:)+ZNIS(:,JMOD_IMM) ) * Z_FRAC_ACT(:,NIND_SPECIE)
-! Now : ZZX(:) = number of activable AP.
-! Activated AP at this time step = activable AP - already activated AP
- ZZX(:) = MIN( ZZW(:), MAX( (ZZX(:)-ZNIS(:,JMOD_IMM)),0.0 ) )
-! Correction BVIE division by PTSTEP ?
-! ZZY(:) = MIN( XMNU0*ZZX(:) / PTSTEP , ZRVS(:) )
- ZZY(:) = MIN( XMNU0*ZZX(:) , ZRVS(:) )
-!
-! Update the concentrations and MMR
-!
- ZNAS(:,JMOD_CCN) = ZNAS(:,JMOD_CCN) - ZZX(:)
- ZW(:,:,:) = PNAS(:,:,:,JMOD_CCN)
- PNAS(:,:,:,JMOD_CCN) = UNPACK(ZNAS(:,JMOD_CCN),MASK=GNEGT(:,:,:), &
- FIELD=ZW(:,:,:))
- ZNIS(:,JMOD_IMM) = ZNIS(:,JMOD_IMM) + ZZX(:)
- ZW(:,:,:) = PNIS(:,:,:,JMOD_IMM)
- PNIS(:,:,:,JMOD_IMM) = UNPACK(ZNIS(:,JMOD_IMM),MASK=GNEGT(:,:,:), &
- FIELD=ZW(:,:,:))
-!
- ZRCS(:) = ZRCS(:) - ZZY(:)
- ZRIS(:) = ZRIS(:) + ZZY(:)
- ZTHS(:) = ZTHS(:) + ZZY(:)*ZLSFACT(:) !-ZLVFACT(:)) ! f(L_s*(RVHNCI))
- ZCCS(:) = ZCCS(:) - ZZX(:)
- ZCIS(:) = ZCIS(:) + ZZX(:)
- END IF
-END DO
-!
-! Budget storage
-IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH ( &
- UNPACK(ZTHS(:),MASK=GNEGT(:,:,:),FIELD=PTHS)*PRHODJ(:,:,:),&
- 4,'HINC_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH ( &
- UNPACK(ZRCS(:),MASK=GNEGT(:,:,:),FIELD=PRCS)*PRHODJ(:,:,:),&
- 7,'HINC_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH ( &
- UNPACK(ZRIS(:),MASK=GNEGT(:,:,:),FIELD=PRIS)*PRHODJ(:,:,:),&
- 9,'HINC_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH ( UNPACK(ZCCS(:),MASK=GNEGT(:,:,:),FIELD=PCCS)*PRHODJ(:,:,:),&
- 12+NSV_LIMA_NC,'HINC_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH ( UNPACK(ZCIS(:),MASK=GNEGT(:,:,:),FIELD=PCIS)*PRHODJ(:,:,:),&
- 12+NSV_LIMA_NI,'HINC_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
-END IF
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 7. UNPACK VARIABLES AND CLEAN
-! --------------------------
-!
-!
-! End of the heterogeneous nucleation following Phillips 08
-! Unpack variables, deallocate...
-!
-!
-ZW(:,:,:) = PRVS(:,:,:)
-PRVS(:,:,:) = UNPACK( ZRVS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
-ZW(:,:,:) = PRCS(:,:,:)
-PRCS(:,:,:) = UNPACK( ZRCS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
-ZW(:,:,:) = PRIS(:,:,:)
-PRIS(:,:,:) = UNPACK( ZRIS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
-ZW(:,:,:) = PTHS(:,:,:)
-PTHS(:,:,:) = UNPACK( ZTHS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
-ZW(:,:,:) = PCCS(:,:,:)
-PCCS(:,:,:) = UNPACK( ZCCS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
-ZW(:,:,:) = PCIS(:,:,:)
-PCIS(:,:,:) = UNPACK( ZCIS(:),MASK=GNEGT(:,:,:),FIELD=ZW(:,:,:) )
-!
-DEALLOCATE(ZRTMIN)
-DEALLOCATE(ZCTMIN)
-DEALLOCATE(ZRVT)
-DEALLOCATE(ZRCT)
-DEALLOCATE(ZRRT)
-DEALLOCATE(ZRIT)
-DEALLOCATE(ZRST)
-DEALLOCATE(ZRGT)
-DEALLOCATE(ZCIT)
-DEALLOCATE(ZRVS)
-DEALLOCATE(ZRCS)
-DEALLOCATE(ZRIS)
-DEALLOCATE(ZTHS)
-DEALLOCATE(ZCCS)
-DEALLOCATE(ZCIS)
-DEALLOCATE(ZNAS)
-DEALLOCATE(ZIFS)
-DEALLOCATE(ZINS)
-DEALLOCATE(ZNIS)
-DEALLOCATE(ZRHODREF)
-DEALLOCATE(ZZT)
-DEALLOCATE(ZPRES)
-DEALLOCATE(ZEXNREF)
-DEALLOCATE(ZLSFACT)
-DEALLOCATE(ZLVFACT)
-DEALLOCATE(ZSI)
-DEALLOCATE(ZTCELSIUS)
-DEALLOCATE(ZZT_SI0_BC)
-DEALLOCATE(ZLBDAC)
-DEALLOCATE(ZSI0)
-DEALLOCATE(Z_FRAC_ACT)
-DEALLOCATE(ZSW)
-DEALLOCATE(ZZW)
-DEALLOCATE(ZZX)
-DEALLOCATE(ZZY)
-DEALLOCATE(ZSI_W)
-!
-!
-ELSE
-!
-! Advance the budget calls
-!
- IF (NBUMOD==KMI .AND. LBU_ENABLE) THEN
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'HIND_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RV) CALL BUDGET_DDH (PRVS(:,:,:)*PRHODJ(:,:,:),6,'HIND_BU_RRV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9,'HIND_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- !print*, 'LBUDGET_SV dans lima_phillips = ', LBUDGET_SV
- CALL BUDGET_DDH (PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'HIND_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- IF (NMOD_IFN.GE.1) THEN
- DO JL=1, NMOD_IFN
- CALL BUDGET_DDH ( PIFS(:,:,:,JL)*PRHODJ(:,:,:),12+NSV_LIMA_IFN_FREE+JL-1,'HIND_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END DO
- END IF
- END IF
-
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'HINC_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:),7,'HINC_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RI) CALL BUDGET_DDH (PRIS(:,:,:)*PRHODJ(:,:,:),9,'HINC_BU_RRI',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- !print*, 'LBUDGET_SV dans lima_phillips = ', LBUDGET_SV
- CALL BUDGET_DDH (PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,'HINC_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- CALL BUDGET_DDH (PCIS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NI,'HINC_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
- END IF
-!
-!
-END IF ! INEGT > 0
-!
-!-------------------------------------------------------------------------------
-!
-END SUBROUTINE LIMA_PHILLIPS
diff --git a/src/arome/micro/lima_warm.F90 b/src/arome/micro/lima_warm.F90
deleted file mode 100644
index bcec12255..000000000
--- a/src/arome/micro/lima_warm.F90
+++ /dev/null
@@ -1,459 +0,0 @@
-! #####################
- MODULE MODI_LIMA_WARM
-! #####################
-!
-INTERFACE
- SUBROUTINE LIMA_WARM (OACTIT, OSEDC, ORAIN, KSPLITR, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, KRR, PZZ, PRHODJ, &
- PRHODREF, PEXNREF, PW_NU, PPABSM, PPABST, &
- PTHM, PRCM, &
- PTHT, PRT, PSVT, &
- PTHS, PRS, PSVS, &
- PINPRC, PINPRR, PINPRR3D, PEVAP3D, &
- YDDDH, YDLDDH, YDMDDH )
-
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-LOGICAL, INTENT(IN) :: OACTIT ! Switch to activate the
- ! activation by radiative
- ! tendency
-LOGICAL, INTENT(IN) :: OSEDC ! switch to activate the
- ! cloud droplet sedimentation
-LOGICAL, INTENT(IN) :: ORAIN ! switch to activate the
- ! rain formation by coalescence
-INTEGER, INTENT(IN) :: KSPLITR ! Number of small time step
- ! for sedimendation
-REAL, INTENT(IN) :: PTSTEP ! Double Time step
- ! (single if cold start)
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-INTEGER, INTENT(IN) :: KRR ! Number of moist variables
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PW_NU ! updraft velocity used for
- ! the nucleation param.
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSM ! abs. pressure at time t-dt
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHM ! Theta at time t-dt
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCM ! Cloud water m.r. at t-dt
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! m.r. at t
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PSVT ! Concentrations at t
-!
-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(INOUT) :: PINPRC ! Cloud instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRR ! Rain instant precip
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PINPRR3D ! Rain inst precip 3D
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PEVAP3D ! Rain evap profile
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-END SUBROUTINE LIMA_WARM
-END INTERFACE
-END MODULE MODI_LIMA_WARM
-! #####################################################################
- SUBROUTINE LIMA_WARM (OACTIT, OSEDC, ORAIN, KSPLITR, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, KRR, PZZ, PRHODJ, &
- PRHODREF, PEXNREF, PW_NU, PPABSM, PPABST, &
- PTHM, PRCM, &
- PTHT, PRT, PSVT, &
- PTHS, PRS, PSVS, &
- PINPRC, PINPRR, PINPRR3D, PEVAP3D, &
- YDDDH, YDLDDH, YDMDDH )
-! #####################################################################
-!
-!!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the warm microphysical
-!! sources: nucleation, sedimentation, autoconversion, accretion,
-!! self-collection and vaporisation which are parameterized according
-!! to Cohard and Pinty, QJRMS, 2000
-!!
-!!
-!!** METHOD
-!! ------
-!! The activation of CCN is checked for quasi-saturated air parcels
-!! to update the cloud droplet number concentration. Then assuming a
-!! generalized gamma distribution law for the cloud droplets and the
-!! raindrops, the zeroth and third order moments tendencies are evaluated
-!! for all the coalescence terms by integrating the Stochastic Collection
-!! Equation. As autoconversion is a process that cannot be resolved
-!! analytically, the Berry-Reinhardt parameterisation is employed with
-!! modifications to initiate the raindrop spectrum mode. The integration
-!! of the raindrop evaporation below clouds is straightforward.
-!!
-!! The sedimentation rates are computed with a time spliting technique:
-!! an upstream scheme, written as a difference of non-advective fluxes.
-!! This source term is added to the next coming time step (split-implicit
-!! process).
-!!
-!! REFERENCE
-!! ---------
-!!
-!! Cohard, J.-M. and J.-P. Pinty, 2000: A comprehensive two-moment warm
-!! microphysical bulk scheme.
-!! Part I: Description and tests
-!! Part II: 2D experiments with a non-hydrostatic model
-!! Accepted for publication in Quart. J. Roy. Meteor. Soc.
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!! C. Barthe * LACy * jan. 2014 add budgets
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE YOMLUN , ONLY : NULOUT
-!
-USE MODD_PARAMETERS
-USE MODD_CST
-USE MODD_CONF
-USE MODD_PARAM_LIMA
-USE MODD_PARAM_LIMA_WARM
-USE MODD_NSV
-!
-!
-USE MODD_BUDGET
-USE MODE_BUDGET, ONLY: BUDGET_DDH
-!
-USE MODI_LIMA_WARM_SEDIMENTATION
-USE MODI_LIMA_WARM_NUCL
-USE MODI_LIMA_WARM_COAL
-USE MODI_LIMA_WARM_EVAP
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-LOGICAL, INTENT(IN) :: OACTIT ! Switch to activate the
- ! activation by radiative
- ! tendency
-LOGICAL, INTENT(IN) :: OSEDC ! switch to activate the
- ! cloud droplet sedimentation
-LOGICAL, INTENT(IN) :: ORAIN ! switch to activate the
- ! rain formation by coalescence
-INTEGER, INTENT(IN) :: KSPLITR ! Number of small time step
- ! for sedimendation
-REAL, INTENT(IN) :: PTSTEP ! Double Time step
- ! (single if cold start)
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-INTEGER, INTENT(IN) :: KRR ! Number of moist variables
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ ! Dry density * Jacobian
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PW_NU ! updraft velocity used for
- ! the nucleation param.
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSM ! abs. pressure at time t-dt
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHM ! Theta at time t-dt
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCM ! Cloud water m.r. at t-dt
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PTHT ! Theta at time t
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PRT ! m.r. at t
-REAL, DIMENSION(:,:,:,:), INTENT(IN) :: PSVT ! Concentrations at t
-!
-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(INOUT) :: PINPRC ! Cloud instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRR ! Rain instant precip
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PINPRR3D ! Rain inst precip 3D
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PEVAP3D ! Rain evap profile
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-!* 0.2 Declarations of local variables :
-!
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: PRVT, & ! Water vapor m.r. at t
- PRCT, & ! Cloud water m.r. at t
- PRRT, & ! Rain water m.r. at t
- !
- PRVS, & ! Water vapor m.r. source
- PRCS, & ! Cloud water m.r. source
- PRRS, & ! Rain water m.r. source
- !
- PCCT, & ! Cloud water C. at t
- PCRT, & ! Rain water C. at t
- !
- PCCS, & ! Cloud water C. source
- PCRS ! Rain water C. source
-!
-REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: PNFS ! CCN C. available source
- !used as Free ice nuclei for
- !HOMOGENEOUS nucleation of haze
-REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: PNAS ! Cloud C. nuclei C. source
- !used as Free ice nuclei for
- !IMMERSION freezing
-!
-!
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: ZT, ZTM
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: ZWLBDR,ZWLBDR3,ZWLBDC,ZWLBDC3
-INTEGER :: JL
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 0. 3D MICROPHYSCAL VARIABLES
-! -------------------------
-!
-!
-! Prepare 3D water mixing ratios
-PRVT(:,:,:) = PRT(:,:,:,1)
-PRVS(:,:,:) = PRS(:,:,:,1)
-!
-PRCT(:,:,:) = 0.
-PRCS(:,:,:) = 0.
-PRRT(:,:,:) = 0.
-PRRS(:,:,:) = 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)
-!
-! Prepare 3D number concentrations
-PCCT(:,:,:) = 0.
-PCRT(:,:,:) = 0.
-PCCS(:,:,:) = 0.
-PCRS(:,:,:) = 0.
-!
-IF ( LWARM_LIMA ) PCCT(:,:,:) = PSVT(:,:,:,NSV_LIMA_NC)
-IF ( LWARM_LIMA .AND. LRAIN_LIMA ) PCRT(:,:,:) = PSVT(:,:,:,NSV_LIMA_NR)
-!
-IF ( LWARM_LIMA ) PCCS(:,:,:) = PSVS(:,:,:,NSV_LIMA_NC)
-IF ( LWARM_LIMA .AND. LRAIN_LIMA ) PCRS(:,:,:) = PSVS(:,:,:,NSV_LIMA_NR)
-!
-IF ( 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) )
- 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)
-ELSE
- ALLOCATE( PNFS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),1) )
- ALLOCATE( PNAS(SIZE(PRHODJ,1),SIZE(PRHODJ,2),SIZE(PRHODJ,3),1) )
- PNFS(:,:,:,:) = 0.
- PNAS(:,:,:,:) = 0.
-END IF
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 1. COMPUTE THE SLOPE PARAMETERS ZLBDC,ZLBDR
-! ----------------------------------------
-!
-!
-ZWLBDC3(:,:,:) = 1.E45
-ZWLBDC(:,:,:) = 1.E15
-!
-WHERE (PRCT(:,:,:)>XRTMIN(2) .AND. PCCT(:,:,:)>XCTMIN(2))
- ZWLBDC3(:,:,:) = XLBC * PCCT(:,:,:) / PRCT(:,:,:)
- ZWLBDC(:,:,:) = ZWLBDC3(:,:,:)**XLBEXC
-END WHERE
-!
-ZWLBDR3(:,:,:) = 1.E30
-ZWLBDR(:,:,:) = 1.E10
-WHERE (PRRT(:,:,:)>XRTMIN(3) .AND. PCRT(:,:,:)>XCTMIN(3))
- ZWLBDR3(:,:,:) = XLBR * PCRT(:,:,:) / PRRT(:,:,:)
- ZWLBDR(:,:,:) = ZWLBDR3(:,:,:)**XLBEXR
-END WHERE
-ZT(:,:,:) = PTHT(:,:,:) * (PPABST(:,:,:)/XP00)**(XRD/XCPD)
-IF( OACTIT ) THEN
- ZTM(:,:,:) = PTHM(:,:,:) * (PPABSM(:,:,:)/XP00)**(XRD/XCPD)
-ELSE
- ZTM(:,:,:) = ZT(:,:,:)
-END IF
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 2. COMPUTE THE SEDIMENTATION (RS) SOURCE
-! -------------------------------------
-!
-!
-CALL LIMA_WARM_SEDIMENTATION (OSEDC, KSPLITR, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, &
- PZZ, PRHODREF, PPABST, ZT, &
- ZWLBDC, &
- PRCT, PRRT, PCCT, PCRT, &
- PRCS, PRRS, PCCS, PCRS, &
- PINPRC, PINPRR, &
- PINPRR3D )
-!
-IF (LBUDGET_RC .AND. OSEDC) &
- CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:),7 ,'SEDI_BU_RRC',YDDDH, YDLDDH, YDMDDH)
-IF (LBUDGET_RR) CALL BUDGET_DDH (PRRS(:,:,:)*PRHODJ(:,:,:),8 ,'SEDI_BU_RRR',YDDDH, YDLDDH, YDMDDH)
-IF (LBUDGET_SV) THEN
- IF (OSEDC) CALL BUDGET_DDH (PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,&
- &'SEDI_BU_RSV',YDDDH, YDLDDH, YDMDDH) ! RCC
- IF (ORAIN) CALL BUDGET_DDH (PCRS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NR,&
- &'SEDI_BU_RSV',YDDDH, YDLDDH, YDMDDH) ! RCR
-END IF
-!
-!
-!-------------------------------------------------------------------------------
-!
-!* 2. COMPUTES THE NUCLEATION PROCESS SOURCES
-! --------------------------------------
-!
-!
-IF (LACTI_LIMA) THEN
-!
- CALL LIMA_WARM_NUCL (OACTIT, PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT,&
- PRHODREF, PEXNREF, PPABST, ZT, ZTM, PW_NU, &
- PRCM, PRVT, PRCT, PRRT, &
- PTHS, PRVS, PRCS, PCCS, PNFS, PNAS )
-!
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4,'HENU_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RV) CALL BUDGET_DDH (PRVS(:,:,:)*PRHODJ(:,:,:),6,'HENU_BU_RRV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:),7,'HENU_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) THEN
- CALL BUDGET_DDH (PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,'HENU_BU_RSV',YDDDH, YDLDDH, YDMDDH) ! RCN
- IF (NMOD_CCN.GE.1) THEN
- DO JL=1, NMOD_CCN
- CALL BUDGET_DDH ( PNFS(:,:,:,JL)*PRHODJ(:,:,:),12+NSV_LIMA_CCN_FREE+JL-1,'HENU_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END DO
- END IF
- END IF
-!
-END IF ! LACTI_LIMA
-!
-!
-!------------------------------------------------------------------------------
-!
-!* 3. COALESCENCE PROCESSES
-! ---------------------
-!
-!
- CALL LIMA_WARM_COAL (PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT, &
- PRHODREF, ZWLBDC3, ZWLBDC, ZWLBDR3, ZWLBDR, &
- PRCT, PRRT, PCCT, PCRT, &
- PRCS, PRRS, PCCS, PCRS, &
- PRHODJ,YDDDH, YDLDDH, YDMDDH )
-!
-!
-!-------------------------------------------------------------------------------
-!
-! 4. EVAPORATION OF RAINDROPS
-! ------------------------
-!
-!
-IF (ORAIN) THEN
-!
- CALL LIMA_WARM_EVAP (PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT, &
- PRHODREF, PEXNREF, PPABST, ZT, &
- ZWLBDC3, ZWLBDC, ZWLBDR3, ZWLBDR, &
- PRVT, PRCT, PRRT, PCRT, &
- PRVS, PRCS, PRRS, PCCS, PCRS, PTHS, &
- PEVAP3D )
-!
- IF (LBUDGET_RV) CALL BUDGET_DDH (PRVS(:,:,:)*PRHODJ(:,:,:),6 ,'REVA_BU_RRV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:),7 ,'REVA_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH (PRRS(:,:,:)*PRHODJ(:,:,:),8 ,'REVA_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_TH) CALL BUDGET_DDH (PTHS(:,:,:)*PRHODJ(:,:,:),4 ,'REVA_BU_RTH',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,'REVA_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCRS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NR,'REVA_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-!
-!
-!-------------------------------------------------------------------------------
-!
-! 5. SPONTANEOUS BREAK-UP (NUMERICAL FILTER)
-! --------------------
-!
- ZWLBDR(:,:,:) = 1.E10
- WHERE (PRRS(:,:,:)>XRTMIN(3)/PTSTEP.AND.PCRS(:,:,:)>XCTMIN(3)/PTSTEP )
- ZWLBDR3(:,:,:) = XLBR * PCRS(:,:,:) / PRRS(:,:,:)
- ZWLBDR(:,:,:) = ZWLBDR3(:,:,:)**XLBEXR
- END WHERE
- WHERE (ZWLBDR(:,:,:)<(XACCR1/XSPONBUD1))
- PCRS(:,:,:) = PCRS(:,:,:)*MAX((1.+XSPONCOEF2*(XACCR1/ZWLBDR(:,:,:)-XSPONBUD1)**2),&
- (XACCR1/ZWLBDR(:,:,:)/XSPONBUD3)**3)
- END WHERE
-!
-! Budget storage
- IF (LBUDGET_SV) &
- CALL BUDGET_DDH (PCRS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NR,&
- &'BRKU_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
-!
-ENDIF ! ORAIN
-!
-!------------------------------------------------------------------------------
-!
-!
-!* 6. REPORT 3D MICROPHYSICAL VARIABLES IN PRS AND PSVS
-! -------------------------------------------------
-!
-PRS(:,:,:,1) = PRVS(:,:,:)
-IF ( KRR .GE. 2 ) PRS(:,:,:,2) = PRCS(:,:,:)
-IF ( KRR .GE. 3 ) PRS(:,:,:,3) = PRRS(:,:,:)
-!
-! Prepare 3D number concentrations
-!
-IF ( LWARM_LIMA ) PSVS(:,:,:,NSV_LIMA_NC) = PCCS(:,:,:)
-IF ( LWARM_LIMA .AND. LRAIN_LIMA ) PSVS(:,:,:,NSV_LIMA_NR) = PCRS(:,:,:)
-!
-IF ( 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 (ALLOCATED(PNFS)) DEALLOCATE(PNFS)
-IF (ALLOCATED(PNAS)) DEALLOCATE(PNAS)
-!
-!-------------------------------------------------------------------------------
-!
-END SUBROUTINE LIMA_WARM
diff --git a/src/arome/micro/lima_warm_coal.F90 b/src/arome/micro/lima_warm_coal.F90
deleted file mode 100644
index cf7ade8f3..000000000
--- a/src/arome/micro/lima_warm_coal.F90
+++ /dev/null
@@ -1,513 +0,0 @@
-! ##########################
- MODULE MODI_LIMA_WARM_COAL
-! ##########################
-!
-INTERFACE
- SUBROUTINE LIMA_WARM_COAL (PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT, &
- PRHODREF, ZWLBDC3, ZWLBDC, ZWLBDR3, ZWLBDR, &
- PRCT, PRRT, PCCT, PCRT, &
- PRCS, PRRS, PCCS, PCRS, &
- PRHODJ, &
- YDDDH, YDLDDH, YDMDDH )
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-!
-REAL, INTENT(IN) :: PTSTEP ! Double Time step
- ! (single if cold start)
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Reference density
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZWLBDC3 ! Lambda(cloud) **3
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZWLBDC ! Lambda(cloud)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZWLBDR3 ! Lambda(rain) **3
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZWLBDR ! Lambda(rain)
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCCT ! Cloud water C. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCRT ! Rain water C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCCS ! Cloud water C. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCRS ! Rain water C. source
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
- END SUBROUTINE LIMA_WARM_COAL
-END INTERFACE
-END MODULE MODI_LIMA_WARM_COAL
-! #############################################################################
- SUBROUTINE LIMA_WARM_COAL (PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT, &
- PRHODREF, ZWLBDC3, ZWLBDC, ZWLBDR3, ZWLBDR, &
- PRCT, PRRT, PCCT, PCRT, &
- PRCS, PRRS, PCCS, PCRS, &
- PRHODJ, &
- YDDDH, YDLDDH, YDMDDH )
-! #############################################################################
-!
-!!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the microphysical sources:
-!! nucleation, sedimentation, autoconversion, accretion, self-collection
-!! and vaporisation which are parameterized according to Cohard and Pinty
-!! QJRMS, 2000
-!!
-!!
-!!** METHOD
-!! ------
-!! Assuming a generalized gamma distribution law for the cloud droplets
-!! and the raindrops, the zeroth and third order moments tendencies
-!! are evaluated for all the coalescence terms by integrating the
-!! Stochastic Collection Equation. As autoconversion is a process that
-!! cannot be resolved analytically, the Berry-Reinhardt parameterisation
-!! is employed with modifications to initiate the raindrop spectrum mode.
-!!
-!! Computation steps :
-!! 1- Check where computations are necessary, pack variables
-!! 2- Self collection of cloud droplets
-!! 3- Autoconversion of cloud droplets (Berry-Reinhardt parameterization)
-!! 4- Accretion sources
-!! 5- Self collection - Coalescence/Break-up
-!! 6- Unpack variables, clean
-!!
-!!
-!! REFERENCE
-!! ---------
-!!
-!! Cohard, J.-M. and J.-P. Pinty, 2000: A comprehensive two-moment warm
-!! microphysical bulk scheme.
-!! Part I: Description and tests
-!! Part II: 2D experiments with a non-hydrostatic model
-!! Accepted for publication in Quart. J. Roy. Meteor. Soc.
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!! C. Barthe * LACy * jan. 2014 add budgets
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_PARAMETERS, ONLY : JPHEXT, JPVEXT
-USE MODD_PARAM_LIMA
-USE MODD_PARAM_LIMA_WARM
-!
-USE MODD_NSV, ONLY : NSV_LIMA_NC, NSV_LIMA_NR
-USE MODD_BUDGET
-USE MODE_BUDGET, ONLY: BUDGET_DDH
-!
-USE MODI_LIMA_FUNCTIONS, ONLY : COUNTJV
-!
-USE DDH_MIX, ONLY : TYP_DDH
-USE YOMLDDH, ONLY : TLDDH
-USE YOMMDDH, ONLY : TMDDH
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-REAL, INTENT(IN) :: PTSTEP ! Double Time step
- ! (single if cold start)
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Reference density
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZWLBDC3 ! Lambda(cloud) **3
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZWLBDC ! Lambda(cloud)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZWLBDR3 ! Lambda(rain) **3
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZWLBDR ! Lambda(rain)
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCCT ! Cloud water C. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCRT ! Rain water C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCCS ! Cloud water C. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCRS ! Rain water C. source
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODJ
-!
-TYPE(TYP_DDH), INTENT(INOUT) :: YDDDH
-TYPE(TLDDH), INTENT(IN) :: YDLDDH
-TYPE(TMDDH), INTENT(IN) :: YDMDDH
-!
-!* 0.1 Declarations of local variables :
-!
-! Packing variables
-LOGICAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: GMICRO
-INTEGER :: IMICRO
-INTEGER , DIMENSION(SIZE(GMICRO)) :: I1,I2,I3 ! Used to replace the COUNT
-INTEGER :: JL ! and PACK intrinsics
-!
-! Packed micophysical variables
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRRT ! Rain water m.r. at t
-REAL, DIMENSION(:) , ALLOCATABLE :: ZCCT ! cloud conc. at t
-REAL, DIMENSION(:) , ALLOCATABLE :: ZCRT ! rain conc. at t
-!
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRCS ! Cloud water m.r. source
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRRS ! Rain water m.r. source
-REAL, DIMENSION(:) , ALLOCATABLE :: ZCCS ! cloud conc. source
-REAL, DIMENSION(:) , ALLOCATABLE :: ZCRS ! rain conc. source
-!
-! Other packed variables
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRHODREF ! RHO Dry REFerence
-REAL, DIMENSION(:) , ALLOCATABLE :: ZLBDC3
-REAL, DIMENSION(:) , ALLOCATABLE :: ZLBDC
-REAL, DIMENSION(:) , ALLOCATABLE :: ZLBDR3
-REAL, DIMENSION(:) , ALLOCATABLE :: ZLBDR
-!
-! Work arrays
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: ZW
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZZW1, ZZW2, ZZW3, ZZW4, ZSCBU
-LOGICAL, DIMENSION(:), ALLOCATABLE :: GSELF, &
- GACCR, &
- GSCBU, &
- GENABLE_ACCR_SCBU
-!
-!
-INTEGER :: ISELF, IACCR, ISCBU
-INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE ! Physical domain
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 1. PREPARE COMPUTATIONS - PACK
-! ---------------------------
-!
-!
-IIB=1+JPHEXT
-IIE=SIZE(PRHODREF,1) - JPHEXT
-IJB=1+JPHEXT
-IJE=SIZE(PRHODREF,2) - JPHEXT
-IKB=1+JPVEXT
-IKE=SIZE(PRHODREF,3) - JPVEXT
-!
-GMICRO(:,:,:) = .FALSE.
-GMICRO(IIB:IIE,IJB:IJE,IKB:IKE) = &
- PRCT(IIB:IIE,IJB:IJE,IKB:IKE)>XRTMIN(2) .OR. &
- PRRT(IIB:IIE,IJB:IJE,IKB:IKE)>XRTMIN(3)
-!
-IMICRO = COUNTJV( GMICRO(:,:,:),I1(:),I2(:),I3(:))
-!
-IF( IMICRO >= 1 ) THEN
- ALLOCATE(ZRCT(IMICRO))
- ALLOCATE(ZRRT(IMICRO))
- ALLOCATE(ZCCT(IMICRO))
- ALLOCATE(ZCRT(IMICRO))
-!
- ALLOCATE(ZRCS(IMICRO))
- ALLOCATE(ZRRS(IMICRO))
- ALLOCATE(ZCCS(IMICRO))
- ALLOCATE(ZCRS(IMICRO))
-!
- ALLOCATE(ZLBDC(IMICRO))
- ALLOCATE(ZLBDC3(IMICRO))
- ALLOCATE(ZLBDR(IMICRO))
- ALLOCATE(ZLBDR3(IMICRO))
-!
- ALLOCATE(ZRHODREF(IMICRO))
- DO JL=1,IMICRO
- ZCCT(JL) = PCCT(I1(JL),I2(JL),I3(JL))
- ZRCT(JL) = PRCT(I1(JL),I2(JL),I3(JL))
- ZRRT(JL) = PRRT(I1(JL),I2(JL),I3(JL))
- ZCRT(JL) = PCRT(I1(JL),I2(JL),I3(JL))
- ZCCS(JL) = PCCS(I1(JL),I2(JL),I3(JL))
- ZRCS(JL) = PRCS(I1(JL),I2(JL),I3(JL))
- ZRRS(JL) = PRRS(I1(JL),I2(JL),I3(JL))
- ZCRS(JL) = PCRS(I1(JL),I2(JL),I3(JL))
- ZLBDR(JL) = ZWLBDR(I1(JL),I2(JL),I3(JL))
- ZLBDR3(JL) = ZWLBDR3(I1(JL),I2(JL),I3(JL))
- ZLBDC(JL) = ZWLBDC(I1(JL),I2(JL),I3(JL))
- ZLBDC3(JL) = ZWLBDC3(I1(JL),I2(JL),I3(JL))
- ZRHODREF(JL) = PRHODREF(I1(JL),I2(JL),I3(JL))
- END DO
-!
- ALLOCATE(GSELF(IMICRO))
- ALLOCATE(GACCR(IMICRO))
- ALLOCATE(GSCBU(IMICRO))
- ALLOCATE(ZZW1(IMICRO))
- ALLOCATE(ZZW2(IMICRO))
- ALLOCATE(ZZW3(IMICRO))
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 2. Self-collection of cloud droplets
-! ------------------------------------
-!
-!
- GSELF(:) = ZCCT(:)>XCTMIN(2)
- ISELF = COUNT(GSELF(:))
- IF( ISELF>0 ) THEN
- ZZW1(:) = XSELFC*(ZCCT(:)/ZLBDC3(:))**2 * ZRHODREF(:) ! analytical integration
- WHERE( GSELF(:) )
- ZCCS(:) = ZCCS(:) - MIN( ZCCS(:),ZZW1(:) )
- END WHERE
- END IF
-!
-!
- ZW(:,:,:) = PCCS(:,:,:)
- IF (LBUDGET_SV) CALL BUDGET_DDH ( &
- UNPACK(ZCCS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:))&
- &*PRHODJ(:,:,:),12+NSV_LIMA_NC,'SELF_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 3. Autoconversion of cloud droplets (Berry-Reinhardt parameterization)
-! ----------------------------------------------------------------------
-!
-!
-IF (LRAIN_LIMA) THEN
-!
- ZZW2(:) = 0.0
- ZZW1(:) = 0.0
- WHERE( ZRCT(:)>XRTMIN(2) )
- ZZW2(:) = MAX( 0.0,XLAUTR*ZRHODREF(:)*ZRCT(:)* &
- (XAUTO1/ZLBDC(:)**4-XLAUTR_THRESHOLD) ) ! L
-!
- ZZW3(:) = MIN( ZRCS(:), MAX( 0.0,XITAUTR*ZZW2(:)*ZRCT(:)* &
- (XAUTO2/ZLBDC(:)-XITAUTR_THRESHOLD) ) ) ! L/tau
-!
- ZRCS(:) = ZRCS(:) - ZZW3(:)
- ZRRS(:) = ZRRS(:) + ZZW3(:)
-!
- ZZW1(:) = MIN( MIN( 1.2E4,(XACCR4/ZLBDC(:)-XACCR5)/XACCR3), &
- ZLBDR(:)/XACCR1 ) ! D**-1 threshold diameter for
- ! switching the autoconversion regimes
- ! min (80 microns, D_h, D_r)
- ZZW3(:) = ZZW3(:) * MAX( 0.0,ZZW1(:) )**3 / XAC
- ZCRS(:) = ZCRS(:) + ZZW3(:)
- END WHERE
-!
-!
- ZW(:,:,:) = PRCS(:,:,:)
- IF (LBUDGET_RC) CALL BUDGET_DDH ( &
- UNPACK(ZRCS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:)) &
- *PRHODJ(:,:,:),7 ,'AUTO_BU_RRC',YDDDH, YDLDDH, YDMDDH)
-
- ZW(:,:,:) = PRRS(:,:,:)
- IF (LBUDGET_RR) CALL BUDGET_DDH ( &
- UNPACK(ZRRS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:)) &
- *PRHODJ(:,:,:),8 ,'AUTO_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- ZW(:,:,:) = PCRS(:,:,:)
- IF (LBUDGET_SV) THEN
- ZW(:,:,:) = PCRS(:,:,:)
- CALL BUDGET_DDH (UNPACK(ZCRS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:)) &
- *PRHODJ(:,:,:),12+NSV_LIMA_NR,'AUTO_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- ZW(:,:,:) = PCCS(:,:,:)
- CALL BUDGET_DDH (UNPACK(ZCCS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:)) &
- *PRHODJ(:,:,:),12+NSV_LIMA_NC,'AUTO_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- END IF
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 4. Accretion sources
-! --------------------
-!
-!
- GACCR(:) = ZRRT(:)>XRTMIN(3) .AND. ZCRT(:)>XCTMIN(3)
- IACCR = COUNT(GACCR(:))
- IF( IACCR>0 ) THEN
- ALLOCATE(ZZW4(IMICRO)); ZZW4(:) = XACCR1/ZLBDR(:)
- ALLOCATE(GENABLE_ACCR_SCBU(IMICRO))
- GENABLE_ACCR_SCBU(:) = ZRRT(:)>1.2*ZZW2(:)/ZRHODREF(:) .OR. &
- ZZW4(:)>=MAX( XACCR2,XACCR3/(XACCR4/ZLBDC(:)-XACCR5) )
- GACCR(:) = GACCR(:) .AND. ZRCT(:)>XRTMIN(2) .AND. GENABLE_ACCR_SCBU(:)
- END IF
-!
- IACCR = COUNT(GACCR(:))
- IF( IACCR>0 ) THEN
- WHERE( GACCR(:).AND.(ZZW4(:)>1.E-4) ) ! Accretion for D>100 10-6 m
- ZZW3(:) = ZLBDC3(:) / ZLBDR3(:)
- ZZW1(:) = ( ZCCT(:)*ZCRT(:) / ZLBDC3(:) )*ZRHODREF(:)
- ZZW2(:) = MIN( ZZW1(:)*(XACCR_CLARGE1+XACCR_CLARGE2*ZZW3(:)),ZCCS(:) )
- ZCCS(:) = ZCCS(:) - ZZW2(:)
-!
- ZZW1(:) = ( ZZW1(:) / ZLBDC3(:) )*ZRHODREF(:)
- ZZW2(:) = MIN( ZZW1(:)*(XACCR_RLARGE1+XACCR_RLARGE2*ZZW3(:)),ZRCS(:) )
- ZRCS(:) = ZRCS(:) - ZZW2(:)
- ZRRS(:) = ZRRS(:) + ZZW2(:)
- END WHERE
- WHERE( GACCR(:).AND.(ZZW4(:)<=1.E-4) ) ! Accretion for D<100 10-6 m
- ZZW3(:) = ZLBDC3(:) / ZLBDR3(:)
- ZZW1(:) = ( ZCCT(:)*ZCRT(:) / ZLBDC3(:)**2 )*ZRHODREF(:)
- ZZW3(:) = ZZW3(:)**2
- ZZW2(:) = MIN( ZZW1(:)*(XACCR_CSMALL1+XACCR_CSMALL2*ZZW3(:)),ZCCS(:) )
- ZCCS(:) = ZCCS(:) - ZZW2(:)
-!
- ZZW1(:) = ZZW1(:) / ZLBDC3(:)
- ZZW2(:) = MIN( ZZW1(:)*(XACCR_RSMALL1+XACCR_RSMALL2*ZZW3(:)) &
- *ZRHODREF(:),ZRCS(:) )
- ZRCS(:) = ZRCS(:) - ZZW2(:)
- ZRRS(:) = ZRRS(:) + ZZW2(:)
- END WHERE
- END IF
-!
-!
- ZW(:,:,:) = PRCS(:,:,:)
- IF (LBUDGET_RC) CALL BUDGET_DDH ( &
- UNPACK(ZRCS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:)) &
- *PRHODJ(:,:,:),7 ,'ACCR_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- ZW(:,:,:) = PRRS(:,:,:)
- IF (LBUDGET_RR) CALL BUDGET_DDH ( &
- UNPACK(ZRRS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:)) &
- *PRHODJ(:,:,:),8 ,'ACCR_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- ZW(:,:,:) = PCCS(:,:,:)
- IF (LBUDGET_SV) CALL BUDGET_DDH ( &
- UNPACK(ZCCS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:)) &
- *PRHODJ(:,:,:),12+NSV_LIMA_NC,'ACCR_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 5. Self collection - Coalescence/Break-up
-! -----------------------------------------
-!
-!
- IF( IACCR>0 ) THEN
- GSCBU(:) = ZCRT(:)>XCTMIN(3) .AND. GENABLE_ACCR_SCBU(:)
- ISCBU = COUNT(GSCBU(:))
- ELSE
- ISCBU = 0.0
- END IF
- IF( ISCBU>0 ) THEN
-!
-!* 5.1 efficiencies
-!
- IF (.NOT.ALLOCATED(ZZW4)) ALLOCATE(ZZW4(IMICRO))
- ZZW4(:) = XACCR1 / ZLBDR(:) ! Mean diameter
- ALLOCATE(ZSCBU(IMICRO))
- ZSCBU(:) = 1.0
- WHERE (ZZW4(:)>=XSCBU_EFF1 .AND. GSCBU(:)) ZSCBU(:) = & ! Coalescence
- EXP(XSCBUEXP1*(ZZW4(:)-XSCBU_EFF1)) ! efficiency
- WHERE (ZZW4(:)>=XSCBU_EFF2) ZSCBU(:) = 0.0 ! Break-up
-!
-!* 5.2 integration
-!
- ZZW1(:) = 0.0
- ZZW2(:) = 0.0
- ZZW3(:) = 0.0
- ZZW4(:) = XACCR1 / ZLBDR(:) ! Mean volume drop diameter
- WHERE (GSCBU(:).AND.(ZZW4(:)>1.E-4)) ! analytical integration
- ZZW1(:) = XSCBU2 * ZCRT(:)**2 / ZLBDR3(:) ! D>100 10-6 m
- ZZW3(:) = ZZW1(:)*ZSCBU(:)
- END WHERE
- WHERE (GSCBU(:).AND.(ZZW4(:)<=1.E-4))
- ZZW2(:) = XSCBU3 *(ZCRT(:) / ZLBDR3(:))**2 ! D<100 10-6 m
- ZZW3(:) = ZZW2(:)
- END WHERE
- ZCRS(:) = ZCRS(:) - MIN( ZCRS(:),ZZW3(:) * ZRHODREF(:) )
- DEALLOCATE(ZSCBU)
- END IF
-!
-!
- ZW(:,:,:) = PCRS(:,:,:)
- IF (LBUDGET_SV) CALL BUDGET_DDH ( &
- UNPACK(ZCRS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:)) &
- *PRHODJ(:,:,:),12+NSV_LIMA_NR,'SCBU_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-!
-END IF ! LRAIN_LIMA
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 6. Unpack and clean
-! -------------------
-!
-!
- ZW(:,:,:) = PRCS(:,:,:)
- PRCS(:,:,:) = UNPACK( ZRCS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRRS(:,:,:)
- PRRS(:,:,:) = UNPACK( ZRRS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PCCS(:,:,:)
- PCCS(:,:,:) = UNPACK( ZCCS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PCRS(:,:,:)
- PCRS(:,:,:) = UNPACK( ZCRS(:),MASK=GMICRO(:,:,:),FIELD=ZW(:,:,:) )
-!
- DEALLOCATE(ZRCT)
- DEALLOCATE(ZRRT)
- DEALLOCATE(ZCCT)
- DEALLOCATE(ZCRT)
- DEALLOCATE(ZRCS)
- DEALLOCATE(ZRRS)
- DEALLOCATE(ZCRS)
- DEALLOCATE(ZCCS)
- DEALLOCATE(ZRHODREF)
- DEALLOCATE(GSELF)
- DEALLOCATE(GACCR)
- DEALLOCATE(GSCBU)
- IF( ALLOCATED(GENABLE_ACCR_SCBU) ) DEALLOCATE(GENABLE_ACCR_SCBU)
- DEALLOCATE(ZZW1)
- DEALLOCATE(ZZW2)
- DEALLOCATE(ZZW3)
- IF( ALLOCATED(ZZW4) ) DEALLOCATE(ZZW4)
- DEALLOCATE(ZLBDR3)
- DEALLOCATE(ZLBDC3)
- DEALLOCATE(ZLBDR)
- DEALLOCATE(ZLBDC)
-!
-!
-!-------------------------------------------------------------------------------
-!
-ELSE
-!* 7. Budgets are forwarded
-! ------------------------
-!
-!
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,'SELF_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-!
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:),7 ,'AUTO_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH (PRRS(:,:,:)*PRHODJ(:,:,:),8 ,'AUTO_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCRS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NR,'AUTO_BU_RSV',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,'AUTO_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-!
- IF (LBUDGET_RC) CALL BUDGET_DDH (PRCS(:,:,:)*PRHODJ(:,:,:),7 ,'ACCR_BU_RRC',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_RR) CALL BUDGET_DDH (PRRS(:,:,:)*PRHODJ(:,:,:),8 ,'ACCR_BU_RRR',YDDDH, YDLDDH, YDMDDH)
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCCS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NC,'ACCR_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-!
- IF (LBUDGET_SV) CALL BUDGET_DDH (PCRS(:,:,:)*PRHODJ(:,:,:),12+NSV_LIMA_NR,'SCBU_BU_RSV',YDDDH, YDLDDH, YDMDDH)
-
-END IF ! IMICRO
-!
-!-------------------------------------------------------------------------------
-!
-END SUBROUTINE LIMA_WARM_COAL
diff --git a/src/arome/micro/lima_warm_evap.F90 b/src/arome/micro/lima_warm_evap.F90
deleted file mode 100644
index a7674a41e..000000000
--- a/src/arome/micro/lima_warm_evap.F90
+++ /dev/null
@@ -1,350 +0,0 @@
-! ##########################
- MODULE MODI_LIMA_WARM_EVAP
-! ##########################
-!
-INTERFACE
- SUBROUTINE LIMA_WARM_EVAP (PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT, &
- PRHODREF, PEXNREF, PPABST, ZT, &
- ZWLBDC3, ZWLBDC, ZWLBDR3, ZWLBDR, &
- PRVT, PRCT, PRRT, PCRT, &
- PRVS, PRCS, PRRS, PCCS, PCRS, PTHS, &
- PEVAP3D)
-!
-REAL, INTENT(IN) :: PTSTEP ! Double Time step
- ! (single if cold start)
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZT ! Temperature
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: ZWLBDC3 ! Lambda(cloud) **3
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: ZWLBDC ! Lambda(cloud)
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: ZWLBDR3 ! Lambda(rain) **3
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: ZWLBDR ! Lambda(rain)
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCRT ! Rain water C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCCS ! Cloud water C. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCRS ! Rain water C. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PEVAP3D ! Rain evap profile
-!
- END SUBROUTINE LIMA_WARM_EVAP
-END INTERFACE
-END MODULE MODI_LIMA_WARM_EVAP
-! #############################################################################
- SUBROUTINE LIMA_WARM_EVAP (PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT, &
- PRHODREF, PEXNREF, PPABST, ZT, &
- ZWLBDC3, ZWLBDC, ZWLBDR3, ZWLBDR, &
- PRVT, PRCT, PRRT, PCRT, &
- PRVS, PRCS, PRRS, PCCS, PCRS, PTHS, &
- PEVAP3D)
-! #############################################################################
-!
-!!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the raindrop evaporation
-!!
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_PARAMETERS, ONLY : JPHEXT, JPVEXT
-USE MODD_CST
-USE MODD_PARAM_LIMA
-USE MODD_PARAM_LIMA_WARM
-!
-USE MODI_LIMA_FUNCTIONS, ONLY : COUNTJV
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-REAL, INTENT(IN) :: PTSTEP ! Double Time step
- ! (single if cold start)
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZT ! Temperature
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: ZWLBDC3 ! Lambda(cloud) **3
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: ZWLBDC ! Lambda(cloud)
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: ZWLBDR3 ! Lambda(rain) **3
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: ZWLBDR ! Lambda(rain)
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCRT ! Rain water C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCCS ! Cloud water C. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCRS ! Rain water C. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PEVAP3D ! Rain evap profile
-!
-!* 0.1 Declarations of local variables :
-!
-! Packing variables
-LOGICAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: GEVAP, GMICRO
-INTEGER :: IEVAP, IMICRO
-INTEGER , DIMENSION(SIZE(GEVAP)) :: I1,I2,I3 ! Used to replace the COUNT
-INTEGER :: JL ! and PACK intrinsics
-!
-! Packed micophysical variables
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRRT ! Rain water m.r. at t
-REAL, DIMENSION(:) , ALLOCATABLE :: ZCRT ! rain conc. at t
-!
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRVS ! Water vapor m.r. source
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRRS ! Rain water m.r. source
-REAL, DIMENSION(:) , ALLOCATABLE :: ZTHS ! Theta source
-!
-! Other packed variables
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRHODREF ! RHO Dry REFerence
-REAL, DIMENSION(:) , ALLOCATABLE :: ZEXNREF ! EXNer Pressure REFerence
-REAL, DIMENSION(:) , ALLOCATABLE :: ZZT ! Temperature
-REAL, DIMENSION(:) , ALLOCATABLE :: ZLBDR ! Lambda(rain)
-!
-! Work arrays
-REAL, DIMENSION(:), ALLOCATABLE :: ZZW1, ZZW2, ZZW3, &
- ZRTMIN, ZCTMIN, &
- ZZLV ! Latent heat of vaporization at T
-!
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: ZW, ZW2, ZRVSAT
-!
-!
-REAL :: ZEPS, ZFACT
-INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE ! Physical domain
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 1. PREPARE COMPUTATIONS - PACK
-! ---------------------------
-!
-!
-IIB=1+JPHEXT
-IIE=SIZE(PRHODREF,1) - JPHEXT
-IJB=1+JPHEXT
-IJE=SIZE(PRHODREF,2) - JPHEXT
-IKB=1+JPVEXT
-IKE=SIZE(PRHODREF,3) - JPVEXT
-!
-ALLOCATE(ZRTMIN(SIZE(XRTMIN)))
-ALLOCATE(ZCTMIN(SIZE(XCTMIN)))
-ZRTMIN(:) = XRTMIN(:) / PTSTEP
-ZCTMIN(:) = XCTMIN(:) / PTSTEP
-!
-ZEPS= XMV / XMD
-ZRVSAT(:,:,:) = ZEPS / (PPABST(:,:,:) * &
- EXP(-XALPW+XBETAW/ZT(:,:,:)+XGAMW*ALOG(ZT(:,:,:))) - 1.0)
-
-!
-GEVAP(:,:,:) = .FALSE.
-GEVAP(IIB:IIE,IJB:IJE,IKB:IKE) = &
- PRRS(IIB:IIE,IJB:IJE,IKB:IKE)>ZRTMIN(3) .AND. &
- PRVT(IIB:IIE,IJB:IJE,IKB:IKE)<ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE)
-!
-IEVAP = COUNTJV( GEVAP(:,:,:),I1(:),I2(:),I3(:))
-!
-IF( IEVAP >= 1 ) THEN
- ALLOCATE(ZRVT(IEVAP))
- ALLOCATE(ZRCT(IEVAP))
- ALLOCATE(ZRRT(IEVAP))
- ALLOCATE(ZCRT(IEVAP))
-!
- ALLOCATE(ZRVS(IEVAP))
- ALLOCATE(ZRRS(IEVAP))
- ALLOCATE(ZTHS(IEVAP))
-!
- ALLOCATE(ZLBDR(IEVAP))
-!
- ALLOCATE(ZRHODREF(IEVAP))
- ALLOCATE(ZEXNREF(IEVAP))
-!
- ALLOCATE(ZZT(IEVAP))
- ALLOCATE(ZZLV(IEVAP))
- ALLOCATE(ZZW1(IEVAP))
- DO JL=1,IEVAP
- ZRVT(JL) = PRVT(I1(JL),I2(JL),I3(JL))
- ZRCT(JL) = PRCT(I1(JL),I2(JL),I3(JL))
- ZRRT(JL) = PRRT(I1(JL),I2(JL),I3(JL))
- ZCRT(JL) = PCRT(I1(JL),I2(JL),I3(JL))
- ZRRS(JL) = PRRS(I1(JL),I2(JL),I3(JL))
- ZRVS(JL) = PRVS(I1(JL),I2(JL),I3(JL))
- ZTHS(JL) = PTHS(I1(JL),I2(JL),I3(JL))
- ZZT(JL) = ZT(I1(JL),I2(JL),I3(JL))
- ZZW1(JL) = ZRVSAT(I1(JL),I2(JL),I3(JL))
- ZLBDR(JL) = ZWLBDR(I1(JL),I2(JL),I3(JL))
- ZRHODREF(JL) = PRHODREF(I1(JL),I2(JL),I3(JL))
- ZEXNREF(JL) = PEXNREF(I1(JL),I2(JL),I3(JL))
- END DO
- ZZLV(:) = XLVTT + (XCPV-XCL)*(ZZT(:)-XTT)
-!
- ALLOCATE(ZZW2(IEVAP))
- ALLOCATE(ZZW3(IEVAP))
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 2. compute the evaporation of rain drops
-! ----------------------------------------
-!
-!
- ZZW3(:) = MAX((1.0 - ZRVT(:)/ZZW1(:)),0.0) ! Subsaturation
-!
-! Compute the function G(T)
-!
- ZZW2(:) = 1. / ( XRHOLW*((((ZZLV(:)/ZZT(:))**2)/(XTHCO*XRV)) + & ! G
- (XRV*ZZT(:))/(XDIVA*EXP(XALPW-XBETAW/ZZT(:)-XGAMW*ALOG(ZZT(:))))))
-!
-! Compute the evaporation tendency
-!
- ZZW2(:) = MIN( ZZW2(:) * ZZW3(:) * ZRRT(:) * &
- (X0EVAR*ZLBDR(:)**XEX0EVAR + X1EVAR*ZRHODREF(:)**XEX2EVAR* &
- ZLBDR(:)**XEX1EVAR),ZRRS(:) )
- ZZW2(:) = MAX(ZZW2(:),0.0)
-!
-! Adjust sources
-!
- ZRVS(:) = ZRVS(:) + ZZW2(:)
- ZRRS(:) = ZRRS(:) - ZZW2(:)
- ZTHS(:) = ZTHS(:) - ZZW2(:)*ZZLV(:) / &
- ( ZEXNREF(:)*(XCPD + XCPV*ZRVT(:) + XCL*(ZRCT(:) + ZRRT(:)) ) )
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 3. Unpack and clean
-! -------------------
-!
-!
- ZW(:,:,:) = PRVS(:,:,:)
- PRVS(:,:,:) = UNPACK( ZRVS(:),MASK=GEVAP(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PRRS(:,:,:)
- PRRS(:,:,:) = UNPACK( ZRRS(:),MASK=GEVAP(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:) = PTHS(:,:,:)
- PTHS(:,:,:) = UNPACK( ZTHS(:),MASK=GEVAP(:,:,:),FIELD=ZW(:,:,:) )
- ZW(:,:,:)= PEVAP3D(:,:,:)
- PEVAP3D(:,:,:) = UNPACK( ZZW2(:),MASK=GEVAP(:,:,:),FIELD=ZW(:,:,:) )
-!
- DEALLOCATE(ZRCT)
- DEALLOCATE(ZRRT)
- DEALLOCATE(ZRVT)
- DEALLOCATE(ZCRT)
- DEALLOCATE(ZRVS)
- DEALLOCATE(ZRRS)
- DEALLOCATE(ZTHS)
- DEALLOCATE(ZZLV)
- DEALLOCATE(ZZT)
- DEALLOCATE(ZRHODREF)
- DEALLOCATE(ZEXNREF)
- DEALLOCATE(ZZW1)
- DEALLOCATE(ZZW2)
- DEALLOCATE(ZZW3)
- DEALLOCATE(ZLBDR)
-!
-!
-!-----------------------------------------------------------------------------
-!
-!
-!* 4. Update Nr if: 80 microns < Dr < D_h
-! ---------------------------------------
-!
-!
- GEVAP(:,:,:) = PRRS(:,:,:)>ZRTMIN(3) .AND. PCRS(:,:,:)>ZCTMIN(3) .AND. &
- PRCS(:,:,:)>ZRTMIN(2) .AND. PCCS(:,:,:)>ZCTMIN(2)
- WHERE (GEVAP(:,:,:))
- ZWLBDR3(:,:,:) = XLBR * PCRS(:,:,:) / PRRS(:,:,:)
- ZWLBDR(:,:,:) = ZWLBDR3(:,:,:)**XLBEXR
-!
- ZWLBDC3(:,:,:) = XLBC * PCCS(:,:,:) / PRCS(:,:,:)
- ZWLBDC(:,:,:) = ZWLBDC3(:,:,:)**XLBEXC
- ZWLBDC3(:,:,:) = (XACCR1/XACCR3)*(XACCR4/ZWLBDC(:,:,:)-XACCR5) ! 1/D_h, not "Lambda_h"
- END WHERE
-!
- GMICRO(:,:,:) = GEVAP(:,:,:) .AND. ZWLBDR(:,:,:)>ZWLBDC3(:,:,:)
- ! the raindrops are too small, that is lower than D_h
- ZFACT = 1.2E4*XACCR1
- WHERE (GMICRO(:,:,:))
- ZWLBDC(:,:,:) = XLBR / MIN( ZFACT,ZWLBDC3(:,:,:) )**3
- ZW(:,:,:) = MIN( MAX( &
- (PRHODREF(:,:,:)*PRRS(:,:,:) - ZWLBDC(:,:,:)*PCRS(:,:,:)) / &
- (PRHODREF(:,:,:)*PRCS(:,:,:)/PCCS(:,:,:) - ZWLBDC(:,:,:)) , &
- 0.0 ),PCRS(:,:,:), &
- PCCS(:,:,:)*PRRS(:,:,:)/(PRCS(:,:,:)))
-!
-! Compute the percent (=1 if (ZWLBDR/XACCR1) >= 1.2E4
-! of transfer with (=0 if (ZWLBDR/XACCR1) <= (XACCR4/ZWLBDC-XACCR5)/XACCR3
-!
- ZW(:,:,:) = ZW(:,:,:)*( (MIN(ZWLBDR(:,:,:),1.2E4*XACCR1)-ZWLBDC3(:,:,:)) / &
- ( 1.2E4*XACCR1 -ZWLBDC3(:,:,:)) )
-!
- ZW2(:,:,:) = PCCS(:,:,:) !temporary storage
- PCCS(:,:,:) = PCCS(:,:,:)+ZW(:,:,:)
- PCRS(:,:,:) = PCRS(:,:,:)-ZW(:,:,:)
- ZW(:,:,:) = ZW(:,:,:) * (PRHODREF(:,:,:)*PRCS(:,:,:)/ZW2(:,:,:))
- PRCS(:,:,:) = PRCS(:,:,:)+ZW(:,:,:)
- PRRS(:,:,:) = PRRS(:,:,:)-ZW(:,:,:)
- END WHERE
-!
- GEVAP(:,:,:) = PRRS(:,:,:)<ZRTMIN(3) .OR. PCRS(:,:,:)<ZCTMIN(3)
- WHERE (GEVAP(:,:,:))
- PCRS(:,:,:) = 0.0
- PRRS(:,:,:) = 0.0
- END WHERE
-!
-END IF ! IEVAP
-!
-DEALLOCATE(ZRTMIN)
-DEALLOCATE(ZCTMIN)
-!
-!-----------------------------------------------------------------------------
-!
-END SUBROUTINE LIMA_WARM_EVAP
diff --git a/src/arome/micro/lima_warm_nucl.F90 b/src/arome/micro/lima_warm_nucl.F90
deleted file mode 100644
index a82de8ba9..000000000
--- a/src/arome/micro/lima_warm_nucl.F90
+++ /dev/null
@@ -1,817 +0,0 @@
-! ##########################
- MODULE MODI_LIMA_WARM_NUCL
-! ##########################
-!
-INTERFACE
- SUBROUTINE LIMA_WARM_NUCL (OACTIT, PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT,&
- PRHODREF, PEXNREF, PPABST, ZT, ZTM, PW_NU, &
- PRCM, PRVT, PRCT, PRRT, &
- PTHS, PRVS, PRCS, PCCS, PNFS, PNAS )
-!
-LOGICAL, INTENT(IN) :: OACTIT ! Switch to activate the
- ! activation by radiative
- ! tendency
-REAL, INTENT(IN) :: PTSTEP ! Double Time step
- ! (single if cold start)
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the output FM file
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZT ! Temperature
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZTM ! Temperature at time t-dt
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PW_NU ! updraft velocity used for
- ! the nucleation param.
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCM ! Cloud water m.r. at t-dt
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-!
-REAL, DIMENSION(:,:,:) , INTENT(INOUT) :: PCCS ! Cloud water C. source
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNFS ! CCN C. available source
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNAS ! CCN C. activated source
-!
-END SUBROUTINE LIMA_WARM_NUCL
-END INTERFACE
-END MODULE MODI_LIMA_WARM_NUCL
-! #############################################################################
- SUBROUTINE LIMA_WARM_NUCL (OACTIT, PTSTEP, KMI, HFMFILE, HLUOUT, OCLOSE_OUT,&
- PRHODREF, PEXNREF, PPABST, ZT, ZTM, PW_NU, &
- PRCM, PRVT, PRCT, PRRT, &
- PTHS, PRVS, PRCS, PCCS, PNFS, PNAS )
-! #############################################################################
-!
-!!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the activation of CCN
-!! according to Cohard and Pinty, QJRMS, 2000
-!!
-!!
-!!** METHOD
-!! ------
-!! The activation of CCN is checked for quasi-saturated air parcels
-!! to update the cloud droplet number concentration.
-!!
-!! Computation steps :
-!! 1- Check where computations are necessary
-!! 2- and 3- Compute the maximum of supersaturation using the iterative
-!! Ridder algorithm
-!! 4- Compute the nucleation source
-!! 5- Deallocate local variables
-!!
-!! Contains :
-!! 6- Functions : Ridder algorithm
-!!
-!!
-!! REFERENCE
-!! ---------
-!!
-!! Cohard, J.-M. and J.-P. Pinty, 2000: A comprehensive two-moment warm
-!! microphysical bulk scheme.
-!! Part I: Description and tests
-!! Part II: 2D experiments with a non-hydrostatic model
-!! Accepted for publication in Quart. J. Roy. Meteor. Soc.
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_PARAMETERS, ONLY : JPHEXT, JPVEXT
-USE MODD_CST
-USE MODD_PARAM_LIMA
-USE MODD_PARAM_LIMA_WARM
-!
-USE YOMLUN , ONLY : NULOUT
-
-USE MODI_GAMMA
-USE MODI_LIMA_FUNCTIONS, ONLY : COUNTJV
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-LOGICAL, INTENT(IN) :: OACTIT ! Switch to activate the
- ! activation by radiative
- ! tendency
-REAL, INTENT(IN) :: PTSTEP ! Double Time step
- ! (single if cold start)
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the output FM file
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PEXNREF ! Reference Exner function
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZT ! Temperature
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZTM ! Temperature at time t-dt
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PW_NU ! updraft velocity used for
- ! the nucleation param.
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCM ! Cloud water m.r. at t-dt
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRVT ! Water vapor m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PTHS ! Theta source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRVS ! Water vapor m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-!
-REAL, DIMENSION(:,:,:) , INTENT(INOUT) :: PCCS ! Cloud water C. source
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNFS ! CCN C. available source
-REAL, DIMENSION(:,:,:,:), INTENT(INOUT) :: PNAS ! CCN C. activated source
-!
-!
-!* 0.1 Declarations of local variables :
-!
-! Packing variables
-LOGICAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: GNUCT
-INTEGER :: INUCT
-INTEGER , DIMENSION(SIZE(GNUCT)) :: I1,I2,I3 ! Used to replace the COUNT
-INTEGER :: JL ! and PACK intrinsics
-!
-! Packed micophysical variables
-REAL, DIMENSION(:) , ALLOCATABLE :: ZCCS ! cloud conc. source
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZNFS ! available nucleus conc. source
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZNAS ! activated nucleus conc. source
-!
-! Other packed variables
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRHODREF ! RHO Dry REFerence
-REAL, DIMENSION(:) , ALLOCATABLE :: ZEXNREF ! EXNer Pressure REFerence
-REAL, DIMENSION(:) , ALLOCATABLE :: ZZT ! Temperature
-!
-! Work arrays
-REAL, DIMENSION(:), ALLOCATABLE :: ZZW1, ZZW2, ZZW3, ZZW4, ZZW5, ZZW6, &
- ZRTMIN, ZCTMIN, &
- ZZTDT, & ! dT/dt
- ZSMAX, & ! Maximum supersaturation
- ZVEC1
-!
-REAL, DIMENSION(:,:), ALLOCATABLE :: ZTMP, ZCHEN_MULTI
-!
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: ZTDT, ZDRC, ZRVSAT, ZW
-REAL, DIMENSION(SIZE(PNFS,1),SIZE(PNFS,2),SIZE(PNFS,3)) &
- :: ZCONC_TOT ! total CCN C. available
-!
-INTEGER, DIMENSION(:), ALLOCATABLE :: IVEC1 ! Vectors of indices for
- ! interpolations
-!
-!
-REAL :: ZEPS ! molar mass ratio
-REAL :: ZS1, ZS2, ZXACC
-INTEGER :: JMOD
-INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE ! Physical domain
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 1. PREPARE COMPUTATIONS - PACK
-! ---------------------------
-!
-!
-IIB=1+JPHEXT
-IIE=SIZE(PRHODREF,1) - JPHEXT
-IJB=1+JPHEXT
-IJE=SIZE(PRHODREF,2) - JPHEXT
-IKB=1+JPVEXT
-IKE=SIZE(PRHODREF,3) - JPVEXT
-!
-ALLOCATE(ZRTMIN(SIZE(XRTMIN)))
-ALLOCATE(ZCTMIN(SIZE(XCTMIN)))
-ZRTMIN(:) = XRTMIN(:) / PTSTEP
-ZCTMIN(:) = XCTMIN(:) / PTSTEP
-!
-! Saturation vapor mixing ratio and radiative tendency
-!
-ZEPS= XMV / XMD
-!
-ZRVSAT(:,:,:) = ZEPS / (PPABST(:,:,:) * &
- EXP(-XALPW+XBETAW/ZT(:,:,:)+XGAMW*ALOG(ZT(:,:,:))) - 1.0)
-ZTDT(:,:,:) = 0.
-ZDRC(:,:,:) = 0.
-IF (OACTIT) THEN
- ZTDT(:,:,:) = (ZT(:,:,:)-ZTM(:,:,:))/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)*(ZT(:,:,:)-XTT))*ZDRC(:,:,:)/XCPD)
-END IF
-!
-! find locations where CCN are available
-!
-ZCONC_TOT(:,:,:) = 0.0
-DO JMOD = 1, NMOD_CCN
- ZCONC_TOT(:,:,:) = ZCONC_TOT(:,:,:) + PNFS(:,:,:,JMOD) ! sum over the free CCN
-ENDDO
-!
-! optimization by looking for locations where
-! the updraft velocity is positive!!!
-!
-GNUCT(:,:,:) = .FALSE.
-!
-! NEW : -22°C = limit sup for condensation freezing in Fridlin et al., 2007
-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) .AND.&
- PRVT(IIB:IIE,IJB:IJE,IKB:IKE)>(0.98*ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE))&
- .AND. ZT(IIB:IIE,IJB:IJE,IKB:IKE)>(XTT-22.) &
- .AND. ZCONC_TOT(IIB:IIE,IJB:IJE,IKB:IKE)>ZCTMIN(4)
-ELSE
- GNUCT(IIB:IIE,IJB:IJE,IKB:IKE) = PW_NU(IIB:IIE,IJB:IJE,IKB:IKE)>XWMIN .AND.&
- PRVT(IIB:IIE,IJB:IJE,IKB:IKE)>(0.98*ZRVSAT(IIB:IIE,IJB:IJE,IKB:IKE))&
- .AND. ZT(IIB:IIE,IJB:IJE,IKB:IKE)>(XTT-22.) &
- .AND. ZCONC_TOT(IIB:IIE,IJB:IJE,IKB:IKE)>ZCTMIN(4)
-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(ZCCS(INUCT))
- ALLOCATE(ZZT(INUCT))
- ALLOCATE(ZZTDT(INUCT))
- ALLOCATE(ZZW1(INUCT))
- ALLOCATE(ZZW2(INUCT))
- ALLOCATE(ZZW3(INUCT))
- ALLOCATE(ZZW4(INUCT))
- ALLOCATE(ZZW5(INUCT))
- ALLOCATE(ZZW6(INUCT))
- ALLOCATE(ZCHEN_MULTI(INUCT,NMOD_CCN))
- ALLOCATE(ZVEC1(INUCT))
- ALLOCATE(IVEC1(INUCT))
- ALLOCATE(ZRHODREF(INUCT))
- ALLOCATE(ZEXNREF(INUCT))
- DO JL=1,INUCT
- ZCCS(JL) = PCCS(I1(JL),I2(JL),I3(JL))
- ZZT(JL) = ZT(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))
- ZZTDT(JL) = ZTDT(I1(JL),I2(JL),I3(JL))
- ZRHODREF(JL) = PRHODREF(I1(JL),I2(JL),I3(JL))
- ZEXNREF(JL) = PEXNREF(I1(JL),I2(JL),I3(JL))
- DO JMOD = 1,NMOD_CCN
- ZNFS(JL,JMOD) = PNFS(I1(JL),I2(JL),I3(JL),JMOD)
- ZNAS(JL,JMOD) = PNAS(I1(JL),I2(JL),I3(JL),JMOD)
- ZCHEN_MULTI(JL,JMOD) = (ZNFS(JL,JMOD)+ZNAS(JL,JMOD))*PTSTEP*ZRHODREF(JL) &
- / XLIMIT_FACTOR(JMOD)
- ENDDO
- ENDDO
-!
- ZZW1(:) = 1.0/ZEPS + 1.0/ZZW1(:) &
- + (((XLVTT+(XCPV-XCL)*(ZZT(:)-XTT))/ZZT(:))**2)/(XCPD*XRV) ! Psi2
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 2. compute the constant term (ZZW3) relative to smax
-! ----------------------------------------------------
-!
-! Remark : in LIMA's nucleation parameterization, Smax=0.01 for a supersaturation of 1% !
-!
-!
- ZVEC1(:) = MAX( 1.00001, MIN( FLOAT(NAHEN)-0.00001, &
- XAHENINTP1 * ZZT(:) + XAHENINTP2 ) )
- IVEC1(:) = INT( ZVEC1(:) )
- ZVEC1(:) = ZVEC1(:) - FLOAT( IVEC1(:) )
- ALLOCATE(ZSMAX(INUCT))
-!
-!
- IF (OACTIT) THEN ! including a cooling rate
-!
-! Compute the tabulation of function of ZZW3 :
-!
-! (Psi1*w+Psi3*DT/Dt)**1.5
-! ZZW3 = XAHENG*(Psi1*w + Psi3*DT/Dt)**1.5 = ------------------------
-! 2*pi*rho_l*G**(3/2)
-!
-!
- ZZW4(:)=XPSI1( IVEC1(:)+1)*ZZW2(:)+XPSI3(IVEC1(:)+1)*ZZTDT(:)
- ZZW5(:)=XPSI1( IVEC1(:) )*ZZW2(:)+XPSI3(IVEC1(:) )*ZZTDT(:)
- WHERE (ZZW4(:) < 0. .OR. ZZW5(:) < 0.)
- ZZW4(:) = 0.
- ZZW5(:) = 0.
- END WHERE
- 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
-!
-!
- ELSE ! OACTIT , for clouds
-!
-!
-! Compute the tabulation of function of ZZW3 :
-!
-! (Psi1 * w)**1.5
-! ZZW3 = XAHENG * (Psi1 * w)**1.5 = -------------------------
-! 2 pi rho_l * G**(3/2)
-!
-!
- ZZW3(:)=XAHENG(IVEC1(:)+1)*((XPSI1(IVEC1(:)+1)*ZZW2(:))**1.5)* ZVEC1(:) &
- -XAHENG(IVEC1(:) )*((XPSI1(IVEC1(:) )*ZZW2(:))**1.5)*(ZVEC1(:)-1.0)
-!
- END IF ! OACTIT
-!
-!
-! (Psi1*w+Psi3*DT/Dt)**1.5 rho_air
-! ZZW3 = ------------------------ * -------
-! 2*pi*rho_l*G**(3/2) Psi2
-!
- ZZW5(:) = 1.
- ZZW3(:) = (ZZW3(:)/ZZW1(:))*ZRHODREF(:) ! R.H.S. of Eq 9 of CPB 98 but
- ! for multiple aerosol modes
- WHERE (ZZW3(:) == 0.)
- ZZW5(:) = -1.
- END WHERE
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 3. Compute the maximum of supersaturation
-! -----------------------------------------
-!
-!
-! estimate S_max for the CPB98 parameterization with SEVERAL aerosols mode
-! Reminder : Smax=0.01 for a 1% supersaturation
-!
-! Interval bounds to tabulate sursaturation Smax
-! 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]
-!
- ZSMAX(:) = ZRIDDR(ZS1,ZS2,ZXACC,ZZW3(:),INUCT) ! ZSMAX(:) is in [NO UNITS]
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 4. Compute the nucleus source
-! -----------------------------
-!
-!
-! Again : Smax=0.01 for a 1% supersaturation
-! Modified values for Beta and C (see in init_aerosol_properties) account for that
-!
- WHERE (ZZW5(:) > 0. .AND. ZSMAX(:) > 0.)
- ZVEC1(:) = MAX( 1.00001, MIN( FLOAT(NHYP)-0.00001, &
- XHYPINTP1*LOG(ZSMAX(:))+XHYPINTP2 ) )
- IVEC1(:) = INT( ZVEC1(:) )
- ZVEC1(:) = ZVEC1(:) - FLOAT( IVEC1(:) )
- END WHERE
- ZZW6(:) = 0. ! initialize the change of cloud droplet concentration
-!
- ZTMP(:,:)=0.0
-!
-! Compute the concentration of activable aerosols for each mode
-! based on the max of supersaturation ( -> ZTMP )
-!
- DO JMOD = 1, NMOD_CCN ! iteration on mode number
- ZZW1(:) = 0.
- ZZW2(:) = 0.
- ZZW3(:) = 0.
- !
- WHERE( 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
- ENDWHERE
- 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
- ZZW1(:) = 0.
- ZZW2(:) = 0.
- ZZW3(:) = 0.
- !
- WHERE( SUM(ZTMP(:,:),DIM=2)*PTSTEP .GT. 25.E6/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 )
- !
- !* update the concentration of free CCN = Nf
- !
- PNFS(:,:,:,JMOD) = PNFS(:,:,:,JMOD) - &
- UNPACK( ZZW1(:), MASK=GNUCT(:,:,:), FIELD=0.0 )
- !
- !* prepare to update the cloud water concentration
- !
- ZZW6(:) = ZZW6(:) + ZZW1(:)
- ENDDO
-!
-! Update PRVS, PRCS, PCCS, and PTHS
-!
- ZZW1(:)=0.
- 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 ),PRVS(:,:,:) )
-!
- PRVS(:,:,:) = PRVS(:,:,:) - ZW(:,:,:)
- PRCS(:,:,:) = PRCS(:,:,:) + ZW(:,:,:)
- ZW(:,:,:) = ZW(:,:,:) * (XLVTT+(XCPV-XCL)*(ZT(:,:,:)-XTT))/ &
- (PEXNREF(:,:,:)*(XCPD+XCPV*PRVT(:,:,:)+XCL*(PRCT(:,:,:)+PRRT(:,:,:))))
- PTHS(:,:,:) = PTHS(:,:,:) + ZW(:,:,:)
-!
- ZW(:,:,:) = PCCS(:,:,:)
- PCCS(:,:,:) = UNPACK( ZZW6(:)+ZCCS(:),MASK=GNUCT(:,:,:),FIELD=ZW(:,:,:) )
-!
- ZW(:,:,:) = UNPACK( 100.0*ZSMAX(:),MASK=GNUCT(:,:,:),FIELD=0.0 )
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 5. Cleaning
-! -----------
-!
-!
- DEALLOCATE(IVEC1)
- DEALLOCATE(ZVEC1)
- DEALLOCATE(ZNFS)
- DEALLOCATE(ZNAS)
- DEALLOCATE(ZCCS)
- DEALLOCATE(ZZT)
- DEALLOCATE(ZSMAX)
- DEALLOCATE(ZZW1)
- DEALLOCATE(ZZW2)
- DEALLOCATE(ZZW3)
- DEALLOCATE(ZZW4)
- DEALLOCATE(ZZW5)
- DEALLOCATE(ZZW6)
- DEALLOCATE(ZZTDT)
- DEALLOCATE(ZRHODREF)
- DEALLOCATE(ZCHEN_MULTI)
- DEALLOCATE(ZEXNREF)
-!
-END IF ! INUCT
-!
-DEALLOCATE(ZCTMIN)
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-!* 6. Functions used to compute the maximum of supersaturation
-! -----------------------------------------------------------
-!
-!
-CONTAINS
-!------------------------------------------------------------------------------
-!
- FUNCTION ZRIDDR(PX1,PX2INIT,PXACC,PZZW3,NPTS) 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
-!
-INTEGER, INTENT(IN) :: NPTS
-REAL, DIMENSION(:), INTENT(IN) :: PZZW3
-REAL, INTENT(IN) :: PX1, PX2INIT, PXACC
-REAL, DIMENSION(:), ALLOCATABLE :: PZRIDDR
-!
-!* 0.2 declarations of local variables
-!
-!
-INTEGER, PARAMETER :: MAXIT=60
-REAL, PARAMETER :: UNUSED=0.0 !-1.11e30
-REAL, DIMENSION(:), ALLOCATABLE :: fh,fl, fm,fnew
-REAL :: s,xh,xl,xm,xnew
-REAL :: PX2
-INTEGER :: j, JL
-!
-ALLOCATE( fh(NPTS))
-ALLOCATE( fl(NPTS))
-ALLOCATE( fm(NPTS))
-ALLOCATE(fnew(NPTS))
-ALLOCATE(PZRIDDR(NPTS))
-!
-PZRIDDR(:)= UNUSED
-PX2 = PX2INIT
-fl(:) = FUNCSMAX(PX1,PZZW3(:),NPTS)
-fh(:) = FUNCSMAX(PX2,PZZW3(:),NPTS)
-!
-DO JL = 1, NPTS
- PX2 = PX2INIT
-100 if ((fl(JL) > 0.0 .and. fh(JL) < 0.0) .or. (fl(JL) < 0.0 .and. fh(JL) > 0.0)) then
- xl = PX1
- xh = PX2
- do j=1,MAXIT
- xm = 0.5*(xl+xh)
- fm(JL) = SINGL_FUNCSMAX(xm,PZZW3(JL),JL)
- s = sqrt(fm(JL)**2-fl(JL)*fh(JL))
- if (s == 0.0) then
- GO TO 101
- endif
- xnew = xm+(xm-xl)*(sign(1.0,fl(JL)-fh(JL))*fm(JL)/s)
- if (abs(xnew - PZRIDDR(JL)) <= PXACC) then
- GO TO 101
- endif
- PZRIDDR(JL) = xnew
- fnew(JL) = SINGL_FUNCSMAX(PZRIDDR(JL),PZZW3(JL),JL)
- if (fnew(JL) == 0.0) then
- GO TO 101
- endif
- if (sign(fm(JL),fnew(JL)) /= fm(JL)) then
- xl =xm
- fl(JL)=fm(JL)
- xh =PZRIDDR(JL)
- fh(JL)=fnew(JL)
- else if (sign(fl(JL),fnew(JL)) /= fl(JL)) then
- xh =PZRIDDR(JL)
- fh(JL)=fnew(JL)
- else if (sign(fh(JL),fnew(JL)) /= fh(JL)) then
- xl =PZRIDDR(JL)
- fl(JL)=fnew(JL)
- 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)
- go to 100
- print*, 'PZRIDDR: never get here'
- STOP
- end if
- if (abs(xh-xl) <= PXACC) then
- GO TO 101
- endif
-!!SB
-!!$ if (j == MAXIT .and. (abs(xh-xl) > PXACC) ) then
-!!$ PZRIDDR(JL)=0.0
-!!$ go to 101
-!!$ endif
-!!SB
- end do
- print*, 'PZRIDDR: exceeded maximum iterations',j
- STOP
- else if (fl(JL) == 0.0) then
- PZRIDDR(JL)=PX1
- else if (fh(JL) == 0.0) then
- PZRIDDR(JL)=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(JL) = SINGL_FUNCSMAX(PX2,PZZW3(JL),JL)
- go to 100
- else
-!!$ print*, 'PZRIDDR: root must be bracketed'
-!!$ print*,'npts ',NPTS,'jl',JL
-!!$ print*, 'PX1,PX2,fl,fh',PX1,PX2,fl(JL),fh(JL)
-!!$ print*, 'PX2 = 30 % of supersaturation, there is no solution for Smax'
-!!$ print*, 'try to put greater PX2 (upper bound for Smax research)'
-!!$ STOP
- PZRIDDR(JL)=0.0
- go to 101
- end if
-101 ENDDO
-!
-DEALLOCATE( fh)
-DEALLOCATE( fl)
-DEALLOCATE( fm)
-DEALLOCATE(fnew)
-!
-END FUNCTION ZRIDDR
-!
-!------------------------------------------------------------------------------
-!
- FUNCTION FUNCSMAX(PPZSMAX,PPZZW3,NPTS) RESULT(PFUNCSMAX)
-!
-!
-!!**** *FUNCSMAX* - function describing SMAX function that you want to find the root
-!!
-!!
-!! PURPOSE
-!! -------
-!! This function describe the equilibrium between Smax and two aerosol mode
-!! acting as CCN. This function is derive from eq. (9) of CPB98 but for two
-!! aerosols mode described by their respective parameters C, k, Mu, Beta.
-!! the arguments are the supersaturation in "no unit" and the r.h.s. of this eq.
-!! and the ratio of concentration of injected aerosols on maximum concentration
-!! of injected aerosols ever.
-!!** METHOD
-!! ------
-!! This function is called by zriddr.f90
-!!
-!! EXTERNAL
-!! --------
-!!
-!! IMPLICIT ARGUMENTS
-!! ------------------
-!! Module MODD_PARAM_LIMA_WARM
-!! XHYPF32
-!!
-!! XHYPINTP1
-!! XHYPINTP2
-!!
-!! Module MODD_PARAM_C2R2
-!! XKHEN_MULTI()
-!! NMOD_CCN
-!!
-!! REFERENCE
-!! ---------
-!! Cohard, J.M., J.P.Pinty, K.Suhre, 2000:"On the parameterization of activation
-!! spectra from cloud condensation nuclei microphysical properties",
-!! J. Geophys. Res., Vol.105, N0.D9, pp. 11753-11766
-!!
-!! AUTHOR
-!! ------
-!! Frederick Chosson *CERFACS*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original 12/07/07
-!! S.Berthet 19/03/08 Extension a une population multimodale d aerosols
-!
-!------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-!
-IMPLICIT NONE
-!
-!* 0.1 declarations of arguments and result
-!
-INTEGER, INTENT(IN) :: NPTS
-REAL, INTENT(IN) :: PPZSMAX ! supersaturation is already in no units
-REAL, DIMENSION(:), INTENT(IN) :: PPZZW3 !
-REAL, DIMENSION(:), ALLOCATABLE :: PFUNCSMAX !
-!
-!* 0.2 declarations of local variables
-!
-REAL :: ZHYPF
-!
-REAL :: PZVEC1
-INTEGER :: PIVEC1
-!
-ALLOCATE(PFUNCSMAX(NPTS))
-!
-PFUNCSMAX(:) = 0.
-PZVEC1 = MAX( 1.00001,MIN( FLOAT(NHYP)-0.00001, &
- XHYPINTP1*LOG(PPZSMAX)+XHYPINTP2 ) )
-PIVEC1 = INT( PZVEC1 )
-PZVEC1 = PZVEC1 - FLOAT( PIVEC1 )
-DO JMOD = 1, NMOD_CCN
- ZHYPF = 0. ! XHYPF32 is tabulated with ZSMAX in [NO UNITS]
- ZHYPF = XHYPF32( PIVEC1+1,JMOD ) * PZVEC1 &
- - XHYPF32( PIVEC1 ,JMOD ) *(PZVEC1 - 1.0)
- ! sum of s**(ki+2) * F32 * Ci * ki * beta(ki/2,3/2)
- PFUNCSMAX(:) = PFUNCSMAX(:) + (PPZSMAX)**(XKHEN_MULTI(JMOD) + 2) &
- * ZHYPF* XKHEN_MULTI(JMOD) * ZCHEN_MULTI(:,JMOD) &
- * GAMMA_X0D( XKHEN_MULTI(JMOD)/2.0)*GAMMA_X0D(3.0/2.0) &
- / 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(:)
-!
-END FUNCTION FUNCSMAX
-!
-!------------------------------------------------------------------------------
-!
- FUNCTION SINGL_FUNCSMAX(PPZSMAX,PPZZW3,KINDEX) RESULT(PSINGL_FUNCSMAX)
-!
-!
-!!**** *SINGL_FUNCSMAX* - same function as FUNCSMAX
-!!
-!!
-!! PURPOSE
-!! -------
-! As for FUNCSMAX but for a scalar
-!!
-!!** METHOD
-!! ------
-!! This function is called by zriddr.f90
-!!
-!------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-!
-IMPLICIT NONE
-!
-!* 0.1 declarations of arguments and result
-!
-INTEGER, INTENT(IN) :: KINDEX
-REAL, INTENT(IN) :: PPZSMAX ! supersaturation is "no unit"
-REAL, INTENT(IN) :: PPZZW3 !
-REAL :: PSINGL_FUNCSMAX !
-!
-!* 0.2 declarations of local variables
-!
-REAL :: ZHYPF
-!
-REAL :: PZVEC1
-INTEGER :: PIVEC1
-!
-PSINGL_FUNCSMAX = 0.
-PZVEC1 = MAX( 1.00001,MIN( FLOAT(NHYP)-0.00001, &
- XHYPINTP1*LOG(PPZSMAX)+XHYPINTP2 ) )
-PIVEC1 = INT( PZVEC1 )
-PZVEC1 = PZVEC1 - FLOAT( PIVEC1 )
-DO JMOD = 1, NMOD_CCN
- ZHYPF = 0. ! XHYPF32 is tabulated with ZSMAX in [NO UNITS]
- ZHYPF = XHYPF32( PIVEC1+1,JMOD ) * PZVEC1 &
- - XHYPF32( PIVEC1 ,JMOD ) *(PZVEC1 - 1.0)
- ! sum of s**(ki+2) * F32 * Ci * ki * bêta(ki/2,3/2)
- PSINGL_FUNCSMAX = PSINGL_FUNCSMAX + (PPZSMAX)**(XKHEN_MULTI(JMOD) + 2) &
- * ZHYPF* XKHEN_MULTI(JMOD) * ZCHEN_MULTI(KINDEX,JMOD) &
- * GAMMA_X0D( XKHEN_MULTI(JMOD)/2.0)*GAMMA_X0D(3.0/2.0) &
- / 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
-!
-END FUNCTION SINGL_FUNCSMAX
-!
-!-----------------------------------------------------------------------------
-!
-END SUBROUTINE LIMA_WARM_NUCL
diff --git a/src/arome/micro/lima_warm_sedimentation.F90 b/src/arome/micro/lima_warm_sedimentation.F90
deleted file mode 100644
index 28a8fde5d..000000000
--- a/src/arome/micro/lima_warm_sedimentation.F90
+++ /dev/null
@@ -1,425 +0,0 @@
-! ###################################
- MODULE MODI_LIMA_WARM_SEDIMENTATION
-! ###################################
-!
-INTERFACE
- SUBROUTINE LIMA_WARM_SEDIMENTATION (OSEDC, KSPLITR, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, &
- PZZ, PRHODREF, PPABST, ZT, &
- ZWLBDC, &
- PRCT, PRRT, PCCT, PCRT, &
- PRCS, PRRS, PCCS, PCRS, &
- PINPRC, PINPRR, PINPRR3D )
-!
-LOGICAL, INTENT(IN) :: OSEDC ! switch to activate the
- ! cloud droplet sedimentation
-INTEGER, INTENT(IN) :: KSPLITR ! Number of small time step
- ! for sedimendation
-REAL, INTENT(IN) :: PTSTEP ! Double Time step
- ! (single if cold start)
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZT ! Temperature
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZWLBDC ! libre parcours moyen
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCCT ! Cloud water C. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCRT ! Rain water C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCCS ! Cloud water C. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCRS ! Rain water C. source
-!
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRC ! Cloud instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRR ! Rain instant precip
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PINPRR3D ! Rain inst precip 3D
-!
-END SUBROUTINE LIMA_WARM_SEDIMENTATION
-END INTERFACE
-END MODULE MODI_LIMA_WARM_SEDIMENTATION
-! #####################################################################
- SUBROUTINE LIMA_WARM_SEDIMENTATION (OSEDC, KSPLITR, PTSTEP, KMI, &
- HFMFILE, HLUOUT, OCLOSE_OUT, &
- PZZ, PRHODREF, PPABST, ZT, &
- ZWLBDC, &
- PRCT, PRRT, PCCT, PCRT, &
- PRCS, PRRS, PCCS, PCRS, &
- PINPRC, PINPRR, PINPRR3D )
-! #####################################################################
-!
-!!
-!! PURPOSE
-!! -------
-!! The purpose of this routine is to compute the sedimentation
-!! of cloud droplets and rain drops
-!!
-!!
-!!** METHOD
-!! ------
-!! The sedimentation rates are computed with a time spliting technique:
-!! an upstream scheme, written as a difference of non-advective fluxes.
-!! This source term is added to the next coming time step (split-implicit
-!! process).
-!!
-!!
-!! REFERENCE
-!! ---------
-!!
-!! Cohard, J.-M. and J.-P. Pinty, 2000: A comprehensive two-moment warm
-!! microphysical bulk scheme.
-!! Part I: Description and tests
-!! Part II: 2D experiments with a non-hydrostatic model
-!! Accepted for publication in Quart. J. Roy. Meteor. Soc.
-!!
-!! AUTHOR
-!! ------
-!! J.-M. Cohard * Laboratoire d'Aerologie*
-!! J.-P. Pinty * Laboratoire d'Aerologie*
-!! S. Berthet * Laboratoire d'Aerologie*
-!! B. Vié * Laboratoire d'Aerologie*
-!!
-!! MODIFICATIONS
-!! -------------
-!! Original ??/??/13
-!!
-!-------------------------------------------------------------------------------
-!
-!* 0. DECLARATIONS
-! ------------
-!
-USE MODD_PARAMETERS, ONLY : JPHEXT, JPVEXT
-USE MODD_CST, ONLY : XRHOLW
-USE MODD_PARAM_LIMA, ONLY : XRTMIN, XCTMIN, XALPHAC, XNUC, XCEXVT
-USE MODD_PARAM_LIMA_WARM, ONLY : XLBC, XLBEXC, XLBR, XLBEXR, &
- XFSEDRC, XFSEDCC, XFSEDRR, XFSEDCR,&
- XDC, XDR
-USE MODI_LIMA_FUNCTIONS, ONLY : COUNTJV
-USE MODI_GAMMA, ONLY : GAMMA_X0D
-!
-USE YOMLUN , ONLY : NULOUT
-!
-IMPLICIT NONE
-!
-!* 0.1 Declarations of dummy arguments :
-!
-LOGICAL, INTENT(IN) :: OSEDC ! switch to activate the
- ! cloud droplet sedimentation
-INTEGER, INTENT(IN) :: KSPLITR ! Number of small time step
- ! for sedimendation
-REAL, INTENT(IN) :: PTSTEP ! Double Time step
- ! (single if cold start)
-INTEGER, INTENT(IN) :: KMI ! Model index
-CHARACTER(LEN=*), INTENT(IN) :: HFMFILE ! Name of the output FM-file
-CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name for
- ! model n
-LOGICAL, INTENT(IN) :: OCLOSE_OUT ! Conditional closure of
- ! the tput FM fileoutp
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PZZ ! Height (z)
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRHODREF ! Reference density
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABST ! abs. pressure at time t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZT ! Temperature
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: ZWLBDC ! libre parcours moyen
-!
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PRRT ! Rain water m.r. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCCT ! Cloud water C. at t
-REAL, DIMENSION(:,:,:), INTENT(IN) :: PCRT ! Rain water C. at t
-!
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRCS ! Cloud water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PRRS ! Rain water m.r. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCCS ! Cloud water C. source
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PCRS ! Rain water C. source
-!
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRC ! Cloud instant precip
-REAL, DIMENSION(:,:), INTENT(INOUT) :: PINPRR ! Rain instant precip
-REAL, DIMENSION(:,:,:), INTENT(INOUT) :: PINPRR3D ! Rain inst precip 3D
-!
-!
-!* 0.2 Declarations of local variables :
-!
-! Packing variables
-LOGICAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) :: GSEDIM
-INTEGER :: ISEDIM
-INTEGER , DIMENSION(SIZE(GSEDIM)) :: I1,I2,I3 ! Used to replace the COUNT
-INTEGER :: JL ! and PACK intrinsics
-!
-! Packed micophysical variables
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRCT ! Cloud water m.r. at t
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRRT ! Rain water m.r. at t
-REAL, DIMENSION(:) , ALLOCATABLE :: ZCCT ! cloud conc. at t
-REAL, DIMENSION(:) , ALLOCATABLE :: ZCRT ! rain conc. at t
-!
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRCS ! Cloud water m.r. source
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRRS ! Rain water m.r. source
-REAL, DIMENSION(:) , ALLOCATABLE :: ZCCS ! cloud conc. source
-REAL, DIMENSION(:) , ALLOCATABLE :: ZCRS ! rain conc. source
-!
-! Other packed variables
-REAL, DIMENSION(:) , ALLOCATABLE :: ZRHODREF ! RHO Dry REFerence
-REAL, DIMENSION(:) , ALLOCATABLE :: ZLBDC
-REAL, DIMENSION(:) , ALLOCATABLE :: ZLBDR
-!
-! Work arrays
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)) &
- :: ZW, &
- ZWLBDA, & ! Mean free path
- ZRAY, & ! Mean volumic radius
- ZCC ! Terminal vertical velocity
-REAL, DIMENSION(SIZE(PRHODREF,1),SIZE(PRHODREF,2),SIZE(PRHODREF,3)+1) &
- :: ZWSEDR, ZWSEDC ! Sedim. fluxes
-!
-REAL, DIMENSION(:), ALLOCATABLE :: ZZW1, ZZW2, ZZW3, &
- ZTCC, &
- ZRTMIN, ZCTMIN
-!
-!
-INTEGER :: JK ! Vertical loop index for the rain sedimentation
-INTEGER :: JN ! Temporal loop index for the rain sedimentation
-INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE ! Physical domain
-REAL :: ZTSPLITR ! Small time step for rain sedimentation
-!
-INTEGER :: IKMAX
-!
-!!!!!!!!!!! Entiers pour niveaux inversés dans AROME !!!!!!!!!!!!!!!!!!!!!!!!!!!
-INTEGER :: IBOTTOM, INVLVL
-!
-!-------------------------------------------------------------------------------
-!
-! 0. Prepare computations
-! -----------------------
-!
-!
-ALLOCATE(ZRTMIN(SIZE(XCTMIN)))
-ALLOCATE(ZCTMIN(SIZE(XCTMIN)))
-ZRTMIN(:) = XRTMIN(:) / PTSTEP
-ZCTMIN(:) = XCTMIN(:) / PTSTEP
-!
-IIB=1+JPHEXT
-IIE=SIZE(PZZ,1) - JPHEXT
-IJB=1+JPHEXT
-IJE=SIZE(PZZ,2) - JPHEXT
-IKB=1+JPVEXT
-IKE=SIZE(PZZ,3) - JPVEXT
-!
-!!!!!!!!!!! Entiers pour niveaux inversés dans AROME !!!!!!!!!!!!!!!!!!!!!!!!!!!
-IBOTTOM=IKE
-INVLVL=-1
-!
-ZWSEDR(:,:,:)=0.
-ZWSEDC(:,:,:)=0.
-IKMAX=SIZE(PRHODREF,3)
-!
-ZTSPLITR= PTSTEP / FLOAT(KSPLITR)
-!
-PINPRC(:,:) = 0.
-PINPRR(:,:) = 0.
-PINPRR3D(:,:,:) = 0.
-!
-IF (OSEDC) THEN
- ZWLBDA(:,:,:) = 0.
- ZRAY(:,:,:) = 0.
- ZCC(:,:,:) = 1.
- DO JK=IKB,IKE
- ZWLBDA(:,:,JK) = 6.6E-8*(101325./PPABST(:,:,JK))*(ZT(:,:,JK)/293.15)
- END DO
- WHERE (PRCT(:,:,:)>XRTMIN(2) .AND. PCCT(:,:,:)>XCTMIN(2))
- ZRAY(:,:,:) = 0.5*GAMMA_X0D(XNUC+1./XALPHAC)/(GAMMA_X0D(XNUC)*ZWLBDC(:,:,:))
- ! ZCC : Corrective Cunningham term for the terminal velocity
- ZCC(:,:,:)=1.+1.26*ZWLBDA(:,:,:)/ZRAY(:,:,:)
- END WHERE
-END IF
-!
-!-------------------------------------------------------------------------------
-!
-!
-! 1. Computations only where necessary
-! ------------------------------------
-!
-!
-DO JN = 1 , KSPLITR
- GSEDIM(:,:,:) = .FALSE.
- GSEDIM(IIB:IIE,IJB:IJE,IKB:IKE) = PRRS(IIB:IIE,IJB:IJE,IKB:IKE)>ZRTMIN(3) &
- .AND. PCRS(IIB:IIE,IJB:IJE,IKB:IKE)>ZCTMIN(3)
- IF( OSEDC ) THEN
- GSEDIM(IIB:IIE,IJB:IJE,IKB:IKE) = GSEDIM(IIB:IIE,IJB:IJE,IKB:IKE) .OR. &
- (PRCS(IIB:IIE,IJB:IJE,IKB:IKE)>ZRTMIN(2) &
- .AND. PCCS(IIB:IIE,IJB:IJE,IKB:IKE)>ZCTMIN(2) )
- END IF
-!
- ISEDIM = COUNTJV( GSEDIM(:,:,:),I1(:),I2(:),I3(:))
- IF( ISEDIM >= 1 ) THEN
-!
- IF( JN==1 ) THEN
- IF( OSEDC ) THEN
- PRCS(:,:,:) = PRCS(:,:,:) * PTSTEP
- PCCS(:,:,:) = PCCS(:,:,:) * PTSTEP
- END IF
- PRRS(:,:,:) = PRRS(:,:,:) * PTSTEP
- PCRS(:,:,:) = PCRS(:,:,:) * PTSTEP
- DO JK = IKB , IKE
-!Dans AROME, PZZ = épaisseur de la couche
-! ZW(:,:,JK)=ZTSPLITR/(PZZ(:,:,JK+1)-PZZ(:,:,JK))
- ZW(:,:,JK)=ZTSPLITR/(PZZ(:,:,JK))
- END DO
- END IF
-!
- ALLOCATE(ZRHODREF(ISEDIM))
- DO JL = 1,ISEDIM
- ZRHODREF(JL) = PRHODREF(I1(JL),I2(JL),I3(JL))
- END DO
-!
- ALLOCATE(ZZW1(ISEDIM))
- ALLOCATE(ZZW2(ISEDIM))
- ALLOCATE(ZZW3(ISEDIM))
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-! 2. Cloud droplets sedimentation
-! -------------------------------
-!
-!
- IF( OSEDC .AND. MAXVAL(PRCS(:,:,:))>ZRTMIN(2) ) THEN
- ZZW1(:) = 0.0
- ZZW2(:) = 0.0
- ZZW3(:) = 0.0
- ALLOCATE(ZRCS(ISEDIM))
- ALLOCATE(ZCCS(ISEDIM))
- ALLOCATE(ZRCT(ISEDIM))
- ALLOCATE(ZCCT(ISEDIM))
- ALLOCATE(ZTCC(ISEDIM))
- ALLOCATE(ZLBDC(ISEDIM))
- DO JL = 1,ISEDIM
- ZRCS(JL) = PRCS(I1(JL),I2(JL),I3(JL))
- ZCCS(JL) = PCCS(I1(JL),I2(JL),I3(JL))
- ZRCT(JL) = PRCT(I1(JL),I2(JL),I3(JL))
- ZCCT(JL) = PCCT(I1(JL),I2(JL),I3(JL))
- ZTCC(JL) = ZCC (I1(JL),I2(JL),I3(JL))
- END DO
- ZLBDC(:) = 1.E15
- WHERE (ZRCT(:)>XRTMIN(2) .AND. ZCCT(:)>XCTMIN(2))
- ZLBDC(:) = ( XLBC*ZCCT(:) / ZRCT(:) )**XLBEXC
- END WHERE
- WHERE( ZRCS(:)>ZRTMIN(2) )
- ZZW3(:) = ZRHODREF(:)**(-XCEXVT) * ZLBDC(:)**(-XDC)
- ZZW1(:) = ZTCC(:) * XFSEDRC * ZRCS(:) * ZZW3(:) * ZRHODREF(:)
- ZZW2(:) = ZTCC(:) * XFSEDCC * ZCCS(:) * ZZW3(:) * ZRHODREF(:)
- END WHERE
- ZWSEDR(:,:,1:IKMAX) = UNPACK( ZZW1(:),MASK=GSEDIM(:,:,:),FIELD=0.0 )
- ZWSEDC(:,:,1:IKMAX) = UNPACK( ZZW2(:),MASK=GSEDIM(:,:,:),FIELD=0.0 )
- DO JK = IKB+1 , IKE
- PRCS(:,:,JK) = PRCS(:,:,JK) + ZW(:,:,JK)* &
- (ZWSEDR(:,:,JK+1*INVLVL)-ZWSEDR(:,:,JK))/PRHODREF(:,:,JK)
- PCCS(:,:,JK) = PCCS(:,:,JK) + ZW(:,:,JK)* &
- (ZWSEDC(:,:,JK+1*INVLVL)-ZWSEDC(:,:,JK))/PRHODREF(:,:,JK)
- END DO
- PRCS(:,:,1) = PRCS(:,:,1) + ZW(:,:,1)* &
- (0.-ZWSEDR(:,:,1))/PRHODREF(:,:,1)
- PCCS(:,:,1) = PCCS(:,:,1) + ZW(:,:,1)* &
- (0.-ZWSEDC(:,:,1))/PRHODREF(:,:,1)
- DEALLOCATE(ZRCS)
- DEALLOCATE(ZCCS)
- DEALLOCATE(ZRCT)
- DEALLOCATE(ZCCT)
- DEALLOCATE(ZTCC)
- DEALLOCATE(ZLBDC)
-!
- PINPRC(:,:) = PINPRC(:,:) + ZWSEDR(:,:,IBOTTOM)/XRHOLW/KSPLITR ! in m/s
- ELSE
- ZWSEDR(:,:,IBOTTOM) = 0.0
- END IF ! OSEDC
-!
-!
-!-------------------------------------------------------------------------------
-!
-!
-! 2. Rain drops sedimentation
-! ---------------------------
-!
-!
- IF( MAXVAL(PRRS(:,:,:))>ZRTMIN(3) ) THEN
- ZZW1(:) = 0.0
- ZZW2(:) = 0.0
- ZZW3(:) = 0.0
- ALLOCATE(ZRRS(ISEDIM))
- ALLOCATE(ZCRS(ISEDIM))
- ALLOCATE(ZRRT(ISEDIM))
- ALLOCATE(ZCRT(ISEDIM))
- ALLOCATE(ZLBDR(ISEDIM))
- DO JL = 1,ISEDIM
- ZRRS(JL) = PRRS(I1(JL),I2(JL),I3(JL))
- ZCRS(JL) = PCRS(I1(JL),I2(JL),I3(JL))
- ZRRT(JL) = PRRT(I1(JL),I2(JL),I3(JL))
- ZCRT(JL) = PCRT(I1(JL),I2(JL),I3(JL))
- END DO
- ZLBDR(:) = 1.E10
- WHERE (ZRRT(:)>XRTMIN(3) .AND. ZCRT(:)>XCTMIN(3))
- ZLBDR(:) = ( XLBR*ZCRT(:) / ZRRT(:) )**XLBEXR
- END WHERE
- WHERE( ZRRS(:)>ZRTMIN(3) )
- ZZW3(:) = ZRHODREF(:)**(-XCEXVT) * (ZLBDR(:)**(-XDR))
- ZZW1(:) = XFSEDRR * ZRRS(:) * ZZW3(:) * ZRHODREF(:)
- ZZW2(:) = XFSEDCR * ZCRS(:) * ZZW3(:) * ZRHODREF(:)
- END WHERE
- ZWSEDR(:,:,1:IKMAX) = UNPACK( ZZW1(:),MASK=GSEDIM(:,:,:),FIELD=0.0 )
- ZWSEDC(:,:,1:IKMAX) = UNPACK( ZZW2(:),MASK=GSEDIM(:,:,:),FIELD=0.0 )
- DO JK = IKB+1 , IKE
- PRRS(:,:,JK) = PRRS(:,:,JK) + ZW(:,:,JK)* &
- (ZWSEDR(:,:,JK+1*INVLVL)-ZWSEDR(:,:,JK))/PRHODREF(:,:,JK)
- PCRS(:,:,JK) = PCRS(:,:,JK) + ZW(:,:,JK)* &
- (ZWSEDC(:,:,JK+1*INVLVL)-ZWSEDC(:,:,JK))/PRHODREF(:,:,JK)
- END DO
- PRRS(:,:,1) = PRRS(:,:,1) + ZW(:,:,1)* &
- (0.-ZWSEDR(:,:,1))/PRHODREF(:,:,1)
- PCRS(:,:,1) = PCRS(:,:,1) + ZW(:,:,1)* &
- (0.-ZWSEDC(:,:,1))/PRHODREF(:,:,1)
- DEALLOCATE(ZRRS)
- DEALLOCATE(ZCRS)
- DEALLOCATE(ZRRT)
- DEALLOCATE(ZCRT)
- DEALLOCATE(ZLBDR)
- ELSE
- ZWSEDR(:,:,IBOTTOM) = 0.0
- END IF ! max PRRS > ZRTMIN(3)
-!
- PINPRR(:,:) = PINPRR(:,:) + ZWSEDR(:,:,IBOTTOM)/XRHOLW/KSPLITR ! in m/s
- PINPRR3D(:,:,:) = PINPRR3D(:,:,:) + ZWSEDR(:,:,1:IKMAX)/XRHOLW/KSPLITR ! in m/s
-!
- DEALLOCATE(ZRHODREF)
- DEALLOCATE(ZZW1)
- DEALLOCATE(ZZW2)
- DEALLOCATE(ZZW3)
- IF( JN==KSPLITR ) THEN
- IF( OSEDC ) THEN
- PRCS(:,:,:) = PRCS(:,:,:) / PTSTEP
- PCCS(:,:,:) = PCCS(:,:,:) / PTSTEP
- END IF
- PRRS(:,:,:) = PRRS(:,:,:) / PTSTEP
- PCRS(:,:,:) = PCRS(:,:,:) / PTSTEP
- END IF
- END IF ! ISEDIM
-END DO ! KSPLITR
-!
-!++cb++
-DEALLOCATE(ZRTMIN)
-DEALLOCATE(ZCTMIN)
-!--cb--
-
-!
-!-------------------------------------------------------------------------------
-!
-END SUBROUTINE LIMA_WARM_SEDIMENTATION
diff --git a/src/mesonh/micro/hypgeo.f90 b/src/common/micro/hypgeo.F90
similarity index 100%
rename from src/mesonh/micro/hypgeo.f90
rename to src/common/micro/hypgeo.F90
diff --git a/src/mesonh/micro/ini_lima.f90 b/src/common/micro/ini_lima.F90
similarity index 100%
rename from src/mesonh/micro/ini_lima.f90
rename to src/common/micro/ini_lima.F90
diff --git a/src/mesonh/micro/ini_lima_cold_mixed.f90 b/src/common/micro/ini_lima_cold_mixed.F90
similarity index 100%
rename from src/mesonh/micro/ini_lima_cold_mixed.f90
rename to src/common/micro/ini_lima_cold_mixed.F90
diff --git a/src/mesonh/micro/ini_lima_warm.f90 b/src/common/micro/ini_lima_warm.F90
similarity index 100%
rename from src/mesonh/micro/ini_lima_warm.f90
rename to src/common/micro/ini_lima_warm.F90
diff --git a/src/mesonh/micro/init_aerosol_properties.f90 b/src/common/micro/init_aerosol_properties.F90
similarity index 100%
rename from src/mesonh/micro/init_aerosol_properties.f90
rename to src/common/micro/init_aerosol_properties.F90
diff --git a/src/mesonh/micro/lima.f90 b/src/common/micro/lima.F90
similarity index 100%
rename from src/mesonh/micro/lima.f90
rename to src/common/micro/lima.F90
diff --git a/src/mesonh/micro/lima_adjust_split.f90 b/src/common/micro/lima_adjust_split.F90
similarity index 100%
rename from src/mesonh/micro/lima_adjust_split.f90
rename to src/common/micro/lima_adjust_split.F90
diff --git a/src/mesonh/micro/lima_bergeron.f90 b/src/common/micro/lima_bergeron.F90
similarity index 100%
rename from src/mesonh/micro/lima_bergeron.f90
rename to src/common/micro/lima_bergeron.F90
diff --git a/src/mesonh/micro/lima_ccn_activation.f90 b/src/common/micro/lima_ccn_activation.F90
similarity index 100%
rename from src/mesonh/micro/lima_ccn_activation.f90
rename to src/common/micro/lima_ccn_activation.F90
diff --git a/src/mesonh/micro/lima_ccn_hom_freezing.f90 b/src/common/micro/lima_ccn_hom_freezing.F90
similarity index 100%
rename from src/mesonh/micro/lima_ccn_hom_freezing.f90
rename to src/common/micro/lima_ccn_hom_freezing.F90
diff --git a/src/mesonh/micro/lima_collisional_ice_breakup.f90 b/src/common/micro/lima_collisional_ice_breakup.F90
similarity index 100%
rename from src/mesonh/micro/lima_collisional_ice_breakup.f90
rename to src/common/micro/lima_collisional_ice_breakup.F90
diff --git a/src/mesonh/micro/lima_compute_cloud_fractions.f90 b/src/common/micro/lima_compute_cloud_fractions.F90
similarity index 100%
rename from src/mesonh/micro/lima_compute_cloud_fractions.f90
rename to src/common/micro/lima_compute_cloud_fractions.F90
diff --git a/src/mesonh/micro/lima_conversion_melting_snow.f90 b/src/common/micro/lima_conversion_melting_snow.F90
similarity index 100%
rename from src/mesonh/micro/lima_conversion_melting_snow.f90
rename to src/common/micro/lima_conversion_melting_snow.F90
diff --git a/src/mesonh/micro/lima_droplets_accretion.f90 b/src/common/micro/lima_droplets_accretion.F90
similarity index 100%
rename from src/mesonh/micro/lima_droplets_accretion.f90
rename to src/common/micro/lima_droplets_accretion.F90
diff --git a/src/mesonh/micro/lima_droplets_autoconversion.f90 b/src/common/micro/lima_droplets_autoconversion.F90
similarity index 100%
rename from src/mesonh/micro/lima_droplets_autoconversion.f90
rename to src/common/micro/lima_droplets_autoconversion.F90
diff --git a/src/mesonh/micro/lima_droplets_hom_freezing.f90 b/src/common/micro/lima_droplets_hom_freezing.F90
similarity index 100%
rename from src/mesonh/micro/lima_droplets_hom_freezing.f90
rename to src/common/micro/lima_droplets_hom_freezing.F90
diff --git a/src/mesonh/micro/lima_droplets_riming_snow.f90 b/src/common/micro/lima_droplets_riming_snow.F90
similarity index 100%
rename from src/mesonh/micro/lima_droplets_riming_snow.f90
rename to src/common/micro/lima_droplets_riming_snow.F90
diff --git a/src/mesonh/micro/lima_droplets_self_collection.f90 b/src/common/micro/lima_droplets_self_collection.F90
similarity index 100%
rename from src/mesonh/micro/lima_droplets_self_collection.f90
rename to src/common/micro/lima_droplets_self_collection.F90
diff --git a/src/mesonh/micro/lima_drops_break_up.f90 b/src/common/micro/lima_drops_break_up.F90
similarity index 100%
rename from src/mesonh/micro/lima_drops_break_up.f90
rename to src/common/micro/lima_drops_break_up.F90
diff --git a/src/mesonh/micro/lima_drops_hom_freezing.f90 b/src/common/micro/lima_drops_hom_freezing.F90
similarity index 100%
rename from src/mesonh/micro/lima_drops_hom_freezing.f90
rename to src/common/micro/lima_drops_hom_freezing.F90
diff --git a/src/mesonh/micro/lima_drops_self_collection.f90 b/src/common/micro/lima_drops_self_collection.F90
similarity index 100%
rename from src/mesonh/micro/lima_drops_self_collection.f90
rename to src/common/micro/lima_drops_self_collection.F90
diff --git a/src/mesonh/micro/lima_drops_to_droplets_conv.f90 b/src/common/micro/lima_drops_to_droplets_conv.F90
similarity index 100%
rename from src/mesonh/micro/lima_drops_to_droplets_conv.f90
rename to src/common/micro/lima_drops_to_droplets_conv.F90
diff --git a/src/mesonh/micro/lima_functions.f90 b/src/common/micro/lima_functions.F90
similarity index 100%
rename from src/mesonh/micro/lima_functions.f90
rename to src/common/micro/lima_functions.F90
diff --git a/src/mesonh/micro/lima_graupel.f90 b/src/common/micro/lima_graupel.F90
similarity index 100%
rename from src/mesonh/micro/lima_graupel.f90
rename to src/common/micro/lima_graupel.F90
diff --git a/src/mesonh/micro/lima_graupel_deposition.f90 b/src/common/micro/lima_graupel_deposition.F90
similarity index 100%
rename from src/mesonh/micro/lima_graupel_deposition.f90
rename to src/common/micro/lima_graupel_deposition.F90
diff --git a/src/mesonh/micro/lima_hail.f90 b/src/common/micro/lima_hail.F90
similarity index 100%
rename from src/mesonh/micro/lima_hail.f90
rename to src/common/micro/lima_hail.F90
diff --git a/src/mesonh/micro/lima_hail_deposition.f90 b/src/common/micro/lima_hail_deposition.F90
similarity index 100%
rename from src/mesonh/micro/lima_hail_deposition.f90
rename to src/common/micro/lima_hail_deposition.F90
diff --git a/src/mesonh/micro/lima_ice_aggregation_snow.f90 b/src/common/micro/lima_ice_aggregation_snow.F90
similarity index 100%
rename from src/mesonh/micro/lima_ice_aggregation_snow.f90
rename to src/common/micro/lima_ice_aggregation_snow.F90
diff --git a/src/mesonh/micro/lima_ice_deposition.f90 b/src/common/micro/lima_ice_deposition.F90
similarity index 100%
rename from src/mesonh/micro/lima_ice_deposition.f90
rename to src/common/micro/lima_ice_deposition.F90
diff --git a/src/mesonh/micro/lima_ice_melting.f90 b/src/common/micro/lima_ice_melting.F90
similarity index 100%
rename from src/mesonh/micro/lima_ice_melting.f90
rename to src/common/micro/lima_ice_melting.F90
diff --git a/src/mesonh/micro/lima_init_ccn_activation_spectrum.f90 b/src/common/micro/lima_init_ccn_activation_spectrum.F90
similarity index 100%
rename from src/mesonh/micro/lima_init_ccn_activation_spectrum.f90
rename to src/common/micro/lima_init_ccn_activation_spectrum.F90
diff --git a/src/mesonh/micro/lima_inst_procs.f90 b/src/common/micro/lima_inst_procs.F90
similarity index 100%
rename from src/mesonh/micro/lima_inst_procs.f90
rename to src/common/micro/lima_inst_procs.F90
diff --git a/src/mesonh/micro/lima_meyers_nucleation.f90 b/src/common/micro/lima_meyers_nucleation.F90
similarity index 100%
rename from src/mesonh/micro/lima_meyers_nucleation.f90
rename to src/common/micro/lima_meyers_nucleation.F90
diff --git a/src/mesonh/micro/lima_nucleation_procs.f90 b/src/common/micro/lima_nucleation_procs.F90
similarity index 100%
rename from src/mesonh/micro/lima_nucleation_procs.f90
rename to src/common/micro/lima_nucleation_procs.F90
diff --git a/src/mesonh/micro/lima_phillips_ifn_nucleation.f90 b/src/common/micro/lima_phillips_ifn_nucleation.F90
similarity index 100%
rename from src/mesonh/micro/lima_phillips_ifn_nucleation.f90
rename to src/common/micro/lima_phillips_ifn_nucleation.F90
diff --git a/src/mesonh/micro/lima_phillips_integ.f90 b/src/common/micro/lima_phillips_integ.F90
similarity index 100%
rename from src/mesonh/micro/lima_phillips_integ.f90
rename to src/common/micro/lima_phillips_integ.F90
diff --git a/src/mesonh/micro/lima_phillips_ref_spectrum.f90 b/src/common/micro/lima_phillips_ref_spectrum.F90
similarity index 100%
rename from src/mesonh/micro/lima_phillips_ref_spectrum.f90
rename to src/common/micro/lima_phillips_ref_spectrum.F90
diff --git a/src/mesonh/micro/lima_rain_accr_snow.f90 b/src/common/micro/lima_rain_accr_snow.F90
similarity index 100%
rename from src/mesonh/micro/lima_rain_accr_snow.f90
rename to src/common/micro/lima_rain_accr_snow.F90
diff --git a/src/mesonh/micro/lima_rain_evaporation.f90 b/src/common/micro/lima_rain_evaporation.F90
similarity index 100%
rename from src/mesonh/micro/lima_rain_evaporation.f90
rename to src/common/micro/lima_rain_evaporation.F90
diff --git a/src/mesonh/micro/lima_rain_freezing.f90 b/src/common/micro/lima_rain_freezing.F90
similarity index 100%
rename from src/mesonh/micro/lima_rain_freezing.f90
rename to src/common/micro/lima_rain_freezing.F90
diff --git a/src/mesonh/micro/lima_raindrop_shattering_freezing.f90 b/src/common/micro/lima_raindrop_shattering_freezing.F90
similarity index 100%
rename from src/mesonh/micro/lima_raindrop_shattering_freezing.f90
rename to src/common/micro/lima_raindrop_shattering_freezing.F90
diff --git a/src/mesonh/micro/lima_read_xker_gweth.f90 b/src/common/micro/lima_read_xker_gweth.F90
similarity index 100%
rename from src/mesonh/micro/lima_read_xker_gweth.f90
rename to src/common/micro/lima_read_xker_gweth.F90
diff --git a/src/mesonh/micro/lima_read_xker_raccs.f90 b/src/common/micro/lima_read_xker_raccs.F90
similarity index 100%
rename from src/mesonh/micro/lima_read_xker_raccs.f90
rename to src/common/micro/lima_read_xker_raccs.F90
diff --git a/src/mesonh/micro/lima_read_xker_rdryg.f90 b/src/common/micro/lima_read_xker_rdryg.F90
similarity index 100%
rename from src/mesonh/micro/lima_read_xker_rdryg.f90
rename to src/common/micro/lima_read_xker_rdryg.F90
diff --git a/src/mesonh/micro/lima_read_xker_sdryg.f90 b/src/common/micro/lima_read_xker_sdryg.F90
similarity index 100%
rename from src/mesonh/micro/lima_read_xker_sdryg.f90
rename to src/common/micro/lima_read_xker_sdryg.F90
diff --git a/src/mesonh/micro/lima_read_xker_sweth.f90 b/src/common/micro/lima_read_xker_sweth.F90
similarity index 100%
rename from src/mesonh/micro/lima_read_xker_sweth.f90
rename to src/common/micro/lima_read_xker_sweth.F90
diff --git a/src/mesonh/micro/lima_sedimentation.f90 b/src/common/micro/lima_sedimentation.F90
similarity index 100%
rename from src/mesonh/micro/lima_sedimentation.f90
rename to src/common/micro/lima_sedimentation.F90
diff --git a/src/mesonh/micro/lima_snow_deposition.f90 b/src/common/micro/lima_snow_deposition.F90
similarity index 100%
rename from src/mesonh/micro/lima_snow_deposition.f90
rename to src/common/micro/lima_snow_deposition.F90
diff --git a/src/mesonh/micro/lima_snow_self_collection.f90 b/src/common/micro/lima_snow_self_collection.F90
similarity index 100%
rename from src/mesonh/micro/lima_snow_self_collection.f90
rename to src/common/micro/lima_snow_self_collection.F90
diff --git a/src/mesonh/micro/lima_tendencies.f90 b/src/common/micro/lima_tendencies.F90
similarity index 100%
rename from src/mesonh/micro/lima_tendencies.f90
rename to src/common/micro/lima_tendencies.F90
diff --git a/src/common/micro/minpack.F90 b/src/common/micro/minpack.F90
new file mode 100644
index 000000000..c927712e4
--- /dev/null
+++ b/src/common/micro/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/mesonh/micro/modd_param_lima.f90 b/src/common/micro/modd_param_lima.F90
similarity index 100%
rename from src/mesonh/micro/modd_param_lima.f90
rename to src/common/micro/modd_param_lima.F90
diff --git a/src/mesonh/micro/modd_param_lima_cold.f90 b/src/common/micro/modd_param_lima_cold.F90
similarity index 100%
rename from src/mesonh/micro/modd_param_lima_cold.f90
rename to src/common/micro/modd_param_lima_cold.F90
diff --git a/src/mesonh/micro/modd_param_lima_mixed.f90 b/src/common/micro/modd_param_lima_mixed.F90
similarity index 100%
rename from src/mesonh/micro/modd_param_lima_mixed.f90
rename to src/common/micro/modd_param_lima_mixed.F90
diff --git a/src/mesonh/micro/modd_param_lima_warm.f90 b/src/common/micro/modd_param_lima_warm.F90
similarity index 100%
rename from src/mesonh/micro/modd_param_lima_warm.f90
rename to src/common/micro/modd_param_lima_warm.F90
diff --git a/tools/check_commit_mesonh.sh b/tools/check_commit_mesonh.sh
index 83cc1f7c7..ddfab901b 100755
--- a/tools/check_commit_mesonh.sh
+++ b/tools/check_commit_mesonh.sh
@@ -84,7 +84,7 @@ done
MNHPACK=${MNHPACK:=$HOME/MesoNH/PHYEX}
REFDIR=${REFDIR:=$PHYEXTOOLSDIR/pack/}
-TARGZDIR=${TARGZDIR:=$PHYEXTOOLSDIR/pack/}
+TARGZDIR=${TARGZDIR:=/home/rodierq/UBUNTU22/}
if [ -z "${tests-}" ]; then
tests=$defaultTest
elif [ $tests == 'ALL' ]; then
--
GitLab