| blob | ed924087546fc328cc49615a49ae3acc3429d211 |
1 ! The National Taiwan University (NTU) scheme is a multi-moment bulk scheme (two moments for the liquid-phase and 3 moments
2 ! for the ice-phase hydrometeors) with consideration for ice crystal shape and density variations. This scheme is developed
3 ! by Dr. Tzu-Chin Tsai and Prof. Jen-Ping Chen at the National Taiwan University. The NTU multi-moment bulk microphysics scheme
4 ! default version implemented into the WRF model by Tzu-Chin Tsai at NTU (d97229002@ntu.edu.tw; tzuchin12@gmail.com)
5 ! Realsed on 2021/1/6
6 !-------------------------------------------------------------------------------------------------------------------------------
7 ! References :
8 ! 1. Chen, J.-P. and S.-T. Liu, 2004: Physically based two-moment bulkwater parametrization for warm-cloud microphysics.
9 ! Quart. J. Roy. Meteor. Soc., 130, 51-78.
10 ! 2. Cheng, C.-T., W.-C. Wang, and J.-P. Chen, 2007: A modeling study of aerosol impacts on cloud microphysics and radiative
11 ! properties. Quart. J. Roy. Meteor. Soc., 133, 283-297.
12 ! 3. Cheng, C.-T., W.-C. Wang, and J.-P. Chen, 2010: Simulation of the effects of increasing cloud condensation nuclei on
13 ! mixed-phase clouds and precipitation of a front system. Atmos. Res., 96, 461-476.
14 ! 4. Chen, J.-P. and T.-C. Tsai, 2016: Triple-moment modal parameterization for the adaptive growth habit of pristine ice
15 ! crystals. J. Atmos. Sci., 73, 2105-2122.
16 ! 5. Tsai, T.-C., and J.-P. Chen, 2020: Multi-moment ice bulk microphysics scheme with consideration for particle shape
17 ! and apparent density. Part I: Methodology and idealized simulation. J. Atmos. Sci., 77, 1821-1850.
18 !
19 !--------------------------------------------------------------------------------------------------------------------------------
20 ! The notation for terms involving two interacting categories are denoted by B(x,y)MPxy, where B is the prognostic variable
21 ! MP represents the microphysical processes, and the subscripts x and y indicate the quantity B being transferred from the
22 ! hydrometeor category x to y. If terms involve three interacting categories, then a three-letter subscript of xyz would
23 ! follow the microphysical process with the destination of hydrometeor category z. Another notation denoted by QHomp is
24 ! only used for the change rate of the hailstone mixing ratio, and o indicates whether the dry (denote d) or wet (denote w)
25 ! growth mode occurs. Please referred to supplemental information related to the Tsai and Chen (2020) is available at the
26 ! Journals Online website: https://doi.org/10.1175/JAS-D-19-0125.s1.
27 !
28 !=================================================================================================================================
30 MODULE module_mp_ntu
31 USE module_wrf_error
33 IMPLICIT NONE
34 PUBLIC :: MP_NTU
35 PRIVATE :: GAMMA,GAMLN,GAMIN,GAMMP,GSER,CFG,GUESS_RC,YEQU,DYEQU, &
36 PDF,DPDF,DLNX,POLYSVP
38 INTEGER, PRIVATE, PARAMETER :: ID_NH42SO4 = 1, &! 1. (NH4)2SO4
39 ID_DUST = 0, &! 2. DUST
40 ID_IN = 2 ! 3. IN
41 INTEGER, PRIVATE, PARAMETER :: INSPEC = 2 ! 1. SOOT; 2. SD; 3. AD; 4. BT
42 INTEGER, PRIVATE, PARAMETER :: ICE_SHAPE = 1 ! 0. SPHERICAL; 1. ASPHERICAL; PRISTINE ICE (HABIT)
43 INTEGER, PRIVATE, PARAMETER :: AGG_SHAPE = 1 ! 0. SPHERICAL; 1. CL94; ASPHERICAL AGGREGATES
44 INTEGER, PRIVATE, PARAMETER :: ICE_RHOI = 1 ! 0. FIXED; 1. PREDICT; 2. FIXED; PRISTINE ICE DENSITY
45 INTEGER, PRIVATE, PARAMETER :: ICE_RHOS = 1 ! 0. FIXED; 1. PREDICT; 2. MAPPING; AGGREGATES DENSITY
46 INTEGER, PRIVATE, PARAMETER :: ICE_RHOG = 1 ! 0. FIXED; 1. CL1993; 2. RH1985; PREDICT GRAUPEL DENSITY
47 INTEGER, PRIVATE, PARAMETER :: ICE_VENT = 2 ! 0. OFF; 1. HP76; 2. CL94; 3. JW99; VENTILATION EFFECT
48 INTEGER, PRIVATE, PARAMETER :: HAIL_VENT = 1 ! 0. DEFAULT; 1. CHENG ET AL. (2014); VENTILATION EFFECT
49 INTEGER, PRIVATE, PARAMETER :: HWET_MODE = 1 ! 0. OFF; 1. ON; HAILSTONE WET GROWTH
50 INTEGER, PRIVATE, PARAMETER :: LIQ_VTC = 1 ! 0. RAMS/FIXED; 1.,2. CL04; CLOUD DROPS/FLUX FALL SPEED
51 INTEGER, PRIVATE, PARAMETER :: LIQ_VTR = 1 ! 0. RAMS/FIXED; 1.,2. CL04; RAIN DROPS/FLUX FALL SPEED
52 INTEGER, PRIVATE, PARAMETER :: ICE_VTI = 1 ! 0. MORR/FIXED; 1. MH05; PRISTINE ICE FALL SPEED
53 INTEGER, PRIVATE, PARAMETER :: ICE_VTS = 1 ! 0. RAMS/FIXED; 1. MH05/EM16 SYNOPTIC;
54 ! 2. SH09 CRYSTAL-FACE; AGGREGATES FALL SPEED
55 INTEGER, PRIVATE, PARAMETER :: ICE_VTG = 1 ! 0. RAMS/FIXED; 1. MH05; GRAUPEL FALL SPEED
56 INTEGER, PRIVATE, PARAMETER :: ICE_VTH = 1 ! 0. RAMS/FIXED; 1. MH05; HAIL FALL SPEED
57 INTEGER, PRIVATE, PARAMETER :: AFAC_3M = 1 ! 0. FIXED; 1.,2. VARIABLE AFAC PARAMETER
58 INTEGER, PRIVATE, PARAMETER :: AFAR_3M = 1 ! 0. FIXED; 1.,2. VARIABLE AFAR PARAMETER
59 INTEGER, PRIVATE, PARAMETER :: AFAI_3M = 1 ! 0. FIXED; 1.,2. VARIABLE AFAI PARAMETER
60 INTEGER, PRIVATE, PARAMETER :: AFAS_3M = 1 ! 0. FIXED; 1.,2. VARIABLE AFAS PARAMETER
61 INTEGER, PRIVATE, PARAMETER :: AFAG_3M = 1 ! 0. FIXED; 1.,2. VARIABLE AFAG PARAMETER
62 INTEGER, PRIVATE, PARAMETER :: AFAH_3M = 1 ! 0. FIXED; 1.,2. VARIABLE AFAH PARAMETER
63 INTEGER, PRIVATE, PARAMETER :: SAT_ADJ = 0 ! 0. OFF (SUPER-SAT); 1. WITH SATURATION ADJUSTMENT
64 INTEGER, PRIVATE, PARAMETER :: NCCN = 3 ! for aerosol modes
65 INTEGER, PRIVATE, PARAMETER :: NAER = 2 ! for aerosol categories of CCN and IN
66 INTEGER, PRIVATE, PARAMETER :: MAER = 4, NAER1 = 4, NAER2 = 1
67 INTEGER, PRIVATE, PARAMETER :: NAERT = NAER1+NAER2 ! 5
68 INTEGER, PRIVATE, PARAMETER :: NTBXA = 25 ! size of tables for the first guess of Rc
69 INTEGER, PRIVATE, DIMENSION(NAER) :: IBAER
70 INTEGER, PRIVATE, DIMENSION(NAER) :: NAERN(1:NAER)=(/NAER1,NAER2/)
71 DOUBLE PRECISION, PRIVATE, SAVE, DIMENSION(NTBXA) :: TBLRC ! table of curresponding R-cut-off
72 DOUBLE PRECISION, PRIVATE, SAVE, DIMENSION(NTBXA,NAER) :: TBLXF
73 !----------------- FOR MICROPHYSICAL PROCESSES -------------------------
74 REAL, PRIVATE, PARAMETER :: DTMIN = 0.01 ! [sec] mininum dt for cond./evap. calculation
75 REAL, PRIVATE, PARAMETER :: DT20S = 20. ! [sec] dt for coalscence and accretion calculation
76 REAL, PRIVATE, PARAMETER :: PI = 3.1415926535897932384626434
77 REAL, PRIVATE, PARAMETER :: SQRTPI = 9.189385332046727417803297E-1
78 REAL, PRIVATE, PARAMETER :: SQRT2 = 1.4142135623730950488016887
79 REAL, PRIVATE, PARAMETER :: THRD = 1./3., C4PI3 = 4.*PI/3.
80 REAL, PRIVATE, PARAMETER :: CP = 1.00546E3, TK0C = 2.7315E2
81 REAL, PRIVATE, PARAMETER :: R = 2.87058E2, RV = 4.61495E2
82 REAL, PRIVATE, PARAMETER :: CPI = 2.093E3, CPW = 4.218E3 ! SPECIFIC HEAT
83 REAL, PRIVATE, PARAMETER :: CMW = 1.8015E-2
84 REAL, PRIVATE, PARAMETER :: RHOSU = 8.5E4/(2.8715E2*2.7315E2)
85 REAL, PRIVATE, PARAMETER :: RHOW = 9.97E2, RHOG1 = 4.E2 ! BULK DENSITY
86 REAL, PRIVATE, PARAMETER :: RHOI0 = 9.1E2, iRHOI0 = 1./RHOI0 ! SOLID ICE DENSITY
87 REAL, PRIVATE, PARAMETER :: RHOS0 = 1.E2, RHOI1 = 5.E2
88 REAL, PRIVATE, PARAMETER :: RHOG0 = (0.078+0.184*6.-0.015*36.)*1000
89 REAL, PRIVATE, PARAMETER :: RHOH = 9.E2, iRHOH = 1./RHOH
90 REAL, PRIVATE, PARAMETER :: RHOIMIN = 5.E1, RHOIMAX = RHOI0
91 REAL, PRIVATE, PARAMETER :: C4PI3W = 4.*PI*RHOW/3.
92 REAL, PRIVATE, PARAMETER :: iAMI0 = 6./(PI*RHOI0)
93 REAL, PRIVATE, PARAMETER :: G = 9.806, iAPW = 4./(PI*RHOW)
94 REAL, PRIVATE, PARAMETER :: AAW = PI/4., V2M3 = 6./PI
95 REAL, PRIVATE, PARAMETER :: BMW = 3., AMW = PI*RHOW/6. ! MASS-DIAMETER PARAMETERS
96 REAL, PRIVATE, PARAMETER :: BMI0 = 3., AMI0 = PI*RHOI0/6. !
97 REAL, PRIVATE, PARAMETER :: BMS = 3., AMS0 = PI*RHOS0/6. !
98 REAL, PRIVATE, PARAMETER :: BMG = 3., AMG0 = PI*RHOG1/6. !
99 REAL, PRIVATE, PARAMETER :: BMH = 3., AMH = PI*RHOH/6. !
100 REAL, PRIVATE, PARAMETER :: iAMW = 1./AMW, iAMH = 1./AMH !
101 REAL, PRIVATE, PARAMETER :: AIMM = 6.6E-1, BIMM = 1.E2 ! BIGG 1953 PARAMETERS FOR IMMERSION FREEZING
102 REAL, PRIVATE, PARAMETER :: AVSG = 8.6E-1, BVSG = 2.8E-1 ! VENTILATION COEFFICIENTS
103 REAL, PRIVATE, PARAMETER :: AVRH = 7.8E-1, BVRH = 3.08E-1 !
104 REAL, PRIVATE, PARAMETER :: AVIS = 1., BVIS = 1.4E-1 !
105 REAL, PRIVATE, PARAMETER :: VENC1 = 3.09E-2, VENC2 = 1.447E-1 ! VENTILATION COEFFICIENTS
106 REAL, PRIVATE, PARAMETER :: VENP1 = 1.05E-2, VENP2 = 2.28E-2 ! FOR PRISITNE ICE CRYSTAL
107 REAL, PRIVATE, PARAMETER :: VENH1 = 0.22385, VENH2 = 0.00101 ! FOR HAILSTONE (Cheng et al., 2014)
108 REAL, PRIVATE, PARAMETER :: NSMALL = 1.E-2, NSMAL1 = 1.E2 ! MOMENTS LIMITS
109 REAL, PRIVATE, PARAMETER :: RLIMIT = 1.E-32, SLIMIT = 1.E-2 !
110 REAL, PRIVATE, PARAMETER :: QSMAL1 = 1.E-9, QSMALL = 1.E-14 !
111 REAL, PRIVATE, PARAMETER :: QLIMIT = 1.E-6, RSMALL = 1.E-20 !
112 REAL, PRIVATE, PARAMETER :: ASMALL = 1.E-12, ISMALL = 1.E-17 !
113 REAL, PRIVATE, PARAMETER :: BOLTZ = 1.38E-23, MLIMIT = 1.E-2 !
114 REAL, PRIVATE, PARAMETER :: VTZ0 = 5.83, VTC0 = 0.6 ! SURFACE ROUGHNESS PARAMETERS
115 REAL, PRIVATE, PARAMETER :: VTC1 = 0.151931, VTC2 = VTZ0**2./4. ! VTC1=4./(VTZ0**2.*VTC0**5.E-1)
116 REAL, PRIVATE, PARAMETER :: VTA0 = 1.7E-3, VTB0 = 0. ! VTB0 = 0.8
117 REAL, PRIVATE, PARAMETER :: AVC0 = 3.E7, BVC0 = 2. ! Morrison scheme
118 REAL, PRIVATE, PARAMETER :: AVR0 = 841.997, BVR0 = 0.8 ! Morrison scheme
119 REAL, PRIVATE, PARAMETER :: AVI0 = 700., BVI0 = 1. ! Morrison scheme
120 REAL, PRIVATE, PARAMETER :: AVS0 = 11.72, BVS0 = 0.41 ! Locatelli and Hobbs (1974)
121 REAL, PRIVATE, PARAMETER :: AVG0 = 19.3, BVG0 = 0.37 ! Ferrier (1994)
122 REAL, PRIVATE, PARAMETER :: AVH0 = 206.89, BVH0 = 0.6384 ! Ferrier (1994)
123 REAL, PRIVATE, PARAMETER :: VTCMAX = 1., VTSMAX = 10. ! UPPER LIMIT FALL SPEED CHECK
124 REAL, PRIVATE, PARAMETER :: VTIMAX = 10., VTRMAX = 15. !
125 REAL, PRIVATE, PARAMETER :: VTGMAX = 20., VTHMAX = 25. !
126 REAL, PRIVATE, PARAMETER :: AFAC0 = 0., AFAR0 = 0. ! INITIAL SPECTRAL INDEX
127 REAL, PRIVATE, PARAMETER :: AFAI0 = 3., AFAS0 = 0. !
128 REAL, PRIVATE, PARAMETER :: AFAG0 = 0., AFAH0 = 0. !
129 REAL, PRIVATE, PARAMETER :: SASMAX = 1., SASMIN = 1.E-3 ! ASPECT RATIO CHECK FOR AGGREGATES SHAPE
130 REAL, PRIVATE, PARAMETER :: KCCMIN = 0.223, KCCMAX = 0.999 ! MOMENT RATIO CHECK
131 REAL, PRIVATE, PARAMETER :: KCRMIN = 0.223, KCRMAX = 0.999 !
132 REAL, PRIVATE, PARAMETER :: KCIMIN = 0.556, KCIMAX = 0.999 ! KC = 0.999, AFAMAX = 2996
133 REAL, PRIVATE, PARAMETER :: KCSMIN = 0.223, KCSMAX = 0.999 ! KC = 0.995, AFAMAX = 596
134 REAL, PRIVATE, PARAMETER :: KCGMIN = 0.223, KCGMAX = 0.999 ! KC = 0.99, AFAMAX = 296
135 REAL, PRIVATE, PARAMETER :: KCHMIN = 0.223, KCHMAX = 0.999 ! KC = 0.95, AFAMAX = 56
136 REAL, PRIVATE, PARAMETER :: AFAMAX = 3.E4, AFAMIN = 0. ! SPECTRAL INDEX CHECK
137 REAL, PRIVATE, PARAMETER :: AFU = 3.125E-1, BFU = 1.0552E-3 ! CL04 FALL SPEED ADJUSTMENT
138 REAL, PRIVATE, PARAMETER :: CFU = -2.4023
139 REAL, PRIVATE, PARAMETER :: DCMIN = 1.E-7, DCMAX = 1.E-4 ! DIAMETER CHECK
140 REAL, PRIVATE, PARAMETER :: DIMIN = 1.E-6, DIMAX = 5.E-3 !
141 REAL, PRIVATE, PARAMETER :: DRMIN = 3.E-5, DRMAX = 6.E-3 !
142 REAL, PRIVATE, PARAMETER :: DSMIN = 2.E-5, DSMAX = 1.E-2 !
143 REAL, PRIVATE, PARAMETER :: DGMIN = 5.E-5, DGMAX = 2.E-2 !
144 REAL, PRIVATE, PARAMETER :: DHMIN = 1.E-3, DHMAX = 4.E-2 !
145 REAL, PRIVATE, PARAMETER :: RCMIN = DCMIN/2., RCMAX = DCMAX/2. ! RADIUS CHECK
146 REAL, PRIVATE, PARAMETER :: RRMIN = DRMIN/2., RRMAX = DRMAX/2. !
147 REAL, PRIVATE, PARAMETER :: DI0 = 6.E-6, DCR = 100.E-6 ! ISOMETRIC LIMIT FOR PI; THRESHOLD FOR RAINDROPS
148 REAL, PRIVATE, PARAMETER :: MI0 = AMI0*DI0**BMI0 ! INITIAL PI MASS
149 REAL, PRIVATE, PARAMETER :: SIG1 = -6.2685, SIG2 = -2.7312E-1 ! CL04 CLOUD DROPLETS SPECTRUM
150 REAL, PRIVATE, PARAMETER :: SIG3 = 2.2606E-1, MNR1 = -2.2920 !
151 REAL, PRIVATE, PARAMETER :: MNR2 = -3.5158E-1, MNR3 = 3.4708E-1 !
152 REAL, PRIVATE, PARAMETER :: EFC1 = -1.2560, EFC2 = -1.7904E-02 ! CL04 CLOUD DROPLETS EFFECTIVE RADIUS
153 REAL, PRIVATE, PARAMETER :: EFC3 = 8.5536E-01, EFR1 = -9.9216E-02 ! CL04 RAINDROPS EFFECTIVE RADIUS
154 REAL, PRIVATE, PARAMETER :: EFR2 = 2.9490E-02, EFR3 = 9.9238E-01 !
155 REAL, DIMENSION(0:120) :: ITBLE ! DEPOSITION GROWTH COEFFICIENTS
156 DATA ITBLE /1.000000,0.979490,0.959401,0.939723,0.920450, &
157 0.899498,0.879023,0.857038,0.833681,0.810961, &
158 0.783430,0.755092,0.703072,0.537032,0.467735, &
159 0.524807,0.630957,0.812831,1.096478,1.479108, &
160 1.905461,2.089296,2.290868,2.398833,2.454709, &
161 2.426610,2.371374,2.290868,2.137962,1.995262, &
162 1.862087,1.737801,1.621810,1.513561,1.396368, &
163 1.288250,1.188502,1.096478,1.000000,0.922571, &
164 0.851138,0.785236,0.724436,0.668344,0.616595, &
165 0.575440,0.537032,0.501187,0.467735,0.436516, &
166 0.407380,0.380189,0.354813,0.331131,0.316228, &
167 0.301995,0.291743,0.285102,0.281838,0.278612, &
168 0.275423,0.278612,0.281838,0.285102,0.291743, &
169 0.298538,0.309030,0.319890,0.331131,0.346737, &
170 0.367282,0.393550,0.426580,0.457088,0.489779, &
171 0.524807,0.562341,0.609537,0.660693,0.716143, &
172 0.785236,0.860994,0.954993,1.047129,1.148154, &
173 1.258925,1.380384,1.496236,1.603245,1.698244, &
174 1.778279,1.840772,1.883649,1.905461,1.905461, &
175 1.883649,1.862087,1.840772,1.798871,1.737801, &
176 1.698244,1.640590,1.584893,1.548817,1.513561, &
177 1.475707,1.452112,1.428894,1.412538,1.393157, &
178 1.377209,1.361445,1.348963,1.336596,1.327394, &
179 1.318257,1.309182,1.303167,1.294196,1.288250,1.279381/
180 REAL, DIMENSION(0:167) :: IECC ! JW99 RIMING COLLECTION EFFICIENCY COLUMNS
181 DATA IECC /0.00,0.03,0.29,0.25,0.00,0.00,0.00,0.00,0.00,0.00, &
182 0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00, &
183 0.00,0.00,0.10,0.42,0.50,0.47,0.21,0.00,0.00,0.00, &
184 0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00, &
185 0.00,0.00,0.00,0.15,0.49,0.56,0.55,0.46,0.10,0.00, &
186 0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00, &
187 0.00,0.00,0.00,0.00,0.20,0.52,0.61,0.62,0.59,0.49, &
188 0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00, &
189 0.00,0.00,0.00,0.00,0.00,0.25,0.62,0.72,0.75,0.74, &
190 0.71,0.68,0.57,0.00,0.00,0.00,0.00,0.00,0.00,0.00, &
191 0.00,0.00,0.00,0.00,0.00,0.00,0.30,0.70,0.80,0.84, &
192 0.85,0.85,0.84,0.83,0.81,0.77,0.69,0.10,0.00,0.00, &
193 0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.35,0.75,0.85, &
194 0.89,0.91,0.92,0.92,0.91,0.90,0.89,0.87,0.85,0.82, &
195 0.71,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.40,0.80, &
196 0.89,0.93,0.94,0.95,0.95,0.95,0.95,0.95,0.95,0.94, &
197 0.93,0.92,0.91,0.88,0.80,0.15,0.00,0.00/
198 REAL, DIMENSION(0:167) :: IEPC ! JW99 RIMING COLLECTION EFFICIENCY PLATES
199 DATA IEPC /0.00,0.00,0.13,0.41,0.00,0.00,0.00,0.00,0.00,0.00, &
200 0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00, &
201 0.00,0.00,0.00,0.25,0.54,0.56,0.39,0.00,0.00,0.00, &
202 0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00, &
203 0.00,0.00,0.00,0.08,0.57,0.75,0.83,0.85,0.86,0.84, &
204 0.78,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.00, &
205 0.00,0.00,0.00,0.00,0.10,0.65,0.80,0.87,0.90,0.91, &
206 0.91,0.91,0.88,0.78,0.00,0.00,0.00,0.00,0.00,0.00, &
207 0.00,0.00,0.00,0.00,0.00,0.12,0.67,0.81,0.88,0.91, &
208 0.92,0.93,0.93,0.92,0.91,0.89,0.81,0.00,0.00,0.00, &
209 0.00,0.00,0.00,0.00,0.00,0.00,0.15,0.68,0.82,0.89, &
210 0.91,0.93,0.94,0.94,0.95,0.95,0.95,0.94,0.91,0.83, &
211 0.00,0.00,0.00,0.00,0.00,0.00,0.00,0.18,0.69,0.82, &
212 0.89,0.92,0.94,0.95,0.95,0.96,0.96,0.96,0.96,0.95, &
213 0.94,0.91,0.80,0.00,0.00,0.00,0.00,0.00,0.22,0.70, &
214 0.83,0.90,0.93,0.95,0.96,0.97,0.98,0.98,0.98,0.98, &
215 0.97,0.96,0.94,0.92,0.84,0.00,0.00,0.00/
216 REAL, DIMENSION(0:44) :: AMS1 ! EM16, MASS-DIAMETER PARAMETERS SYNOPTIC CLOUDS
217 DATA AMS1 /2.728E+01,1.258E+00,6.452E-02,6.259E-03,8.658E-04, &
218 4.657E+01,1.193E+00,3.790E-02,2.688E-03,3.101E-04, &
219 2.260E+01,1.000E+00,5.059E-02,4.889E-03,6.826E-04, &
220 6.176E+00,6.002E-01,5.889E-02,8.892E-03,1.647E-03, &
221 2.982E+00,1.795E-01,1.261E-02,1.647E-03,3.128E-04, &
222 2.783E+00,2.179E-01,1.901E-02,2.825E-03,5.699E-04, &
223 1.630E+00,3.267E-01,6.223E-02,1.493E-02,3.902E-03, &
224 1.145E+01,3.346E-02,1.178E-04,7.701E-05,2.463E-05, &
225 6.606E+01,1.799E-03,1.178E-04,7.701E-05,2.463E-05/
226 REAL, DIMENSION(0:44) :: BMS1 ! SYNOPTIC CLOUDS
227 DATA BMS1 /2.792,2.455,2.085,1.748,1.411,2.846,2.449,2.015,1.618,&
228 1.221,2.773,2.429,2.053,1.710,1.367,2.642,2.371,2.073,&
229 1.802,1.530,2.556,2.254,1.923,1.621,1.320,2.549,2.276,&
230 1.977,1.704,1.431,2.495,2.322,2.133,1.960,1.787,2.686,&
231 2.064,1.382,1.382,1.382,2.863,1.732,1.382,1.382,1.382/
232 REAL, DIMENSION(0:44) :: AAS1 ! EM16, AREA-DIAMETER PARAMETERS SYNOPTIC CLOUDS
233 DATA AAS1 /1.782E+00,2.778E-01,4.794E-02,1.241E-02,4.069E-03, &
234 2.571E+00,2.635E-01,3.180E-02,6.517E-03,1.879E-03, &
235 1.910E+00,2.522E-01,3.759E-02,8.905E-03,2.787E-03, &
236 6.238E-01,1.697E-01,4.686E-02,1.662E-02,6.761E-03, &
237 5.604E-01,9.194E-02,1.726E-02,5.030E-03,1.927E-03, &
238 2.802E-01,8.345E-02,2.602E-02,1.042E-02,4.854E-03, &
239 1.269E-01,1.106E-01,8.453E-02,5.913E-02,3.763E-02, &
240 3.569E-01,2.314E-02,1.664E-03,1.397E-03,8.521E-04, &
241 6.339E-01,5.656E-03,1.664E-03,1.397E-03,8.521E-04/
242 REAL, DIMENSION(0:44) :: BAS1 ! SYNOPTIC CLOUDS
243 DATA BAS1 /2.133,1.938,1.725,1.531,1.337,2.170,1.932,1.671,1.432,&
244 1.194,2.140,1.927,1.693,1.480,1.267,2.027,1.882,1.722,&
245 1.576,1.431,2.011,1.821,1.612,1.422,1.232,1.941,1.810,&
246 1.666,1.534,1.403,1.861,1.842,1.821,1.801,1.782,1.960,&
247 1.669,1.350,1.350,1.350,2.018,1.509,1.350,1.350,1.350/
248 !----------------- FOR AEROSOL PARAMETER -------------------------------
249 REAL, SAVE :: DNC0,DNC1,DNC2,DNC3
250 REAL, SAVE, DIMENSION(NAER) :: SENS,ASH,CMAS,DNAS,AVAN,BETA1,RXMIN
251 REAL, SAVE, DIMENSION(NCCN,NAER) :: ZCCN,CNMOD,CNSTD,WMAS,RFACT
253 CONTAINS
254 !======================================================================
255 SUBROUTINE NTU_INIT(PHB,PH,P,PB,ALT,QV,QDCN,QTCN,QCCN,QRCN,QNIN, &
256 XLAND,CCNTY,RESTART,IDS,IDE,JDS,JDE,KDS,KDE,IMS,IME, &
257 JMS,JME,KMS,KME,ITS,ITE,JTS,JTE,KTS,KTE)
258 !======================================================================
259 IMPLICIT NONE
260 LOGICAL, INTENT(IN) :: RESTART
261 INTEGER, INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE,IMS,IME,JMS,JME, &
262 KMS,KME,ITS,ITE,JTS,JTE,KTS,KTE,CCNTY
263 REAL, INTENT(IN), DIMENSION(IMS:IME,JMS:JME) :: XLAND ! 1:land ; 2:ocean
264 REAL, INTENT(IN), DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: PHB,PH,P,&
265 PB,ALT,QV
266 REAL, INTENT(INOUT), DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: QDCN, &
267 QTCN,QCCN,QRCN,QNIN
268 REAL, DIMENSION(ITS:ITE,KTS:KTE,JTS:JTE) :: DZ,RHO,DZ8W,P_PHY
269 REAL, DIMENSION(ITS:ITE,KTS:KTE,JTS:JTE,NAERT) :: QAERO
270 INTEGER :: I,J,K,NK,ITF,JTF
272 ITF = MIN(ITE,IDE-1)
273 JTF = MIN(JTE,JDE-1)
274 CALL AERO_CONST(CCNTY)
275 DO J = JTS,JTF
276 DO K = KTS,KTE
277 DO I = ITS,ITF
278 DZ(I,K,J) = (PHB(I,K,J)+PH(I,K,J))/G
279 ENDDO
280 ENDDO
281 ENDDO
282 DO J = JTS,JTF
283 DO K = KTS,KTE-1
284 DO I = ITS,ITF
285 NK = KTE-K
286 DZ8W(I,K,J) = DZ(I,NK+1,J)-DZ(I,NK,J)
287 RHO(I,K,J) = 1./ALT(I,NK,J)*(1.+QV(I,NK,J))
288 P_PHY(I,K,J) = P(I,NK,J)+PB(I,NK,J)
289 QAERO(I,K,J,1) = QDCN(I,NK,J)
290 QAERO(I,K,J,2) = QTCN(I,NK,J)
291 QAERO(I,K,J,3) = QCCN(I,NK,J)
292 QAERO(I,K,J,4) = QRCN(I,NK,J)
293 QAERO(I,K,J,5) = QNIN(I,NK,J)
294 ENDDO
295 ENDDO
296 ENDDO
297 IF (.NOT.RESTART) THEN
298 CALL INIT_AEROSOL(P_PHY,RHO,DZ8W,XLAND,QAERO,IDS,IDE,JDS,JDE, &
299 KDS,KDE,IMS,IME,JMS,JME,KMS,KME,ITS,ITE,JTS,JTE,KTS,KTE)
300 ENDIF
301 DO J = JTS,JTF
302 DO K = KTS,KTE-1
303 DO I = ITS,ITF
304 NK = KTE-K
305 QDCN(I,NK,J) = QAERO(I,K,J,1)
306 QTCN(I,NK,J) = QAERO(I,K,J,2)
307 QCCN(I,NK,J) = QAERO(I,K,J,3)
308 QRCN(I,NK,J) = QAERO(I,K,J,4)
309 QNIN(I,NK,J) = QAERO(I,K,J,5)
310 ENDDO
311 ENDDO
312 ENDDO
314 END SUBROUTINE NTU_INIT
315 !======================================================================
316 !
317 !======================================================================
318 SUBROUTINE FIND_RC0(XAFRC,CMODE,CSTDV,WMAS,RC,TBLXA,TBLRC)
319 !======================================================================
320 IMPLICIT NONE
321 INTEGER, PARAMETER :: ITERMAX = 50
322 INTEGER :: IM,I
323 !----------------- AEROSOL TRI-MODAL SIZE DISTRIBUTION ----------------
324 REAL :: RC ! cut-off radius [m]
325 REAL, DIMENSION(NCCN) :: WMAS, &! mass weighting for each mode
326 CMODE, &! modal value (ln R) of each mode [m]
327 CSTDV ! standard distribution (in logarithm) of the mode
328 REAL, PARAMETER :: RC_MAX = 99., RC_MIN = 1.E-9, XTOR = 1.E-5
329 DOUBLE PRECISION, DIMENSION(NCCN) :: DWMAS,DMODE,DSTDV
330 !----------------- GET THE FIRST GUESS OF RC ---------------------------
331 DOUBLE PRECISION :: DRC,UL,X1MAFRC,Y0,Y,DY,DX,DERF,DLOG,DEXP, &
332 DSQRT,XAFRC ! ratio of dry/total aerosol mass
333 DOUBLE PRECISION, DIMENSION(NTBXA) :: TBLRC,TBLXA ! table of dry aerosol mass fraction
335 DO IM = 1,NCCN
336 DWMAS(IM) = DBLE(WMAS(IM))
337 DSTDV(IM) = DBLE(CSTDV(IM))
338 DMODE(IM) = DLOG(DBLE(CMODE(IM)))+DBLE(3.*CSTDV(IM)*CSTDV(IM)) ! for mass, the 3rd momentum DBLE(CMODE (IM))+
339 ENDDO
340 UL = (1.-DERF(5.D+0/DSQRT(2.D+0)))*0.5 ! after 5 sigma, x1mfrc will < 2.86E-7
341 X1MAFRC = 1.D+0-XAFRC
342 IF (XAFRC.LT.1.E-10) THEN
343 RC = RC_MIN
344 RETURN
345 ENDIF
346 IF (X1MAFRC.LT.UL) THEN
347 RC = RC_MAX
348 RETURN
349 ENDIF
350 DRC = GUESS_RC(XAFRC,TBLXA,TBLRC) ! cut-off radius [m]
351 Y0 = YEQU(DRC,XAFRC,DWMAS,DMODE,DSTDV)
352 DO I = 1,ITERMAX
353 Y = Y0
354 DY = DYEQU(DRC,DWMAS,DMODE,DSTDV)
355 IF (DY.LE.1.E-50) THEN
356 PRINT *,'IN FIND_RC0.F DY IS',DY
357 PRINT *,I,DX,Y,DY,DEXP(DRC),DRC,XAFRC,X1MAFRC,DMODE,DSTDV, &
358 CMODE,CSTDV
359 STOP
360 ENDIF
361 DX = -Y/DY
362 IF (DABS(DX).GT.3.D+0) DX = DX/(DABS(DX/0.4))
363 IF (DABS(DX).LT.XTOR) THEN
364 RC = REAL(DEXP(DRC+DX))
365 RC = MIN(RC_MAX,MAX(RC,RC_MIN))
366 RETURN
367 ENDIF
368 Y0 = YEQU(DRC+DX,XAFRC,DWMAS,DMODE,DSTDV)
369 IF (Y*Y0.LT.0.) THEN
370 DX = DX*5.D-1
371 Y0 = YEQU(DRC+DX,XAFRC,DWMAS,DMODE,DSTDV)
372 ENDIF
373 DRC = DRC+DX
374 ENDDO
375 RC = REAL(DEXP(DRC))
377 END SUBROUTINE FIND_RC0
378 !======================================================================
379 !
380 !======================================================================
381 FUNCTION GUESS_RC(XAFRC,TBLXA,TBLRC)
382 !======================================================================
383 DOUBLE PRECISION :: GUESS_RC,XAFRC,TBLXA(NTBXA),TBLRC(NTBXA)
384 INTEGER :: IBNG,IEND,I
386 IF (XAFRC.GE.TBLXA(NTBXA)) THEN
387 GUESS_RC = TBLRC(NTBXA)
388 RETURN
389 ELSEIF (XAFRC.LT.TBLXA(1)) THEN
390 GUESS_RC = TBLRC(1)
391 RETURN
392 ENDIF
393 IF (XAFRC.LT.TBLXA(NTBXA/4)) THEN
394 IBNG = 1
395 IEND = NTBXA/4-1
396 ELSEIF (XAFRC.LT.TBLXA(NTBXA*2/4)) THEN
397 IBNG = NTBXA/4
398 IEND = NTBXA*2/4-1
399 ELSEIF (XAFRC.LT.TBLXA(NTBXA*3/4)) THEN
400 IBNG = NTBXA*2/4
401 IEND = NTBXA*3/4-1
402 ELSE
403 IBNG = NTBXA*3/4
404 IEND = NTBXA-1
405 ENDIF
406 DO I = IEND,IBNG,-1
407 IF (XAFRC.GE.TBLXA(I)) GOTO 111
408 ENDDO
409 111 GUESS_RC = TBLRC(I)
411 END FUNCTION GUESS_RC
412 !======================================================================
413 !
414 !======================================================================
415 FUNCTION YEQU(X,XAFRC,WEGHT,XLBAR,SIGMA)
416 !======================================================================
417 INTEGER :: I
418 DOUBLE PRECISION :: YEQU,DX,XAFRC,X,DSQRT2,DSQRT
419 DOUBLE PRECISION, DIMENSION(NCCN) :: WEGHT,XLBAR,SIGMA
421 DSQRT2 = DSQRT(2.D+0)
422 YEQU = 0.D+0
423 DO I = 1,NCCN
424 DX = (X-XLBAR(I))/SIGMA(I)/DSQRT2
425 YEQU = YEQU+WEGHT(I)*PDF(DX)
426 ENDDO
427 YEQU = YEQU-XAFRC
429 END FUNCTION YEQU
430 !----------------------------------------------------------------------
431 FUNCTION DYEQU(X,WEGHT,XLBAR,SIGMA)
432 !======================================================================
433 INTEGER :: I
434 DOUBLE PRECISION :: DYEQU,X,DX,DSQRT2,DSQRT
435 DOUBLE PRECISION, DIMENSION(NCCN) :: WEGHT,XLBAR,SIGMA
437 DSQRT2 = DSQRT(2.D+0)
438 DYEQU = 0.D+0
439 DO I = 1,NCCN
440 DX = (X-XLBAR(I))/SIGMA(I)/DSQRT2
441 DYEQU = DYEQU+WEGHT(I)*DPDF(DX)/SIGMA(I)/DSQRT2
442 ENDDO
444 END FUNCTION DYEQU
445 !======================================================================
446 FUNCTION PDF(X)
447 DOUBLE PRECISION :: PDF,X,DERF
449 PDF = (1.D+0+DERF(X))*5.D-1
451 END FUNCTION PDF
452 !----------------------------------------------------------------------
453 FUNCTION DPDF(X)
454 DOUBLE PRECISION :: DPDF,X,DPI,DACOS,DEXP,DSQRT
456 DPI = DACOS(-1.D+0)
457 DPDF = DEXP(-X*X)/DSQRT(DPI)
459 END FUNCTION DPDF
460 !======================================================================
461 !
462 !======================================================================
463 REAL FUNCTION GAMMA(X) ! IMPLEMETED FROM MORRISON SCHEME
464 !======================================================================
465 IMPLICIT NONE
466 INTEGER :: I,N
467 LOGICAL :: PARITY
468 REAL :: CONV,EPS,FACT,HALF,ONE,RES,SUM,TWELVE,TWO,X,XBIG, &
469 XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
470 REAL, DIMENSION(7) :: C
471 REAL, DIMENSION(8) :: P
472 REAL, DIMENSION(8) :: Q
473 !----------------------------------------------------------------------
474 ! MATHEMATICAL CONSTANTS
475 !----------------------------------------------------------------------
476 DATA ONE,HALF,TWELVE,TWO,ZERO/1.0E0,0.5E0,12.0E0,2.0E0,0.0E0/
477 !----------------------------------------------------------------------
478 ! MACHINE DEPENDENT PARAMETERS
479 !----------------------------------------------------------------------
480 DATA XBIG,XMININ,EPS/35.040E0,1.18E-38,1.19E-7/,XINF/3.4E38/
481 !----------------------------------------------------------------------
482 ! NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX
483 ! APPROXIMATION OVER (1,2).
484 !----------------------------------------------------------------------
485 DATA P /-1.71618513886549492533811E0,2.47656508055759199108314E1,&
486 -3.79804256470945635097577E2,6.29331155312818442661052E2,&
487 8.66966202790413211295064E2,-3.14512729688483675254357E4,&
488 -3.61444134186911729807069E4,6.64561438202405440627855E4/
489 DATA Q /-3.08402300119738975254353E1,3.15350626979604161529144E2,&
490 -1.01515636749021914166146E3,-3.10777167157231109440444E3,&
491 2.25381184209801510330112E4,4.75584627752788110767815E3, &
492 -1.34659959864969306392456E5,-1.15132259675553483497211E5/
493 !----------------------------------------------------------------------
494 ! COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF).
495 !----------------------------------------------------------------------
496 DATA C /-1.910444077728E-3,8.4171387781295E-4, &
497 -5.952379913043012E-4,7.93650793500350248E-4, &
498 -2.777777777777681622553E-3,8.333333333333333331554247E-2,&
499 5.7083835261E-3/
500 !----------------------------------------------------------------------
501 ! STATEMENT FUNCTIONS FOR CONVERSION BETWEEN INTEGER AND FLOAT
502 !----------------------------------------------------------------------
503 CONV(I) = REAL(I)
504 PARITY = .FALSE.
505 FACT = ONE
506 N = 0
507 Y = X
508 IF (Y.LE.ZERO) THEN
509 !----------------------------------------------------------------------
510 ! ARGUMENT IS NEGATIVE
511 !----------------------------------------------------------------------
512 Y = -X
513 Y1 = AINT(Y)
514 RES = Y-Y1
515 IF (RES.NE.ZERO) THEN
516 IF (Y1.NE.AINT(Y1*HALF)*TWO) PARITY = .TRUE.
517 FACT = -PI/SIN(PI*RES)
518 Y = Y+ONE
519 ELSE
520 RES = XINF
521 GOTO 900
522 ENDIF
523 ENDIF
524 !----------------------------------------------------------------------
525 ! ARGUMENT IS POSITIVE
526 !----------------------------------------------------------------------
527 IF (Y.LT.EPS) THEN
528 !----------------------------------------------------------------------
529 ! ARGUMENT .LT. EPS
530 !----------------------------------------------------------------------
531 IF (Y.GE.XMININ) THEN
532 RES = ONE/Y
533 ELSE
534 RES = XINF
535 GOTO 900
536 ENDIF
537 ELSEIF (Y.LT.TWELVE) THEN
538 Y1 = Y
539 IF (Y.LT.ONE) THEN
540 !----------------------------------------------------------------------
541 ! 0.0 .LT. ARGUMENT .LT. 1.0
542 !----------------------------------------------------------------------
543 Z = Y
544 Y = Y+ONE
545 ELSE
546 !----------------------------------------------------------------------
547 ! 1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY
548 !----------------------------------------------------------------------
549 N = INT(Y)-1
550 Y = Y-CONV(N)
551 Z = Y-ONE
552 ENDIF
553 !----------------------------------------------------------------------
554 ! EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0
555 !----------------------------------------------------------------------
556 XNUM = ZERO
557 XDEN = ONE
558 DO I = 1,8
559 XNUM = (XNUM+P(I))*Z
560 XDEN = XDEN*Z+Q(I)
561 END DO
562 RES = XNUM/XDEN+ONE
563 IF (Y1.LT.Y) THEN
564 !----------------------------------------------------------------------
565 ! ADJUST RESULT FOR CASE 0.0 .LT. ARGUMENT .LT. 1.0
566 !----------------------------------------------------------------------
567 RES = RES/Y1
568 ELSEIF (Y1.GT.Y) THEN
569 !----------------------------------------------------------------------
570 ! ADJUST RESULT FOR CASE 2.0 .LT. ARGUMENT .LT. 12.0
571 !----------------------------------------------------------------------
572 DO I = 1,N
573 RES = RES*Y
574 Y = Y+ONE
575 END DO
576 ENDIF
577 ELSE
578 !----------------------------------------------------------------------
579 ! EVALUATE FOR ARGUMENT .GE. 12.0,
580 !----------------------------------------------------------------------
581 IF (Y.LE.XBIG) THEN
582 YSQ = Y*Y
583 SUM = C(7)
584 DO I = 1,6
585 SUM = SUM/YSQ+C(I)
586 END DO
587 SUM = SUM/Y-Y+SQRTPI
588 SUM = SUM+(Y-HALF)*LOG(Y)
589 RES = EXP(SUM)
590 ELSE
591 RES = XINF
592 GOTO 900
593 ENDIF
594 ENDIF
595 !----------------------------------------------------------------------
596 ! FINAL ADJUSTMENTS AND RETURN
597 !----------------------------------------------------------------------
598 IF (PARITY) RES = -RES
599 IF (FACT.NE.ONE) RES = FACT/RES
600 900 GAMMA = RES
601 RETURN
603 END FUNCTION GAMMA
604 !======================================================================
606 !======================================================================
607 REAL FUNCTION POLYSVP(T,TYPE) ! IMPLEMETED FROM MORRISON SCHEME
608 !======================================================================
609 ! COMPUTE SATURATION VAPOR PRESSURE POLYSVP RETURNED IN UNITS OF PA. T IS INPUT IN UNITS OF K.
610 ! TYPE REFERS TO SATURATION WITH RESPECT TO LIQUID (0) OR ICE (1)
611 ! REPLACE GOFF-GRATCH WITH FASTER FORMULATION FROM FLATAU ET AL. 1992, TABLE 4 (RIGHT-HAND COLUMN)
612 IMPLICIT NONE
613 REAL :: DUM,T,DT
614 INTEGER :: TYPE
615 ! ice
616 REAL :: a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i
617 DATA a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i /6.11147274,0.503160820,&
618 0.188439774E-1,0.420895665E-3,0.615021634E-5,0.602588177E-7,&
619 0.385852041E-9,0.146898966E-11,0.252751365E-14/
620 ! liquid
621 REAL :: a0,a1,a2,a3,a4,a5,a6,a7,a8
622 DATA a0,a1,a2,a3,a4,a5,a6,a7,a8 /6.11239921,0.443987641, &
623 0.142986287E-1,0.264847430E-3,0.302950461E-5,0.206739458E-7,&
624 0.640689451E-10,-0.952447341E-13,-0.976195544E-15/
625 IF (TYPE.EQ.1) THEN ! ICE
626 DT = MAX(-80.,T-273.16)
627 POLYSVP = a0i+DT*(a1i+DT*(a2i+DT*(a3i+DT*(a4i+DT* &
628 (a5i+DT*(a6i+DT*(a7i+a8i*DT)))))))
629 POLYSVP = POLYSVP*100.
630 ENDIF
631 IF (TYPE.EQ.0) THEN ! LIQUID
632 DT = MAX(-80.,T-273.16)
633 POLYSVP = a0+DT*(a1+DT*(a2+DT*(a3+DT*(a4+DT*(a5+DT* &
634 (a6+DT*(a7+a8*DT)))))))
635 POLYSVP = POLYSVP*100.
636 ENDIF
638 END FUNCTION POLYSVP
639 !======================================================================
640 !
641 !======================================================================
642 REAL FUNCTION GAMLN(XX) ! Referred to MY2 scheme
643 !======================================================================
644 ! Returns value of ln(GAMMA(XX)) for XX>0 (modified from "Numerical Recipes")
645 IMPLICIT NONE
646 REAL, INTENT(IN) :: XX
647 INTEGER :: J
648 DOUBLE PRECISION :: ser,stp,TMP,X,y,cof(6)
649 SAVE cof,stp
650 DATA cof,stp /76.18009172947146d0,-86.50532032941677d0, &
651 24.01409824083091d0,-1.231739572450155d0, &
652 .1208650973866179d-2,-.5395239384953d-5, &
653 2.5066282746310005d0/
655 X = DBLE(XX)
656 y = X
657 TMP = X+5.5D0
658 TMP = (X+0.5D0)*LOG(TMP)-TMP
659 ser = 1.000000000190015d0
660 DO J = 1,6 !original
661 y = y+1.D0
662 ser = ser+cof(J)/y
663 ENDDO
664 #if (DWORDSIZE == 8 && RWORDSIZE == 8)
665 GAMLN = TMP+LOG(stp*ser/X)
666 #elif (DWORDSIZE == 8 && RWORDSIZE == 4)
667 GAMLN = SNGL(TMP+LOG(stp*ser/X))
668 #else
669 ! This is a temporary hack assuming double precision is 8 bytes.
670 #endif
672 END FUNCTION GAMLN
673 !======================================================================
674 !
675 !======================================================================
676 REAL FUNCTION GAMIN(P,XMAX)
677 !======================================================================
678 ! The incomplete gamma function below the limit of P = AFA+1 and XMAX = DI0*LAMDA
679 REAL :: P,XMAX
681 GAMIN = GAMMP(P,XMAX)*EXP(GAMLN(P))
683 END FUNCTION GAMIN
684 !=======================================================================
685 REAL FUNCTION GAMMP(A,X)
686 !=======================================================================
687 ! The fraction of distribution below the limit of A = AFA+1 and X = Db*LAMDA
688 IMPLICIT NONE
689 REAL :: A,X,GAMMCF,GAMSER,GLN
691 IF (X.LT.0..OR.A.LE.0.) &
692 CALL wrf_error_fatal('warning : bad arguments in gammq')
693 IF (X.LT.A+1.) THEN
694 CALL GSER(GAMSER,A,X,GLN)
695 GAMMP = GAMSER
696 ELSE
697 CALL CFG(GAMMCF,A,X,GLN)
698 GAMMP = 1.-GAMMCF
699 ENDIF
700 RETURN
702 END FUNCTION GAMMP
703 !======================================================================
704 SUBROUTINE GSER(GAMSER,A,X,GLN) ! Referred to MY2 scheme
705 !======================================================================
706 ! USES GAMLN, Returns the incomplete gamma function P(A,X) evaluated by its series
707 ! representation as GAMSER. Also returns GAMMA(A) as GLN.
708 IMPLICIT NONE
709 INTEGER :: N
710 REAL :: A,GAMSER,GLN,X,AP,de1,summ
711 INTEGER, PARAMETER :: ITMAX = 500
712 REAL, PARAMETER :: EPS = 3.E-7
714 GLN = GAMLN(A)
715 IF (X.LE.0.) THEN
716 IF (X.LT.0.) CALL wrf_error_fatal ( 'WARNING: X <0 in GSER' )
717 GAMSER = 0.
718 RETURN
719 ENDIF
720 AP = A
721 summ = 1./A
722 de1 = summ
723 DO N = 1,ITMAX
724 AP = AP+1.
725 de1 = de1*X/AP
726 summ = summ+de1
727 IF (ABS(de1).LT.ABS(summ)*EPS) GOTO 777
728 ENDDO
729 CALL wrf_error_fatal ('Warning : ITMAX too small in GSER')
730 777 GAMSER = summ*EXP(-X+A*LOG(X)-GLN)
732 RETURN
734 END SUBROUTINE GSER
735 !=======================================================================
736 SUBROUTINE CFG(GAMMCF,A,X,GLN) ! Referred to MY2 scheme
737 !=======================================================================
738 ! USES GAMLN, Returns the incomplete gamma function (Q(A,X) evaluated by tis continued fraction
739 ! representation as GAMMCF. Also returns ln(GAMMA(A)) as GLN. ITMAX is the maximum allowed number of iterations;
740 ! EPS is the relative accuracy; FPMIN is a number near the smallest representable floating-point number.
741 IMPLICIT NONE
742 INTEGER :: I
743 REAL :: A,GAMMCF,GLN,X,AN,b,c,d,de1,h
744 INTEGER, PARAMETER :: ITMAX = 500
745 REAL, PARAMETER :: EPS = 3.E-7
746 REAL, PARAMETER :: fpmin = 1.E-30
748 GLN = GAMLN(A)
749 b = X+1.-A
750 c = 1./fpmin
751 d = 1./b
752 h = d
753 DO I = 1,ITMAX
754 AN = -I*(I-A)
755 b = b+2.
756 d = AN*d+b
757 IF (ABS(d).LT.fpmin) d = fpmin
758 c = b+AN/c
759 IF (ABS(c).LT.fpmin) c = fpmin
760 d = 1./d
761 de1 = d*c
762 h = h*de1
763 IF (ABS(de1-1.).LT.EPS) GOTO 888
764 ENDDO
765 CALL wrf_error_fatal ('Warning : ITMAX too small in gcf')
766 888 GAMMCF = EXP(-X+A*LOG(X)-GLN)*h
767 RETURN
769 END SUBROUTINE CFG
770 !=======================================================================
771 !
772 !======================================================================
773 SUBROUTINE SOLVE_AFAC(TK1D,QC1D,NC1D,LAMC,MVDC,AFAC)
774 !======================================================================
775 IMPLICIT NONE
776 REAL :: TK1D,QC1D,NC1D,LAMC,GC1,MVDC,AFAC,LAMCMIN,LAMCMAX,C3M1D, &
777 SIGC,MNRC,MVRC,EFRC,KDX,LTK,LQC
779 IF (NC1D.LT.NSMALL) THEN
780 LTK = LOG(TK1D)
781 LQC = -1.*LOG(QC1D)
782 NC1D = EXP(DNC0+DNC1*LTK+DNC2*LTK**2.+DNC3*LTK**3.-0.25*LQC)
783 ENDIF
784 IF (QC1D.GE.QSMAL1.AND.NC1D.LT.NSMAL1) THEN
785 LTK = LOG(TK1D)
786 LQC = -1.*LOG(QC1D)
787 NC1D = EXP(DNC0+DNC1*LTK+DNC2*LTK**2.+DNC3*LTK**3.-0.25*LQC)
788 ENDIF
789 C3M1D = QC1D*V2M3/RHOW
790 IF (AFAC_3M.EQ.0) THEN
791 AFAC = AFAC0
792 ELSEIF (AFAC_3M.EQ.1) THEN
793 MVRC = (QC1D/NC1D/C4PI3W)**THRD
794 MVRC = MIN(MAX(MVRC,RCMIN),RCMAX)
795 EFRC = EXP(EFC1+EFC2*LOG(NC1D)+EFC3*LOG(MVRC))
796 ! KDX = MIN(MAX(KCCMIN,C3M1D/(8.*EFRC**3.*NC1D)),KCCMAX)
797 KDX = MAX(KCCMIN,MIN(KCCMAX,(MVRC/EFRC)**3.))
798 AFAC = (6.*KDX-3.+SQRT(8.*KDX+1.))/(2.-2.*KDX)
799 AFAC = MIN(MAX(AFAC,AFAMIN),AFAMAX)
800 ELSEIF (AFAC_3M.EQ.2) THEN
801 SIGC = EXP(SIG1+SIG2*LOG(NC1D)+SIG3*LOG(QC1D))
802 MNRC = EXP(MNR1+MNR2*LOG(NC1D)+MNR3*LOG(QC1D))
803 AFAC = MIN(MAX(SIGC/MNRC,AFAMIN),AFAMAX)
804 ENDIF
805 GC1 = GAMLN(AFAC+1.)
806 LAMC = (EXP(GAMLN(AFAC+4.)-GC1)*NC1D/C3M1D)**THRD
807 LAMCMIN = (EXP(GAMLN(AFAC+4.)-GC1))**THRD/DCMAX
808 LAMCMAX = (EXP(GAMLN(AFAC+4.)-GC1))**THRD/DCMIN
809 IF (LAMC.LT.LAMCMIN) THEN
810 LAMC = LAMCMIN
811 NC1D = C3M1D*EXP(GAMLN(AFAC+1.)-GAMLN(AFAC+4.)+3.*LOG(LAMC))
812 ELSEIF (LAMC.GT.LAMCMAX) THEN
813 LAMC = LAMCMAX
814 NC1D = C3M1D*EXP(GAMLN(AFAC+1.)-GAMLN(AFAC+4.)+3.*LOG(LAMC))
815 ENDIF
816 MVDC = (EXP(GAMLN(AFAC+4.)-GAMLN(AFAC+1.)))**THRD/LAMC
818 END SUBROUTINE SOLVE_AFAC
819 !======================================================================
820 !
821 !======================================================================
822 SUBROUTINE SOLVE_AFAR(TK1D,QR1D,NR1D,LAMR,MVDR,AFAR)
823 !======================================================================
824 IMPLICIT NONE
825 REAL :: TK1D,QR1D,NR1D,LAMR,GR1,MVDR,LAMRMIN,LAMRMAX,R3M1D,AFAR, &
826 BDR,MVRR,EFRR,KDX,LTK,LQR
828 IF (NR1D.LT.NSMALL) THEN
829 LTK = LOG(TK1D)
830 LQR = -1.*LOG(QR1D)
831 NR1D = EXP(-5793.7852+3191.1171*LTK-582.73279*LTK**2.+ &
832 35.346854*LTK**3.-0.25*LQR)
833 ENDIF
834 R3M1D = QR1D*V2M3/RHOW
835 IF (AFAR_3M.EQ.0) THEN
836 AFAR = AFAR0
837 ELSEIF (AFAR_3M.EQ.1) THEN
838 MVRR = MIN(RRMAX,MAX(RRMIN,(QR1D/NR1D/C4PI3W)**THRD))
839 EFRR = EXP(EFR1+EFR2*LOG(NR1D)+EFR3*LOG(MVRR))
840 ! KDX = MIN(MAX(KCRMIN,R3M1D/(8.*EFRR**3.*NR1D)),KCRMAX)
841 KDX = MAX(KCRMIN,MIN(KCRMAX,(MVRR/EFRR)**3.))
842 AFAR = (6.*KDX-3.+SQRT(8.*KDX+1.))/(2.-2.*KDX)
843 AFAR = MIN(MAX(AFAR,AFAMIN),AFAMAX)
844 ELSEIF (AFAR_3M.EQ.2) THEN
845 BDR = MIN(MAX((R3M1D/NR1D)**THRD,DRMIN),DRMAX)
846 AFAR = MAX(AFAMIN,19.*TANH(0.6*(1.E3*BDR-1.8))+17.)
847 ENDIF
848 GR1 = GAMLN(AFAR+1.)
849 LAMR = (EXP(GAMLN(AFAR+4.)-GR1)*NR1D/R3M1D)**THRD
850 LAMRMIN = (EXP(GAMLN(AFAR+4.)-GR1))**THRD/DRMAX
851 LAMRMAX = (EXP(GAMLN(AFAR+4.)-GR1))**THRD/DRMIN
852 IF (LAMR.LT.LAMRMIN) THEN
853 LAMR = LAMRMIN
854 NR1D = R3M1D*EXP(GAMLN(AFAR+1.)-GAMLN(AFAR+4.)+3.*LOG(LAMR))
855 ELSEIF (LAMR.GT.LAMRMAX) THEN
856 LAMR = LAMRMAX
857 NR1D = R3M1D*EXP(GAMLN(AFAR+1.)-GAMLN(AFAR+4.)+3.*LOG(LAMR))
858 ENDIF
859 MVDR = (EXP(GAMLN(AFAR+4.)-GAMLN(AFAR+1.)))**THRD/LAMR
861 END SUBROUTINE SOLVE_AFAR
862 !======================================================================
864 !======================================================================
865 SUBROUTINE SOLVE_AFAI(TK1D,P1D,RHO,QV1D,QI1D,NI1D,VI1D,FI1D, &
866 I2M1D,I3M1D,ADAGR,ZETA,LAMI,AFAI,MVDI,RHOI,AMI,BMI, &
867 AVI,BVI,BEST)
868 !======================================================================
869 IMPLICIT NONE
870 INTEGER :: HID
871 REAL :: TK1D,P1D,RHO,QV1D,QI1D,NI1D,VI1D,FI1D,I2M1D,I3M1D,ADAGR, &
872 ZETA,RHOI,LAMI,AFAI,AMI,BMI,AVI,BVI,MVDI,GI1,TC1D,ESW, &
873 ESI,QVSI,INHGR,I3M0,BEST0,LAMIMIN,LAMIMAX,IPF,IPG,KDX, &
874 ZETA2,ZETA4,KINV,AAI,BAI,IBA1,C1X2,VTA1,VTB1,IPH2,IPG2, &
875 AVIA0,BEST,BDI,FDI,LTK,LQI,MDI
877 IF (ICE_RHOI.EQ.0) THEN
878 RHOI = RHOI0
879 VI1D = 0.
880 ELSEIF (ICE_RHOI.EQ.1) THEN
881 IF (VI1D.LT.ISMALL) THEN
882 TC1D = TK1D-TK0C
883 HID = MAX(MIN(NINT(ABS(TC1D)/0.25),120),0)
884 ESW = MIN(0.99*P1D,POLYSVP(TK1D,0))
885 ESI = MIN(0.99*P1D,POLYSVP(TK1D,1))
886 IF (ESI.GT.ESW) ESI = ESW
887 QVSI = 0.622*ESI/(P1D-ESI)
888 INHGR = ITBLE(HID)
889 RHOI = RHOI0*EXP(-3.*MAX((QV1D-QVSI)-5.E-5,0.)/INHGR)
890 VI1D = QI1D/RHOI
891 ENDIF
892 RHOI = QI1D/VI1D
893 IF (RHOI.LT.RHOIMIN) THEN
894 RHOI = RHOIMIN
895 ELSEIF (RHOI.GT.RHOIMAX) THEN
896 RHOI = RHOIMAX
897 ENDIF
898 VI1D = QI1D/RHOI
899 ELSEIF (ICE_RHOI.EQ.2) THEN
900 RHOI = RHOI1
901 VI1D = 0.
902 ENDIF
903 IF (NI1D.LT.NSMALL) THEN
904 LTK = LOG(TK1D)
905 LQI = -1.*LOG(QI1D)
906 MDI = EXP(-3.2653646+2.0539073*LTK-0.25*LQI)/1.E3
907 NI1D = 1.E9*QI1D*V2M3/RHOI/MDI**3.
908 ENDIF
909 IF (QI1D.GE.QSMAL1.AND.NI1D.LT.NSMAL1) THEN
910 LTK = LOG(TK1D)
911 LQI = -1.*LOG(QI1D)
912 MDI = EXP(-3.2653646+2.0539073*LTK-0.25*LQI)/1.E3
913 NI1D = 1.E9*QI1D*V2M3/RHOI/MDI**3.
914 ENDIF
915 IF (I2M1D.GE.ASMALL.AND.I3M1D.GE.ISMALL) THEN
916 KDX = MAX(0.,I2M1D**3./(I3M1D**2.*NI1D))
917 IF (KDX.GT.KCIMAX) THEN
918 KDX = KCIMIN
919 I2M1D = (KDX*NI1D*I3M1D**2.)**THRD
920 ELSEIF (KDX.LT.KCIMIN) THEN
921 KDX = KCIMIN
922 I2M1D = (KDX*NI1D*I3M1D**2.)**THRD
923 ENDIF
924 AFAI = (6.*KDX-3.+SQRT(8.*KDX+1.))/(2.-2.*KDX)
925 AFAI = MIN(MAX(AFAI,AFAMIN),AFAMAX)
926 ! LAMI = SQRT(NI1D*(AFAI+2.)*(AFAI+1.)/I2M1D)
927 ! LAMI = (NI1D*(AFAI+1.)*(AFAI+2.)*(AFAI+3.)/I3M1D)**THRD
928 LAMI = (AFAI+3.)*I2M1D/I3M1D
929 LAMIMIN = (EXP(GAMLN(AFAI+4.)-GAMLN(AFAI+1.)))**THRD/DIMAX
930 LAMIMAX = (EXP(GAMLN(AFAI+4.)-GAMLN(AFAI+1.)))**THRD/DIMIN
931 IF (LAMI.LT.LAMIMIN) THEN
932 LAMI = LAMIMIN
933 NI1D = I3M1D*EXP(GAMLN(AFAI+1.)-GAMLN(AFAI+4.)+3.*LOG(LAMI))
934 ELSEIF (LAMI.GT.LAMIMAX) THEN
935 LAMI = LAMIMAX
936 NI1D = I3M1D*EXP(GAMLN(AFAI+1.)-GAMLN(AFAI+4.)+3.*LOG(LAMI))
937 ENDIF
938 ELSEIF (I2M1D.LT.ASMALL.AND.I3M1D.GE.ISMALL) THEN
939 IF (AFAI_3M.EQ.0) THEN
940 AFAI = AFAI0
941 I2M1D = 0.
942 ELSEIF (AFAI_3M.EQ.1) THEN
943 AFAI = AFAI0
944 I2M1D = (KCIMIN*NI1D*I3M1D**2.)**THRD
945 ELSEIF (AFAI_3M.EQ.2) THEN
946 BDI = MIN(MAX((I3M1D/NI1D)**THRD*1.E3,DIMIN*1.E3),DIMAX*1.E3)
947 FDI = 0.074015986+0.79866676*BDI-0.0094468892*LOG(NI1D)+ &
948 0.38235092*BDI**2.+0.00029811542*LOG(NI1D)**2.+ &
949 0.019052614*BDI*LOG(NI1D)
950 KDX = MAX(KCIMIN,MIN(KCIMAX,(BDI/FDI)**3.))
951 AFAI = (6.*KDX-3.+SQRT(8.*KDX+1.))/(2.-2.*KDX)
952 AFAI = MIN(MAX(AFAI,AFAMIN),AFAMAX)
953 ! AFAI = MAX(AFAMIN,12.*TANH(0.7*(BDI-1.7))+11.)
954 I2M1D = 0.
955 ENDIF
956 LAMI = (EXP(GAMLN(AFAI+4.)-GAMLN(AFAI+1.))*NI1D/I3M1D)**THRD
957 LAMIMIN = (EXP(GAMLN(AFAI+4.)-GAMLN(AFAI+1.)))**THRD/DIMAX
958 LAMIMAX = (EXP(GAMLN(AFAI+4.)-GAMLN(AFAI+1.)))**THRD/DIMIN
959 IF (LAMI.LT.LAMIMIN) THEN
960 LAMI = LAMIMIN
961 NI1D = I3M1D*EXP(GAMLN(AFAI+1.)-GAMLN(AFAI+4.)+3.*LOG(LAMI))
962 ELSEIF (LAMI.GT.LAMIMAX) THEN
963 LAMI = LAMIMAX
964 NI1D = I3M1D*EXP(GAMLN(AFAI+1.)-GAMLN(AFAI+4.)+3.*LOG(LAMI))
965 ENDIF
966 ELSE
967 IF (AFAI_3M.EQ.0) THEN
968 AFAI = AFAI0
969 I2M1D = 0.
970 ELSE
971 BDI = (QI1D*V2M3/NI1D/RHOI)**THRD*1.E3
972 BDI = MAX(MIN(DIMAX*1.E3,BDI),DIMIN*1.E3)
973 FDI = 7.4015986E-2+7.9866676E-1*BDI-9.4468892E-3*LOG( &
974 NI1D)+3.8235092E-1*BDI**2.+2.9811542E-4*LOG(NI1D)** &
975 2.+1.9052614E-2*BDI*LOG(NI1D)
976 KDX = MAX(KCIMIN,MIN(KCIMAX,(BDI/FDI)**3.))
977 AFAI = (6.*KDX-3.+SQRT(8.*KDX+1.))/(2.-2.*KDX)
978 AFAI = MIN(MAX(AFAI,AFAMIN),AFAMAX)
979 ! AFAI = MAX(AFAMIN,12.*TANH(0.7*(BDI-1.7))+11.)
980 IF (AFAI_3M.EQ.1) THEN
981 KDX = (AFAI**2.+3.*AFAI+2.)/(AFAI**2.+6.*AFAI+9.)
982 I2M1D = (KDX*NI1D*(QI1D*V2M3/RHOI)**2.)**THRD
983 ELSEIF (AFAI_3M.EQ.2) THEN
984 I2M1D = 0.
985 ENDIF
986 ENDIF
987 GI1 = GAMLN(AFAI+1.)
988 LAMI = (EXP(GAMLN(AFAI+4.)-GI1)*PI*RHOI*NI1D/QI1D/6.)**THRD
989 LAMIMIN = (EXP(GAMLN(AFAI+4.)-GAMLN(AFAI+1.)))**THRD/DIMAX
990 LAMIMAX = (EXP(GAMLN(AFAI+4.)-GAMLN(AFAI+1.)))**THRD/DIMIN
991 IF (LAMI.LT.LAMIMIN) THEN
992 LAMI = LAMIMIN
993 NI1D = QI1D*V2M3/RHOI*EXP(GAMLN(AFAI+1.)-GAMLN(AFAI+4.)+ &
994 3.*LOG(LAMI))
995 ELSEIF (LAMI.GT.LAMIMAX) THEN
996 LAMI = LAMIMAX
997 NI1D = QI1D*V2M3/RHOI*EXP(GAMLN(AFAI+1.)-GAMLN(AFAI+4.)+ &
998 3.*LOG(LAMI))
999 ENDIF
1000 ENDIF
1001 MVDI = (EXP(GAMLN(AFAI+4.)-GAMLN(AFAI+1.)))**THRD/LAMI
1002 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
1003 I3M0 = NI1D*DI0**3.
1004 IF (MVDI.GT.(DI0+1.E-7)) THEN
1005 IF (ICE_SHAPE.EQ.0) THEN
1006 ZETA = 0.; ADAGR = 1.
1007 FI1D = I3M1D
1008 ELSEIF (ICE_SHAPE.EQ.1) THEN
1009 ZETA = LOG(FI1D/I3M1D)/LOG(I3M1D/I3M0)
1010 IF (ZETA.GT.0.4) THEN
1011 ZETA = 0.4
1012 FI1D = (I3M1D/I3M0)**ZETA*I3M1D
1013 ELSEIF (ZETA.LT.(-0.4)) THEN
1014 ZETA = -0.4
1015 FI1D = (I3M1D/I3M0)**ZETA*I3M1D
1016 ENDIF
1017 ADAGR = (1.+2.*ZETA)/(1.-ZETA)
1018 ENDIF
1019 ELSE
1020 FI1D = I3M1D
1021 ZETA = 0.; ADAGR = 1.
1022 ENDIF
1023 ELSE
1024 I3M1D = QI1D*V2M3/RHOI
1025 IF (ICE_SHAPE.EQ.0) THEN
1026 FI1D = I3M1D
1027 ZETA = 0.; ADAGR = 1.
1028 ELSEIF (ICE_SHAPE.EQ.1) THEN
1029 TC1D = TK1D-TK0C
1030 HID = MAX(MIN(NINT(ABS(TC1D)/0.25),120),0)
1031 ADAGR = MAX(MIN(ITBLE(HID),2.),0.5)**THRD
1032 ZETA = (ADAGR-1.)/(ADAGR+2.)
1033 I3M0 = NI1D*DI0**3.
1034 FI1D = (I3M1D/I3M0)**ZETA*I3M1D
1035 ENDIF
1036 ENDIF
1037 IF ((ADAGR-1.).GE.SLIMIT) THEN
1038 AMI = PI*RHOI*DI0**(2.-2./ADAGR)/6.
1039 BMI = 2./ADAGR+1.
1040 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
1041 AMI = PI*RHOI*DI0**(1.-ADAGR)/6.
1042 BMI = ADAGR+2.
1043 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
1044 AMI = PI*RHOI/6.
1045 BMI = BMI0
1046 ENDIF
1047 IF (ICE_VTI.EQ.0) THEN
1048 AVI = AVI0
1049 BVI = BVI0
1050 ELSEIF (ICE_VTI.EQ.1) THEN
1051 KINV = (1.72E-5*(393./(TK1D+120.))*(TK1D/TK0C)**1.5)/RHO
1052 BEST0 = 2.*G*NI1D/(KINV**2.)
1053 IF ((ADAGR-1.).GE.SLIMIT) THEN
1054 AAI = PI/4./DI0**ZETA
1055 BAI = 3.*(ADAGR+1.)/(ADAGR+2.)
1056 IPH2 = 2.*3.*ADAGR/(ADAGR+2.)
1057 ZETA4 = 4.*(ADAGR-1.)/(ADAGR+2.)
1058 IBA1 = BMI+IPH2-BAI
1059 BEST = BEST0*AMI*EXP(GAMLN(IBA1+AFAI+1.)-GAMLN(AFAI+1.)- &
1060 IBA1*LOG(LAMI))/(AAI*DI0**ZETA4)
1061 C1X2 = VTC1*BEST**5.E-1
1062 VTB1 = C1X2/(1.+C1X2)**5.E-1/((1.+C1X2)**5.E-1-1.)/2.- &
1063 VTA0*VTB0*BEST**VTB0/VTC2/(SQRT(1.+C1X2)-1.)**2.
1064 VTA1 = MAX((VTC2*((1.+C1X2)**5.E-1-1.)**2.-VTA0*BEST** &
1065 VTB0)/BEST**VTB1,0.)
1066 AVIA0 = VTA1*KINV**(1.-2.*VTB1)
1067 AVI = AVIA0*(2.*AMI*G/(AAI*DI0**ZETA4))**VTB1
1068 BVI = VTB1*(BMI+IPH2-BAI)-1.
1069 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
1070 ZETA2 = 2.*(ADAGR-1.)/(ADAGR+2.)
1071 AAI = PI*DI0**ZETA2/4.
1072 BAI = 2.*3./(ADAGR+2.)
1073 IPG2 = 2.*3./(ADAGR+2.)
1074 IBA1 = BMI+IPG2-BAI
1075 BEST = BEST0*AMI*DI0**ZETA2*EXP(GAMLN(IBA1+AFAI+1.)- &
1076 GAMLN(AFAI+1.)-IBA1*LOG(LAMI))/AAI
1077 C1X2 = VTC1*BEST**5.E-1
1078 VTB1 = C1X2/(1.+C1X2)**5.E-1/((1.+C1X2)**5.E-1-1.)/2.- &
1079 VTA0*VTB0*BEST**VTB0/VTC2/(SQRT(1.+C1X2)-1.)**2.
1080 VTA1 = MAX((VTC2*((1.+C1X2)**5.E-1-1.)**2.-VTA0*BEST** &
1081 VTB0)/BEST**VTB1,0.)
1082 AVIA0 = VTA1*KINV**(1.-2.*VTB1)
1083 AVI = AVIA0*(2.*AMI*G*DI0**ZETA2/AAI)**VTB1
1084 BVI = VTB1*(BMI+IPG2-BAI)-1.
1085 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
1086 AAI = PI/4.
1087 BAI = 2.
1088 IBA1 = BMI
1089 BEST = BEST0*AMI*EXP(GAMLN(IBA1+AFAI+1.)-GAMLN(AFAI+1.)- &
1090 IBA1*LOG(LAMI))/AAI
1091 C1X2 = VTC1*BEST**5.E-1
1092 VTB1 = C1X2/(1.+C1X2)**5.E-1/((1.+C1X2)**5.E-1-1.)/2.- &
1093 VTA0*VTB0*BEST**VTB0/VTC2/(SQRT(1.+C1X2)-1.)**2.
1094 VTA1 = MAX((VTC2*((1.+C1X2)**5.E-1-1.)**2.-VTA0*BEST** &
1095 VTB0)/BEST**VTB1,0.)
1096 AVIA0 = VTA1*KINV**(1.-2.*VTB1)
1097 AVI = AVIA0*(2.*AMI*G/AAI)**VTB1
1098 BVI = VTB1*BMI-1.
1099 ENDIF
1100 ENDIF
1102 END SUBROUTINE SOLVE_AFAI
1103 !======================================================================
1104 !
1105 !======================================================================
1106 SUBROUTINE SOLVE_AFAS(TK1D,RHO,QS1D,QC1D,NS1D,VS1D,FS1D,S2M1D, &
1107 AFAS,LAMS,MVDS,RHOS,SASPR,AMS,AVS,BVS)
1108 !======================================================================
1109 IMPLICIT NONE
1110 INTEGER :: TBIN,DBIN
1111 REAL :: TK1D,RHO,QS1D,QC1D,NS1D,VS1D,FS1D,S2M1D,AFAS,RHOS,SASPR, &
1112 LAMS,AMS,AVS,BVS,MVDS,LAMSMIN,LAMSMAX,KINV,C1X2,VTA1, &
1113 VTB1,BEST,S3M1D,KDX,TC1D,SBA1,AMS2,AAS2,AMS3,BMS3,AAS3, &
1114 BAS3,LAMD,BDS,FDS,LTK,LQS,MDS
1116 IF (ICE_RHOS.EQ.0) THEN
1117 RHOS = RHOS0
1118 VS1D = 0.
1119 ELSEIF (ICE_RHOS.EQ.1) THEN
1120 RHOS = QS1D/(VS1D+ISMALL)
1121 IF (RHOS.GT.RHOIMAX) THEN
1122 RHOS = RHOIMAX
1123 ELSEIF (RHOS.LT.RHOIMIN) THEN
1124 RHOS = RHOIMIN
1125 ENDIF
1126 VS1D = QS1D/RHOS
1127 ELSEIF (ICE_RHOS.EQ.2) THEN
1128 LTK = LOG(TK1D)
1129 LQS = -1.*LOG(QS1D)
1130 IF (TK1D.LT.TK0C) THEN
1131 RHOS = 15740.702-6098.0087*LTK+503.33089*LQS+594.29913* &
1132 LTK**2.+1.9033961*LQS**2.-94.950429*LTK*LQS
1133 ELSE
1134 RHOS = EXP(-64808.666+23113.508*LTK-36.46632*LQS-2060.6024*&
1135 LTK**2.-0.005729458*LQS**2.+6.5057411*LTK*LQS)
1136 ENDIF
1137 RHOS = MIN(MAX(RHOS,RHOIMIN),RHOIMAX)
1138 VS1D = 0.
1139 ENDIF
1140 IF (NS1D.LT.NSMALL) THEN
1141 LTK = LOG(TK1D)
1142 LQS = -1.*LOG(QS1D)
1143 MDS = EXP(-123.23898+40.74706*LTK-3.0333477*LTK**2.- &
1144 0.31219981*LQS+0.0012798222*LQS**2.)/1.E3
1145 NS1D = 1.E9*QS1D*V2M3/RHOS/MDS**3.
1146 ENDIF
1147 AMS = PI*RHOS/6.
1148 S3M1D = QS1D/AMS
1149 IF (AGG_SHAPE.EQ.0) THEN
1150 SASPR = 1.
1151 FS1D = 0.
1152 ELSEIF (AGG_SHAPE.EQ.1) THEN
1153 SASPR = FS1D/S3M1D
1154 IF (SASPR.LT.SASMIN) THEN
1155 SASPR = SASMIN
1156 FS1D = SASPR*S3M1D
1157 ELSEIF (SASPR.GT.SASMAX) THEN
1158 SASPR = SASMAX
1159 FS1D = SASPR*S3M1D
1160 ENDIF
1161 ENDIF
1162 IF (S2M1D.GE.ASMALL.AND.S3M1D.GE.ISMALL) THEN
1163 KDX = MAX(0.,S2M1D**3./(S3M1D**2.*NS1D))
1164 IF (KDX.GT.KCSMAX) THEN
1165 KDX = KCSMIN
1166 S2M1D = (KDX*NS1D*S3M1D**2.)**THRD
1167 ELSEIF (KDX.LT.KCSMIN) THEN
1168 KDX = KCSMIN
1169 S2M1D = (KDX*NS1D*S3M1D**2.)**THRD
1170 ENDIF
1171 AFAS = (6.*KDX-3.+SQRT(8.*KDX+1.))/(2.-2.*KDX)
1172 AFAS = MIN(MAX(AFAS,AFAMIN),AFAMAX)
1173 ! LAMS = (NS1D*(AFAS+1.)*(AFAS+2.)*(AFAS+3.)/S3M1D)**THRD
1174 LAMS = (AFAS+3.)*S2M1D/S3M1D
1175 ELSE
1176 IF (AFAS_3M.EQ.0) THEN
1177 AFAS = AFAS0
1178 S2M1D = 0.
1179 ELSEIF (AFAS_3M.EQ.1) THEN
1180 AFAS = AFAS0
1181 S2M1D = (KCSMIN*NS1D*S3M1D**2.)**THRD
1182 ELSEIF (AFAS_3M.EQ.2) THEN
1183 BDS = MIN(MAX((S3M1D/NS1D)**THRD*1.E3,DSMIN*1.E3),DSMAX*1.E3)
1184 IF (TK1D.GE.TK0C) THEN
1185 FDS = -0.21911541+1.2739845*BDS+0.10141003*LOG(NS1D)+ &
1186 0.30063818*BDS**2.-4.3857765E-3*LOG(NS1D)**2.- &
1187 7.8801732E-2*BDS*LOG(NS1D)
1188 ELSE
1189 IF (QC1D.GE.1.E-8) THEN
1190 FDS = -1.1527014+2.9067645*BDS+0.25316062*LOG(NS1D)- &
1191 0.17768557*BDS**2.-0.013117292*LOG(NS1D)**2.- &
1192 0.17020429*BDS*LOG(NS1D)
1193 ELSE
1194 FDS = -0.2813929+1.7275463*BDS+0.045550156*LOG(NS1D)-&
1195 0.16526226*BDS**2.-1.7699916E-3*LOG(NS1D)**2.- &
1196 4.6441257E-2*BDS*LOG(NS1D)
1197 ENDIF
1198 ENDIF
1199 KDX = MAX(KCSMIN,MIN(KCSMAX,(BDS/FDS)**3.))
1200 AFAS = (6.*KDX-3.+SQRT(8.*KDX+1.))/(2.-2.*KDX)
1201 AFAS = MIN(MAX(AFAS,AFAMIN),AFAMAX)
1202 ! AFAS = MAX(AFAMIN,4.5*TANH(0.5*(BDS-5.))+5.5)
1203 S2M1D = 0.
1204 ENDIF
1205 LAMS = (EXP(GAMLN(AFAS+4.)-GAMLN(AFAS+1.))*NS1D/S3M1D)**THRD
1206 ENDIF
1207 LAMSMIN = (EXP(GAMLN(AFAS+4.)-GAMLN(AFAS+1.)))**THRD/DSMAX
1208 LAMSMAX = (EXP(GAMLN(AFAS+4.)-GAMLN(AFAS+1.)))**THRD/DSMIN
1209 IF (LAMS.LT.LAMSMIN) THEN
1210 LAMS = LAMSMIN
1211 NS1D = S3M1D*EXP(GAMLN(AFAS+1.)-GAMLN(AFAS+4.)+3.*LOG(LAMS))
1212 ELSEIF (LAMS.GT.LAMSMAX) THEN
1213 LAMS = LAMSMAX
1214 NS1D = S3M1D*EXP(GAMLN(AFAS+1.)-GAMLN(AFAS+4.)+3.*LOG(LAMS))
1215 ENDIF
1216 MVDS = (EXP(GAMLN(AFAS+4.)-GAMLN(AFAS+1.)))**THRD/LAMS
1217 IF (ICE_VTS.EQ.0) THEN
1218 AVS = AVS0
1219 BVS = BVS0
1220 ELSEIF (ICE_VTS.EQ.1.OR.ICE_VTS.EQ.2) THEN
1221 KINV = (1.72E-5*(393./(TK1D+120.))*(TK1D/TK0C)**1.5)/RHO
1222 IF (AGG_SHAPE.EQ.0) THEN
1223 AMS3 = AMS
1224 BMS3 = BMS
1225 AAS3 = PI/4.
1226 BAS3 = 2.
1227 LAMD = LAMS
1228 ELSEIF (AGG_SHAPE.EQ.1) THEN
1229 TC1D = TK1D-TK0C
1230 IF (ICE_VTS.EQ.1) THEN
1231 TBIN = MIN(MAX(INT(ABS(TC1D)/5.)-4,0),8)
1232 IF (MVDS.LT.1.5E-4) DBIN = 0
1233 IF (MVDS.GE.1.5E-4.AND.MVDS.LT.3.E-4) DBIN = 1
1234 IF (MVDS.GE.3.E-4.AND.MVDS.LT.1.E-3) DBIN = 2
1235 IF (MVDS.GE.1.E-3.AND.MVDS.LT.3.E-3) DBIN = 3
1236 IF (MVDS.GE.3.E-3) DBIN = 4
1237 DBIN = MIN(MAX(DBIN,0),4)
1238 AMS3 = AMS1(TBIN*5+DBIN)
1239 BMS3 = BMS1(TBIN*5+DBIN)
1240 AAS3 = AAS1(TBIN*5+DBIN)
1241 BAS3 = BAS1(TBIN*5+DBIN)
1242 LAMD = MIN((AMS3*LAMS**3./AMS*EXP(GAMLN(BMS3+AFAS+1.)- &
1243 GAMLN(AFAS+4.)))**(1./BMS3),LAMS)
1244 ELSEIF (ICE_VTS.EQ.2) THEN
1245 BMS3 = 2.4+0.0085*MAX(TC1D,-65.)
1246 BAS3 = 2-0.19+0.0056*MAX(TC1D,-65.)
1247 AMS2 = 0.0102+0.00013*MAX(TC1D,-65.)
1248 AAS2 = 0.29+0.0035*MAX(TC1D,-65.)
1249 AMS3 = ((AMS2*(100.*MVDS)**BMS3)/1.E3)/(MVDS**BMS3)
1250 AAS3 = ((AAS2*(100.*MVDS)**BAS3)/1.E4)/(MVDS**BAS3)
1251 LAMD = LAMS
1252 ENDIF
1253 ENDIF
1254 SBA1 = BMS3+2.-BAS3
1255 BEST = 2.*G*NS1D*AMS3*EXP(GAMLN(SBA1+AFAS+1.)-GAMLN(AFAS+1.)- &
1256 SBA1*LOG(LAMD))/(KINV**2.*AAS3)
1257 C1X2 = VTC1*BEST**5.E-1
1258 VTB1 = C1X2/(1.+C1X2)**5.E-1/((1.+C1X2)**5.E-1-1.)/2.
1259 VTA1 = VTC2*((1+C1X2)**5.E-1-1.)**2./BEST**VTB1
1260 AVS = VTA1*KINV**(1.-2.*VTB1)*(2.*AMS3*G/AAS3)**VTB1
1261 BVS = VTB1*(BMS3+2.-BAS3)-1.
1262 ENDIF
1264 END SUBROUTINE SOLVE_AFAS
1265 !======================================================================
1267 !======================================================================
1268 SUBROUTINE SOLVE_AFAG(TK1D,RHO,QG1D,QC1D,NG1D,VG1D,G2M1D,LAMG, &
1269 AFAG,MVDG,RHOG,AMG,AVG,BVG)
1270 !======================================================================
1271 IMPLICIT NONE
1272 REAL :: TK1D,RHO,QG1D,QC1D,NG1D,VG1D,G2M1D,G3M1D,RHOG,LAMG,AFAG, &
1273 AMG,AVG,BVG,BEST0,LAMGMIN,LAMGMAX,KDX,KINV,GG1,C1X2,VTA1,&
1274 VTB1,BEST,MVDG,GMLR,BDG,FDG,LTK,LQG,MDG
1276 IF (ICE_RHOG.EQ.0) THEN
1277 RHOG = RHOG1
1278 VG1D = 0.
1279 ELSEIF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
1280 RHOG = QG1D/(VG1D+ISMALL)
1281 IF (TK1D.GE.TK0C) THEN
1282 IF (RHOG.GT.RHOH) THEN
1283 RHOG = RHOH
1284 ENDIF
1285 ELSE
1286 IF (RHOG.GT.RHOG0) THEN
1287 RHOG = RHOG0
1288 ENDIF
1289 ENDIF
1290 IF (RHOG.LT.RHOIMIN) THEN
1291 RHOG = RHOIMIN
1292 ENDIF
1293 VG1D = QG1D/RHOG
1294 ENDIF
1295 IF (NG1D.LT.NSMALL) THEN
1296 LTK = LOG(TK1D)
1297 LQG = -1.*LOG(QG1D)
1298 MDG = EXP(-2205.8027+1225.8046*LTK-226.27995*LTK**2.+ &
1299 13.929644*LTK**3.-0.25*LQG)/1.E3
1300 NG1D = 1.E9*QG1D*V2M3/RHOG/MDG**3.
1301 ENDIF
1302 AMG = PI*RHOG/6.
1303 G3M1D = QG1D*V2M3/RHOG
1304 IF (G2M1D.GE.ASMALL.AND.G3M1D.GE.ISMALL) THEN
1305 KDX = MAX(0.,G2M1D**3./(G3M1D**2.*NG1D))
1306 IF (KDX.GT.KCGMAX) THEN
1307 KDX = KCGMIN
1308 G2M1D = (KDX*NG1D*G3M1D**2.)**THRD
1309 ELSEIF (KDX.LT.KCGMIN) THEN
1310 KDX = KCGMIN
1311 G2M1D = (KDX*NG1D*G3M1D**2.)**THRD
1312 ENDIF
1313 AFAG = (6.*KDX-3.+SQRT(8.*KDX+1.))/(2.-2.*KDX)
1314 AFAG = MIN(MAX(AFAG,AFAMIN),AFAMAX)
1315 ! LAMG = (NG1D*(AFAG+1.)*(AFAG+2.)*(AFAG+3.)/G3M1D)**THRD
1316 LAMG = (AFAG+3.)*G2M1D/G3M1D
1317 ELSE
1318 IF (AFAG_3M.EQ.0) THEN
1319 AFAG = AFAG0
1320 G2M1D = 0.
1321 ELSEIF (AFAG_3M.EQ.1) THEN
1322 AFAG = AFAG0
1323 G2M1D = (KCGMIN*NG1D*G3M1D**2.)**THRD
1324 ELSEIF (AFAG_3M.EQ.2) THEN
1325 BDG = MIN(MAX((G3M1D/NG1D)**THRD*1.E3,DGMIN*1.E3),DGMAX*1.E3)
1326 IF (TK1D.GE.TK0C) THEN
1327 FDG = 0.58006354+0.79661229*BDG-0.18394382*LOG(NG1D)+ &
1328 0.067371044*BDG**2.+9.832945E-3*LOG(NG1D)**2.+ &
1329 0.12433055*BDG*LOG(NG1D)
1330 ELSE
1331 IF (QC1D.GE.1.E-8) THEN
1332 FDG = 0.17363469+1.5044291*BDG-0.050639722*LOG(NG1D)+&
1333 0.015101052*BDG**2.+2.5974719E-3*LOG(NG1D)**2.+&
1334 0.01961464*BDG*LOG(NG1D)
1335 ELSE
1336 FDG = 0.59259317-0.89933515*BDG+2.0893032*BDG**2.- &
1337 0.50305755*BDG**3.-2.2446793E-2*LOG(NG1D)+ &
1338 2.7589047E-3*LOG(NG1D)**2.
1339 ENDIF
1340 ENDIF
1341 KDX = MAX(KCGMIN,MIN(KCGMAX,(BDG/FDG)**3.))
1342 AFAG = (6.*KDX-3.+SQRT(8.*KDX+1.))/(2.-2.*KDX)
1343 AFAG = MIN(MAX(AFAG,AFAMIN),AFAMAX)
1344 ! AFAG = MAX(AFAMIN,5.5*TANH(0.7*(BDG-4.5))+8.5)
1345 G2M1D = 0.
1346 ENDIF
1347 LAMG = (EXP(GAMLN(AFAG+4.)-GAMLN(AFAG+1.))*NG1D/G3M1D)**THRD
1348 ENDIF
1349 LAMGMIN = (EXP(GAMLN(AFAG+4.)-GAMLN(AFAG+1.)))**THRD/DGMAX
1350 LAMGMAX = (EXP(GAMLN(AFAG+4.)-GAMLN(AFAG+1.)))**THRD/DGMIN
1351 IF (LAMG.LT.LAMGMIN) THEN
1352 LAMG = LAMGMIN
1353 NG1D = G3M1D*EXP(GAMLN(AFAG+1.)-GAMLN(AFAG+4.)+3.*LOG(LAMG))
1354 ELSEIF (LAMG.GT.LAMGMAX) THEN
1355 LAMG = LAMGMAX
1356 NG1D = G3M1D*EXP(GAMLN(AFAG+1.)-GAMLN(AFAG+4.)+3.*LOG(LAMG))
1357 ENDIF
1358 MVDG = (EXP(GAMLN(AFAG+4.)-GAMLN(AFAG+1.)))**THRD/LAMG
1359 IF (ICE_VTG.EQ.0) THEN
1360 AVG = AVG0
1361 BVG = BVG0
1362 ELSEIF (ICE_VTG.EQ.1) THEN
1363 KINV = (1.72E-5*(393./(TK1D+120.))*(TK1D/TK0C)**1.5)/RHO
1364 BEST0 = 2.*G*NG1D/(KINV**2.)
1365 GG1 = GAMLN(AFAG+1.)
1366 BEST = BEST0*AMG*EXP(GAMLN(BMG+AFAG+1.)-GG1-BMG*LOG(LAMG))/AAW
1367 C1X2 = VTC1*BEST**5.E-1
1368 VTB1 = C1X2/(1.+C1X2)**5.E-1/((1.+C1X2)**5.E-1-1.)/2.
1369 VTA1 = VTC2*((1+C1X2)**5.E-1-1.)**2./BEST**VTB1
1370 AVG = VTA1*KINV**(1.-2.*VTB1)*(2.*AMG*G/AAW)**VTB1
1371 BVG = VTB1*BMG-1.
1372 ENDIF
1374 END SUBROUTINE SOLVE_AFAG
1375 !======================================================================
1376 !
1377 !======================================================================
1378 SUBROUTINE SOLVE_AFAH(TK1D,RHO,QH1D,NH1D,H2M1D,LAMH,AFAH,MVDH, &
1379 AVH,BVH)
1380 !======================================================================
1381 IMPLICIT NONE
1382 REAL :: TK1D,RHO,QH1D,NH1D,H2M1D,H3M1D,LAMH,AFAH,AVH,BVH,BEST0, &
1383 GH1,KDX,MVDH,LAMHMIN,LAMHMAX,KINV,C1X2,VTA1,VTB1,BEST, &
1384 BDH,FDH,LTK,LQH
1386 IF (NH1D.LT.NSMALL) THEN
1387 LTK = LOG(TK1D)
1388 LQH = -1.*LOG(QH1D)
1389 NH1D = EXP(22.929406-4.2328364*LTK+0.30647567*LTK**2.- &
1390 0.009233271*LTK**3.-0.25*LQH)
1391 ENDIF
1392 H3M1D = QH1D*V2M3/RHOH
1393 IF (H2M1D.GE.ASMALL.AND.H3M1D.GE.ISMALL) THEN
1394 KDX = MAX(0.,H2M1D**3./(H3M1D**2.*NH1D))
1395 IF (KDX.GT.KCHMAX) THEN
1396 KDX = KCHMIN
1397 H2M1D = (KDX*NH1D*H3M1D**2.)**THRD
1398 ELSEIF (KDX.LT.KCHMIN) THEN
1399 KDX = KCHMIN
1400 H2M1D = (KDX*NH1D*H3M1D**2.)**THRD
1401 ENDIF
1402 AFAH = (6.*KDX-3.+SQRT(8.*KDX+1.))/(2.-2.*KDX)
1403 AFAH = MIN(MAX(AFAH,AFAMIN),AFAMAX)
1404 ! LAMH = (NH1D*(AFAH+1.)*(AFAH+2.)*(AFAH+3.)/H3M1D)**THRD
1405 LAMH = (AFAH+3.)*H2M1D/H3M1D
1406 ELSE
1407 IF (AFAH_3M.EQ.0) THEN
1408 AFAH = AFAH0
1409 H2M1D = 0.
1410 ELSEIF (AFAH_3M.EQ.1) THEN
1411 AFAH = AFAH0
1412 H2M1D = (KCHMIN*NH1D*H3M1D**2.)**THRD
1413 ELSEIF (AFAH_3M.EQ.2) THEN
1414 BDH = MIN(MAX((H3M1D/NH1D)**THRD*1.E3,DHMIN*1.E3),DHMAX*1.E3)
1415 IF (TK1D.GE.TK0C) THEN
1416 FDH = 1.157754+0.37852874*BDH-0.11129737*LOG(NH1D)+ &
1417 0.13929599*BDH**2.+8.1105237E-3*LOG(NH1D)**2.+ &
1418 5.7432113E-2*BDH*LOG(NH1D)
1419 ELSE
1420 FDH = -0.48246793+2.0407077*BDH+2.2262969E-2*LOG(NH1D)- &
1421 0.158389*BDH**2.-5.5545804E-3*LOG(NH1D)**2.+ &
1422 2.9443577E-2*BDH*LOG(NH1D)
1423 ENDIF
1424 KDX = MAX(KCHMIN,MIN(KCHMAX,(BDH/FDH)**3.))
1425 AFAH = (6.*KDX-3.+SQRT(8.*KDX+1.))/(2.-2.*KDX)
1426 AFAH = MIN(MAX(AFAH,AFAMIN),AFAMAX)
1427 ! AFAH = MAX(AFAMIN,3.7*TANH(0.3*(BDH-9.))+6.5)
1428 H2M1D = 0.
1429 ENDIF
1430 LAMH = (EXP(GAMLN(AFAH+4.)-GAMLN(AFAH+1.))*NH1D/H3M1D)**THRD
1431 ENDIF
1432 LAMHMIN = (EXP(GAMLN(AFAH+4.)-GAMLN(AFAH+1.)))**THRD/DHMAX
1433 LAMHMAX = (EXP(GAMLN(AFAH+4.)-GAMLN(AFAH+1.)))**THRD/DHMIN
1434 IF (LAMH.LT.LAMHMIN) THEN
1435 LAMH = LAMHMIN
1436 NH1D = H3M1D*EXP(GAMLN(AFAH+1.)-GAMLN(AFAH+4.)+3.*LOG(LAMH))
1437 ELSEIF (LAMH.GT.LAMHMAX) THEN
1438 LAMH = LAMHMAX
1439 NH1D = H3M1D*EXP(GAMLN(AFAH+1.)-GAMLN(AFAH+4.)+3.*LOG(LAMH))
1440 ENDIF
1441 MVDH = (EXP(GAMLN(AFAH+4.)-GAMLN(AFAH+1.)))**THRD/LAMH
1442 IF (ICE_VTH.EQ.0) THEN
1443 AVH = AVH0
1444 BVH = BVH0
1445 ELSEIF (ICE_VTH.EQ.1) THEN
1446 KINV = (1.72E-5*(393./(TK1D+120.))*(TK1D/TK0C)**1.5)/RHO
1447 BEST0 = 2.*G*NH1D/(KINV**2.)
1448 GH1 = GAMLN(AFAH+1.)
1449 BEST = BEST0*AMH*EXP(GAMLN(BMH+AFAH+1.)-GH1-BMH*LOG(LAMH))/AAW
1450 C1X2 = VTC1*BEST**5.E-1
1451 VTB1 = C1X2/(1.+C1X2)**5.E-1/((1.+C1X2)**5.E-1-1.)/2.
1452 VTA1 = VTC2*((1+C1X2)**5.E-1-1.)**2./BEST**VTB1
1453 AVH = VTA1*KINV**(1.-2.*VTB1)*(2.*AMH*G/AAW)**VTB1
1454 BVH = VTB1*BMH-1.
1455 ENDIF
1457 END SUBROUTINE SOLVE_AFAH
1458 !======================================================================
1459 !
1460 !======================================================================
1461 SUBROUTINE AERO_CONST(CCNTY)
1462 !======================================================================
1463 IMPLICIT NONE
1464 INTEGER, INTENT(IN) :: CCNTY ! 1.MARINE(WHITBY,1978);2.CLEAN CONTINENTAL(WHITBY,1978);
1465 ! 3.AVERAGE CONTINENTAL(WHITBY,1978);
1466 ! 4.URBAN(WHITBY,1978); 5.ICE NUECEI
1467 INTEGER, PARAMETER :: ID_SENS = 1 ! sensetivity test ID
1468 INTEGER, PARAMETER :: N1 = NCCN, N2 = 5 ! AEROSOL MODE AND COMPONENT
1469 INTEGER :: IA,I,K,J,IM,IV,IB
1470 INTEGER, DIMENSION(NAER) :: IDAER
1471 REAL, DIMENSION(NAER) :: XMASS
1472 REAL, DIMENSION(N2) :: ASHX,CMASX,DNASX,AVANX ! AEROSOL SCALE HEIGHT. 3.57km-continental, 0.8km-marine;
1473 ! MOLAR WEIGHT OF AEROSOL (kg/mol);
1474 ! DENSITY OF SOLID AEROSOL (kg/m^3);
1475 ! VAN'T HOFF FACTOR
1476 REAL, DIMENSION(N1,N2) :: ZCCNX,CNMODX,CNSTDX ! AEROSOL TRI-MODAL SPECTRUM PARAMETERS
1477 REAL, DIMENSION(N2,3) :: SENX ! SENSITIVE TEST RATIO
1478 REAL :: XLOG3,XMTOT,XMAS,DUST_IN0,DUST_IN,DAIR,DZ0,ZH ! Height of grid point [m]
1479 DOUBLE PRECISION :: DMODE,D2STDV,DLNXX,DERF,DSQRT,DLOG
1480 DATA ZCCNX/3.4E8,6.E7,3.E6, 1.E9,8.E8,7.2E5, 6.4E9,2.3E9,3.2E6, &! Cheng et al. 2007, Table 1, number concentration
1481 1.06E11,3.2E10,5.4E6, 4.02E-11,4.5E9,5.4E6/
1482 DATA CNMODX/5.E-9,3.55E-8,3.1E-7,8.E-9,3.3E-8,4.6E-7,7.5E-9, &! Cheng et al. 2007, Table 1, mean size
1483 3.8E-8,5.1E-7,7.E-9,2.7E-8,4.3E-7,4.5E-9,2.35E-8, &
1484 5.5E-7/
1485 DATA CNSTDX/0.47,0.69,0.99,0.47,0.74,0.79,0.53,0.69,0.77,0.59, &! Cheng et al. 2007, Table 1, standard deviation
1486 0.77,0.79,0.53,0.75,0.74/
1487 DATA ASHX/8.E2,3.57E3,3.57E3,2.E3,1.E4/ ! SCALING HEIGHT
1488 DATA CMASX/0.13214,0.13214,0.13214,0.13214,0.13214/ ! MOLAR WEIGHT OF AEROSOL (kg/mol)
1489 DATA DNASX/1769.,1769.,1769.,1769.,1769./ ! DENSITY OF SOLID AEROSOL (kg/m^3)
1490 DATA AVANX/3.,3.,3.,3.,3./ ! VAN'T HOFF FACTOR
1491 DATA SENX/1.,1.,1.,1.,1.,10.,10.,10.,10.,10.,0.1,0.1,0.1,0.1,0.1/ ! 1st, 2nd, and 3rd set for sensetivity test
1493 IF (CCNTY.EQ.1) THEN
1494 DNC0 = 46635.361; DNC1 = -25567.933
1495 DNC2 = 4674.3534; DNC3 = -284.84377
1496 ELSEIF (CCNTY.EQ.2) THEN
1497 DNC0 = -48575.888; DNC1 = 26634.802
1498 DNC2 = -4862.961; DNC3 = 295.7886
1499 ELSEIF (CCNTY.EQ.3) THEN
1500 DNC0 = -63646.587; DNC1 = 34778.66
1501 DNC2 = -6326.6327; DNC3 = 383.28849
1502 ELSEIF (CCNTY.EQ.4) THEN
1503 DNC0 = -6069.3697; DNC1 = 3667.889
1504 DNC2 = -725.3412; DNC3 = 47.260735
1505 ENDIF
1506 IBAER(1) = 1
1507 DO I = 2,NAER
1508 IBAER(I) = IBAER(I-1)+NAERN(I-1)
1509 ENDDO
1510 TBLRC(1) = DLOG(1.D-9) ! 0.001 um
1511 TBLRC(NTBXA) = DLOG(1.D-3) ! 1000. um
1512 DO I = 2,NTBXA-1
1513 TBLRC(I) = TBLRC(1)+DBLE(I-1)/DBLE(NTBXA-1)*(TBLRC(NTBXA)- &
1514 TBLRC(1)) ! ln(rc)
1515 ENDDO
1516 IDAER = (/CCNTY,5/)
1517 PRINT *, 'AEROSOL ID =',IDAER
1518 DO J = 1,NAER
1519 ASH(J) = ASHX(IDAER(J))
1520 DNAS(J) = DNASX(IDAER(J))
1521 CMAS(J) = CMASX(IDAER(J))
1522 AVAN(J) = AVANX(IDAER(J))
1523 BETA1(J) = CMW*DNAS(J)*AVAN(J)/(CMAS(J)*RHOW)
1524 XMTOT = 0.
1525 DO IM = 1,N1
1526 ZCCN(IM,J) = ZCCNX(IM,IDAER(J))*1. ! change the factor to change the initial concentration
1527 CNMOD(IM,J) = CNMODX(IM,IDAER(J))
1528 CNSTD(IM,J) = CNSTDX(IM,IDAER(J))
1529 XLOG3 = CNMOD(IM,J)*CNMOD(IM,J)*CNMOD(IM,J)
1530 WMAS(IM,J) = ZCCN(IM,J)*XLOG3*EXP(4.5*CNSTD(IM,J)**2.) ! factor for mass, the 3rd momentum
1531 RFACT(IM,J) = 1./(C4PI3*DNAS(J)*XLOG3*EXP(4.5* &
1532 CNSTD(IM,J)**2.))
1533 XMTOT = XMTOT+WMAS(IM,J)
1534 ENDDO
1535 DO IM = 1,N1
1536 WMAS(IM,J) = WMAS(IM,J)/XMTOT
1537 ENDDO
1539 DO I = 1,NTBXA
1540 TBLXF(I,J) = DBLE(0.)
1541 ENDDO
1542 DO IM = 1,N1
1543 DMODE = DLOG(DBLE(CNMOD(IM,J)))+DBLE(3.)*DBLE(CNSTD(IM,J))*DBLE(CNSTD(IM,J))
1544 D2STDV = DSQRT(DBLE(2.))*DBLE(CNSTD(IM,J))
1545 DO I = 1,NTBXA
1546 DLNXX = (TBLRC(I)-DMODE)/D2STDV
1547 TBLXF(I,J) = TBLXF(I,J)+DBLE(WMAS(IM,J))*DBLE(0.5)* &
1548 (1.D+0+DERF(DLNXX))
1549 ENDDO
1550 ENDDO ! IM=1,N1
1551 DO I = 1,NTBXA
1552 TBLXF(I,J) = DMAX1(1.D-20,TBLXF(I,J))
1553 ENDDO
1555 CALL FIND_RC0(1.D-6,CNMOD(1,J),CNSTD(1,J),WMAS(1,J),RXMIN(J), &
1556 TBLXF(1,J),TBLRC) ! lower limit of dry aerosol fraction is set as 1.E-6
1557 WRITE(*,*)'FOR DRY AEROSOL FRACTION BE > 1.E-6'
1558 WRITE(*,'(A30,I1,A8,F6.4,A3)')'MINIMUN R-CUTOFF FOR AEROSOL' &
1559 ,J,' IS SET ',RXMIN(J)*1.E6,' um'
1560 WRITE(*,*)'SENSITIVITY TEST ID:',ID_SENS
1561 !----------------- FACTOR FOR SENSETIVITY ------------------------------
1562 SENS(J) = SENX(IDAER(J),ID_SENS)
1563 ENDDO
1565 END SUBROUTINE AERO_CONST
1566 !======================================================================
1568 !======================================================================
1569 SUBROUTINE INIT_AEROSOL(P,RHO,DZ,XLAND,QAERO,IDS,IDE,JDS,JDE,KDS,&
1570 KDE,IMS,IME,JMS,JME,KMS,KME,ITS,ITE,JTS,JTE,KTS,KTE)
1571 !======================================================================
1572 IMPLICIT NONE
1573 INTEGER, INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE,IMS,IME,JMS,JME, &
1574 KMS,KME,ITS,ITE,JTS,JTE,KTS,KTE
1575 INTEGER :: ITF,JTF,IA,I,K,J,IM,K_PBL,IV,IB
1576 INTEGER, DIMENSION(NAER) :: IDAER
1577 REAL, INTENT(IN), DIMENSION(IMS:IME,JMS:JME) :: XLAND ! 1:land ; 2:ocean
1578 REAL, INTENT(IN), DIMENSION(ITS:ITE,KTS:KTE,JTS:JTE) :: P,RHO,DZ
1579 REAL, DIMENSION(ITS:ITE,KTS:KTE,JTS:JTE,NAERT) :: QAERO
1580 REAL, DIMENSION(ITS:ITE,JTS:JTE,NAER) :: RASH
1581 REAL, DIMENSION(NAER) :: XMASS
1582 REAL, PARAMETER :: P_PBL = 85000. ! set PBL pressure [Pa]
1583 REAL, PARAMETER :: BACKIN = 4.E5 ! initial ice nuclei number concentration (#/kg)
1584 REAL :: XLOG3,XMTOT,XMAS,DUST_IN0,DUST_IN,DAIR,DZ0,ZH ! Height of grid point [m]
1585 DOUBLE PRECISION :: DMODE,D2STDV,DLNXX,DERF,DSQRT,DLOG
1587 ITF = MIN(ITE,IDE-1)
1588 JTF = MIN(JTE,JDE-1)
1589 DO IA = 1,NAERT
1590 DO K = KTS,KTE
1591 DO J = JTS,JTF
1592 DO I = ITS,ITF
1593 QAERO(I,K,J,IA) = 0.
1594 ENDDO
1595 ENDDO
1596 ENDDO
1597 ENDDO
1598 DO J = 1,NAER
1599 XMASS(J) = 0.
1600 DO IM = 1,NCCN
1601 XMAS = ZCCN(IM,J)*CNMOD(IM,J)**3.*EXP(4.5*CNSTD(IM,J)**2.)
1602 XMASS(J) = XMASS(J)+XMAS
1603 ENDDO
1604 XMASS(J) = XMASS(J)*C4PI3*DNAS(J)*SENS(J)
1605 ENDDO
1606 IF (ID_DUST*ID_IN.NE.0) THEN ! IF DUST EXISTS
1607 DUST_IN0 = 0.
1608 ! DO IM = 1,NCCN
1609 ! DUST_IN0 = DUST_IN0+ZCCN(IM,ID_DUST)
1610 ! ENDDO
1611 ELSE ! NO DUST
1612 DUST_IN0 = BACKIN
1613 ENDIF
1614 DO J = JTS,JTF
1615 DO I = ITS,ITF
1616 K_PBL = 1
1617 DO K = KTS,KTE
1618 IV = 1
1619 DO IA = 1,NAER
1620 QAERO(I,K,J,IV) = XMASS(IA)/RHO(I,K,J) ! dry aerosol [kg/kg]
1621 RASH (I,J,IA) = 1./ASH(IA) ! increase scale height if necessary
1622 DUST_IN = DUST_IN0 ! dust # over land
1623 IF (IA.EQ.ID_IN) THEN ! IN
1624 IF (ID_DUST.NE.0) THEN ! DUST IS CONSIDERED AS IN
1625 ! IF (XLAND(I,J).EQ.2.) THEN ! over ocean
1626 ! DUST_IN = DUST_IN*0.01 ! dust #
1627 ! RASH (I,J,IA) = RASH (I,J,IA)*0.5 ! double scale height
1628 ! ENDIF
1629 ELSE
1630 DUST_IN = BACKIN ! set to background value
1631 RASH (I,J,IA) = RASH (I,J,IA)*0.5 ! double scale height
1632 ENDIF
1633 DAIR = RHO(I,K,J)
1634 DUST_IN = MAX(BACKIN,DUST_IN)
1635 QAERO(I,K,J,IV) = DUST_IN/DAIR ! 0.5 #/L [#/kg]*[kPa] ! tsai
1636 ELSE ! dust, NH42SO4, chemicals....
1637 ! IF (XLAND(I,J).EQ.2.) THEN ! over ocean
1638 ! IF (IA.EQ.ID_NH42SO4) THEN !
1639 ! QAERO(I,K,J,IV) = QAERO(I,K,J,IV)*0.05 ! reduce it
1640 ! RASH(I,J,IA) = RASH(I,J,IA)*0.5 ! double scale height
1641 ! ELSE ! dust or IN, not sulfate (the same)
1642 ! QAERO(I,K,J,IV) = QAERO(I,K,J,IV)*0.01 ! reduce it
1643 ! RASH(I,J,IA) = RASH (I,J,IA)*0.5 ! double scale height
1644 ! DUST_IN = DUST_IN0*0.01 ! dust #
1645 ! ENDIF
1646 ! ENDIF
1647 ENDIF
1648 IV = IV+NAERN(IA)
1649 ENDDO
1650 IF (P(I,K,J).LT.P_PBL) K_PBL = K
1651 ENDDO
1652 K_PBL = MIN(K_PBL,KTE-3+1) ! at least 3 layers are within PBL
1653 ZH = 0.
1654 DZ0 = 0.
1655 DO K = K_PBL-1,1,-1
1656 DAIR = RHO(I,K,J)
1657 ZH = ZH+(DZ0+DZ(I,K,J))*0.5
1658 DZ0 = DZ(I,K,J)
1659 IV = 1
1660 DO IA = 1,NAER
1661 QAERO(I,K,J,IV)=QAERO(I,K,J,IV)*EXP(-RASH(I,J,IA)*ZH) ! dry aerosol [kg/kg]*[kPa]
1662 IV = IV+NAERN(IA)
1663 ENDDO
1664 ENDDO
1665 IV = 0
1666 DO IA = 1,NAER
1667 DO IB = 2,MIN(2,NAERN(IA)) ! if NV>2
1668 DO K = KTS,KTE
1669 QAERO(I,K,J,IV+IB) = QAERO(I,K,J,IV+1) ! set NV2: total = dry aerosol
1670 ENDDO
1671 ENDDO
1672 IV = IV+NAERN(IA)
1673 ENDDO
1674 ENDDO ! FOR I LOOPS
1675 ENDDO ! FOR J LOOPS
1677 PRINT *,'aerosols_init,I,J,NAER',(ITS+ITE)/2,(JTS+JTE)/2,NAER
1678 DO K = KTS,KTE-1
1679 WRITE(*,'(I2,X,20(E12.6,X))') K,(QAERO((ITS+ITE)/2,K, &
1680 (JTS+JTE)/2,IV),IV=1,NAERT)
1681 ENDDO
1683 RETURN
1685 END SUBROUTINE INIT_AEROSOL
1686 !======================================================================
1687 !
1688 !=======================================================================
1689 SUBROUTINE MP_NTU(ITIMESTEP,TH,P,DZ,W,PII,DT_MP,SR,QV,QC,QR,QI, &
1690 QS,QG,QH,NC,NR,NI,NS,NG,NH,QDCN,QTCN,QCCN,QRCN,QNIN, &
1691 FI,FS,VI,VS,VG,AI,AS,AG,AH,I3M,RAINNC,RAINNCV,SNOWNC, &
1692 SNOWNCV,GRAPNC,GRAPNCV,HAILNC,HAILNCV,IDS,IDE,JDS,JDE,&
1693 KDS,KDE,IMS,IME,JMS,JME,KMS,KME,ITS,ITE,JTS,JTE,KTS, &
1694 KTE)
1695 !======================================================================
1696 IMPLICIT NONE
1697 INTEGER, INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE,IMS,IME,JMS,JME, &
1698 KMS,KME,ITS,ITE,JTS,JTE,KTS,KTE,ITIMESTEP
1699 REAL, INTENT(IN) :: DT_MP
1700 REAL, DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: RAINNC,RAINNCV,&
1701 SNOWNC,SNOWNCV,GRAPNC,GRAPNCV,HAILNC,HAILNCV,SR
1702 REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(IN) :: PII,DZ,W,P
1703 REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(INOUT) :: &
1704 TH,QV,QC,QR,QI,QS,QG,QH,NC,NR,NI,NS,NG,NH,VI,VS,VG,FI,FS, &
1705 AI,AS,AG,AH,I3M,QDCN,QTCN,QCCN,QRCN,QNIN
1706 INTEGER :: I,K,J,NK,ITF,JTF
1707 REAL :: DT,DTMN
1708 REAL, DIMENSION(KTS:KTE) :: TK1D,P1D,W1D,S1D,DZ1D,QV1D,QC1D,QR1D,&
1709 QI1D,QS1D,QG1D,QH1D,NC1D,NR1D,NI1D,NS1D,NG1D,NH1D,VI1D, &
1710 VS1D,VG1D,FI1D,FS1D,AI1D,AS1D,AG1D,AH1D,I3M1D,QDCN1D, &
1711 QTCN1D,QCCN1D,QRCN1D,QNIN1D
1712 REAL, DIMENSION(ITS:ITE,JTS:JTE) :: CLODNCV,ICENCV,VINCV,VSNCV, &
1713 VGNCV,FINCV,FSNCV,AINCV,ASNCV,AGNCV,AHNCV,I3MNCV
1714 REAL, DIMENSION(ITS:ITE,KTS:KTE,JTS:JTE) :: TK
1716 DT = DT_MP
1717 DTMN = DT_MP/60.
1718 ITF = MIN(ITE,IDE-1)
1719 JTF = MIN(JTE,JDE-1)
1720 DO I = ITS,ITF
1721 DO J = JTS,JTF
1722 CLODNCV(I,J) = 0.; RAINNCV(I,J) = 0.; ICENCV(I,J) = 0.
1723 SNOWNCV(I,J) = 0.; GRAPNCV(I,J) = 0.; HAILNCV(I,J) = 0.
1724 VINCV(I,J) = 0.; VSNCV(I,J) = 0.; VGNCV(I,J) = 0.
1725 FINCV(I,J) = 0.; FSNCV(I,J) = 0.; AINCV(I,J) = 0.
1726 ASNCV(I,J) = 0.; AGNCV(I,J) = 0.; AHNCV(I,J) = 0.
1727 I3MNCV(I,J) = 0.; SR(I,J) = 0.
1728 !----------------- write data from 3D to 1D and assign upside down -----
1729 DO K = KTS,KTE
1730 NK = KTE-K+1
1731 S1D(K) = 0.
1732 TK1D(K) = TH(I,NK,J)*PII(I,NK,J)
1733 W1D(K) = 0.5*(W(I,NK,J)+W(I,NK+1,J)) ! W at half level
1734 QV1D(K) = QV(I,NK,J)
1735 DZ1D(K) = DZ(I,NK,J)
1736 P1D(K) = P(I,NK,J)
1737 QC1D(K) = QC(I,NK,J)
1738 QR1D(K) = QR(I,NK,J)
1739 QI1D(K) = QI(I,NK,J)
1740 QS1D(K) = QS(I,NK,J)
1741 QG1D(K) = QG(I,NK,J)
1742 QH1D(K) = QH(I,NK,J)
1743 NC1D(K) = NC(I,NK,J)
1744 NR1D(K) = NR(I,NK,J)
1745 NI1D(K) = NI(I,NK,J)
1746 NS1D(K) = NS(I,NK,J)
1747 NG1D(K) = NG(I,NK,J)
1748 NH1D(K) = NH(I,NK,J)
1749 VI1D(K) = VI(I,NK,J)
1750 VS1D(K) = VS(I,NK,J)
1751 VG1D(K) = VG(I,NK,J)
1752 FI1D(K) = FI(I,NK,J)
1753 FS1D(K) = FS(I,NK,J)
1754 AI1D(K) = AI(I,NK,J)
1755 AS1D(K) = AS(I,NK,J)
1756 AG1D(K) = AG(I,NK,J)
1757 AH1D(K) = AH(I,NK,J)
1758 I3M1D(K) = I3M(I,NK,J)
1759 QDCN1D(K) = MAX(RLIMIT,QDCN(I,NK,J))
1760 QTCN1D(K) = MAX(RLIMIT,QTCN(I,NK,J))
1761 QCCN1D(K) = MAX(RLIMIT,QCCN(I,NK,J))
1762 QRCN1D(K) = MAX(RLIMIT,QRCN(I,NK,J))
1763 QNIN1D(K) = MAX(RLIMIT,QNIN(I,NK,J))
1764 ENDDO
1766 CALL NTU_MICRO(TK1D,QV1D,DZ1D,P1D,S1D,W1D,SR(I,J),ICENCV(I,J),&
1767 VINCV(I,J),VSNCV(I,J),VGNCV(I,J),FINCV(I,J),FSNCV(I,J), &
1768 AINCV(I,J),ASNCV(I,J),AGNCV(I,J),AHNCV(I,J),I3MNCV(I,J), &
1769 CLODNCV(I,J),RAINNC(I,J),RAINNCV(I,J),SNOWNC(I,J), &
1770 SNOWNCV(I,J),GRAPNC(I,J),GRAPNCV(I,J),HAILNC(I,J), &
1771 HAILNCV(I,J),DT,DTMN,QC1D,QR1D,QI1D,QS1D,QG1D,QH1D,NC1D, &
1772 NR1D,NI1D,NS1D,NG1D,NH1D,VI1D,VS1D,VG1D,FI1D,FS1D,AI1D, &
1773 AS1D,AG1D,AH1D,I3M1D,QDCN1D,QTCN1D,QCCN1D,QRCN1D,QNIN1D, &
1774 KTS,KTE)
1776 DO K = KTS,KTE
1777 NK = KTE-K+1
1778 TH(I,NK,J) = TK1D(K)/PII(I,NK,J)
1779 QV(I,NK,J) = MAX(0.,QV1D(K))
1780 QC(I,NK,J) = MAX(0.,QC1D(K))
1781 QR(I,NK,J) = MAX(0.,QR1D(K))
1782 QI(I,NK,J) = MAX(0.,QI1D(K))
1783 QS(I,NK,J) = MAX(0.,QS1D(K))
1784 QG(I,NK,J) = MAX(0.,QG1D(K))
1785 QH(I,NK,J) = MAX(0.,QH1D(K))
1786 NC(I,NK,J) = MAX(0.,NC1D(K))
1787 NR(I,NK,J) = MAX(0.,NR1D(K))
1788 NI(I,NK,J) = MAX(0.,NI1D(K))
1789 NS(I,NK,J) = MAX(0.,NS1D(K))
1790 NG(I,NK,J) = MAX(0.,NG1D(K))
1791 NH(I,NK,J) = MAX(0.,NH1D(K))
1792 VI(I,NK,J) = MAX(0.,VI1D(K))
1793 VS(I,NK,J) = MAX(0.,VS1D(K))
1794 VG(I,NK,J) = MAX(0.,VG1D(K))
1795 FI(I,NK,J) = MAX(0.,FI1D(K))
1796 FS(I,NK,J) = MAX(0.,FS1D(K))
1797 AI(I,NK,J) = MAX(0.,AI1D(K))
1798 AS(I,NK,J) = MAX(0.,AS1D(K))
1799 AG(I,NK,J) = MAX(0.,AG1D(K))
1800 AH(I,NK,J) = MAX(0.,AH1D(K))
1801 I3M(I,NK,J) = MAX(0.,I3M1D(K))
1802 QDCN(I,NK,J) = MAX(0.,QDCN1D(K))
1803 QTCN(I,NK,J) = MAX(0.,QTCN1D(K))
1804 QCCN(I,NK,J) = MAX(0.,QCCN1D(K))
1805 QRCN(I,NK,J) = MAX(0.,QRCN1D(K))
1806 QNIN(I,NK,J) = MAX(0.,QNIN1D(K))
1807 ENDDO
1808 ENDDO
1809 ENDDO
1811 END SUBROUTINE MP_NTU
1812 !======================================================================
1813 !
1814 !======================================================================
1815 SUBROUTINE NTU_MICRO(TK3D,QV3D,DZ3D,P3D,S3D,W3D,SR,ICENCV,VINCV, &
1816 VSNCV,VGNCV,FINCV,FSNCV,AINCV,ASNCV,AGNCV,AHNCV, &
1817 I3MNCV,CLODNCV,RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAPNC, &
1818 GRAPNCV,HAILNC,HAILNCV,DT,DTMN,QC3D,QR3D,QI3D,QS3D, &
1819 QG3D,QH3D,NC3D,NR3D,NI3D,NS3D,NG3D,NH3D,VI3D,VS3D, &
1820 VG3D,FI3D,FS3D,AI3D,AS3D,AG3D,AH3D,I3M3D,QDCN3D, &
1821 QTCN3D,QCCN3D,QRCN3D,QNIN3D,KTS,KTE)
1822 !======================================================================
1823 IMPLICIT NONE
1824 INTEGER, INTENT(IN) :: KTS,KTE
1825 INTEGER :: K,A,IV,IV0,IV1,IV2,IV3,IV4,IM,IT,J
1826 INTEGER, DIMENSION(KTS:KTE) :: HID
1827 REAL, DIMENSION(KTS:KTE), INTENT(IN) :: W3D,P3D
1828 REAL, DIMENSION(KTS:KTE) :: TK3D,TC3D,QV3D,DZ3D,S3D,QC3D,QR3D, &
1829 QI3D,QS3D,QG3D,QH3D,QDCN3D,QTCN3D,QCCN3D,QRCN3D,QNIN3D, &
1830 NC3D,NR3D,NI3D,NS3D,NG3D,NH3D,VI3D,VS3D,VG3D,FI3D,FS3D, &
1831 AI3D,AS3D,AG3D,AH3D,I3M3D,TAIR,PRES,QVAP,ADAGR,AMI,BMI,AVI,&
1832 BVI,AMS,AVS,BVS,AMG,AVG,BVG,AVH,BVH,INHGR,DCLDMT,DCLDMC, &
1833 DCLDMR,DTAIR,DPDT,DQVAP,QACac,QACar,VT_QC,VT_QR,VT_QI, &
1834 VT_QS,VT_QG,VT_QH,VT_NC,VT_NR,VT_NI,VT_NS,VT_NG,VT_NH, &
1835 VT_VI,VT_VS,VT_VG,VT_FI,VT_FS,VT_AI,VT_AS,VT_AG,VT_AH, &
1836 VTI3M,TK0,P40,RHO,CPM,GQCTR,ESW,ESI,QVSW,QVSI,SSRW,SSRI, &
1837 XXLV,XXLS,XXLF,XDNC,XDNR,IPF,IPG,I3M0,ZETA,BEST,MVRC,MVRR, &
1838 SIGC,MNRC,KDX,BDR,BDI,BDS,BDG,BDH,R3M3D,S3M3D,G3M3D,H3M3D, &
1839 FDI,FDS,FDG,FDH,RHOI,RHOS,RHOG,IASPR,SASPR,MVDC,MVDR,MVDI, &
1840 MVDS,MVDG,MVDH,EFRC,EFRR,AFAC,AFAR,AFAI,AFAS,AFAG,AFAH, &
1841 LAMC,LAMR,LAMI,LAMS,LAMG,LAMH,LTK,LQC,LQR,LQI,LQS,LQG,LQH, &
1842 MDI,MDS,MDG
1843 REAL :: SR,ICENCV,CLODNCV,RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAPNC, &
1844 GRAPNCV,HAILNC,HAILNCV,DT,DTMN,SDTL,SDTS,DTL,DTS,CNDMAX, &
1845 TMP,XMASS,TEMPC,TEMPR,TEMPT,FINCV,FSNCV,VINCV,VSNCV, &
1846 VGNCV,AINCV,ASNCV,AGNCV,AHNCV,I3MNCV
1847 REAL, DIMENSION(KTS:KTE,3) :: VTMEAN
1848 LOGICAL, DIMENSION(KTS:KTE,NAER) :: DO_FR ! re-construct r-cutoff from XA & XC for once only
1849 REAL, DIMENSION(KTS:KTE,NAER) :: RX0 ! CUTOFF RADIUS (m)
1850 REAL, DIMENSION(KTS:KTE,NAERT) :: AERO ! AEROSOL MIXING RATIO
1851 REAL, DIMENSION(MAER) :: ABCD
1852 REAL, DIMENSION(NCCN,KTS:KTE,NAER) :: ZCCNS ! AEROSOL # OF EACH MODE (#/kg)
1854 !----- AT SUBSATURATION, REMOVE SMALL AMOUNTS OF HYDROMETEORS ----------
1855 DO K = KTS,KTE
1856 AERO(K,1) = MAX(0.,QDCN3D(K))
1857 AERO(K,2) = MAX(0.,QTCN3D(K))
1858 AERO(K,3) = MAX(0.,QCCN3D(K))
1859 AERO(K,4) = MAX(0.,QRCN3D(K))
1860 AERO(K,5) = MAX(0.,QNIN3D(K))
1861 TC3D(K) = TK3D(K)-TK0C
1862 ESW(K) = MIN(0.99*P3D(K),POLYSVP(TK3D(K),0))
1863 ESI(K) = MIN(0.99*P3D(K),POLYSVP(TK3D(K),1))
1864 IF (ESI(K).GT.ESW(K)) ESI(K) = ESW(K)
1865 SSRW(K) = QV3D(K)/(0.622*ESW(K)/(P3D(K)-ESW(K)))-1.
1866 SSRI(K) = QV3D(K)/(0.622*ESI(K)/(P3D(K)-ESI(K)))-1.
1867 XXLV(K) = 3.1484E6-2370.*TK3D(K)
1868 XXLS(K) = 3.15E6-2370.*TK3D(K)+0.3337E6
1869 XXLF(K) = 2836310.8-(3.1484E6-2370.*TK3D(K))
1870 CPM(K) = CP*(1.+0.887*QV3D(K))
1871 HID(K) = MAX(MIN(NINT(ABS(TC3D(K))/0.25),120),0)
1872 !-------------------------------------------------------------------------
1873 IF (QC3D(K).GE.QSMALL.AND.NC3D(K).LT.NSMALL) THEN
1874 LTK(K) = LOG(TK3D(K))
1875 LQC(K) = -1.*LOG(QC3D(K))
1876 NC3D(K) = EXP(DNC0+DNC1*LTK(K)+DNC2*LTK(K)**2.+DNC3* &
1877 LTK(K)**3.-0.25*LQC(K))
1878 IF (AFAC_3M.EQ.0) THEN
1879 AFAC(K) = AFAC0
1880 ELSEIF (AFAC_3M.EQ.1) THEN
1881 MVRC(K) = (QC3D(K)/NC3D(K)/C4PI3W)**THRD
1882 MVRC(K) = MIN(MAX(MVRC(K),RCMIN),RCMAX)
1883 EFRC(K) = EXP(EFC1+EFC2*LOG(NC3D(K))+EFC3*LOG(MVRC(K)))
1884 KDX(K) = MAX(KCCMIN,MIN(KCCMAX,(MVRC(K)/EFRC(K))**3.))
1885 ! KDX(K) = QC3D(K)*V2M3/(8.*EFRC(K)**3.*NC3D(K)*RHOW)
1886 KDX(K) = MIN(KCCMAX,MAX(KCCMIN,KDX(K)))
1887 AFAC(K) = (6.*KDX(K)-3.+SQRT(8.*KDX(K)+1.))/(2.-2.* &
1888 KDX(K))
1889 AFAC(K) = MIN(MAX(AFAC(K),AFAMIN),AFAMAX)
1890 ELSEIF (AFAC_3M.EQ.2) THEN
1891 SIGC(K) = EXP(SIG1+SIG2*LOG(NC3D(K))+SIG3*LOG(QC3D(K)))
1892 MNRC(K) = EXP(MNR1+MNR2*LOG(NC3D(K))+MNR3*LOG(QC3D(K)))
1893 AFAC(K) = MIN(MAX(SIGC(K)/MNRC(K),AFAMIN),AFAMAX)
1894 ENDIF
1895 ENDIF
1896 IF (QR3D(K).GE.QSMALL.AND.NR3D(K).LT.NSMALL) THEN
1897 LTK(K) = LOG(TK3D(K))
1898 LQR(K) = -1.*LOG(QR3D(K))
1899 NR3D(K) = EXP(-5793.7852+3191.1171*LTK(K)-582.73279* &
1900 LTK(K)**2.+35.346854*LTK(K)**3.-0.25*LQR(K))
1901 IF (AFAR_3M.EQ.0) THEN
1902 AFAR(K) = AFAR0
1903 ELSEIF (AFAR_3M.EQ.1) THEN
1904 MVRR(K) = (QR3D(K)/NR3D(K)/C4PI3W)**THRD
1905 MVRR(K) = MIN(RRMAX,MAX(RRMIN,MVRR(K)))
1906 EFRR(K) = EXP(EFR1+EFR2*LOG(NR3D(K))+EFR3*LOG(MVRR(K)))
1907 KDX(K) = MAX(KCRMIN,MIN(KCRMAX,(MVRR(K)/EFRR(K))**3.))
1908 ! KDX(K) = QR3D(K)*V2M3/(8.*EFRR(K)**3.*NR3D(K)*RHOW)
1909 KDX(K) = MIN(KCRMAX,MAX(KCRMIN,KDX(K)))
1910 AFAR(K) = (6.*KDX(K)-3.+SQRT(8.*KDX(K)+1.))/(2.-2.* &
1911 KDX(K))
1912 AFAR(K) = MIN(MAX(AFAR(K),AFAMIN),AFAMAX)
1913 ELSEIF (AFAR_3M.EQ.2) THEN
1914 BDR(K) = (QR3D(K)*V2M3/RHOW/NR3D(K))**THRD
1915 BDR(K) = MIN(MAX(BDR(K),DRMIN),DRMAX)
1916 AFAR(K) = MAX(AFAMIN,19.*TANH(0.6*(1.E3*BDR(K)-1.8))+17.)
1917 ENDIF
1918 ENDIF
1919 IF (QI3D(K).GE.QSMALL.AND.NI3D(K).LT.NSMALL) THEN
1920 IF (ICE_RHOI.EQ.0) THEN
1921 RHOI(K) = RHOI0
1922 VI3D(K) = 0.
1923 ELSEIF (ICE_RHOI.EQ.1) THEN
1924 QVSI(K) = 0.622*ESI(K)/(P3D(K)-ESI(K))
1925 INHGR(K) = ITBLE(HID(K))
1926 RHOI(K) = RHOI0*EXP(-3.*MAX((QV3D(K)-QVSI(K))-5.E-5, &
1927 0.)/INHGR(K))
1928 VI3D(K) = QI3D(K)/RHOI(K)
1929 ELSEIF (ICE_RHOI.EQ.2) THEN
1930 RHOI(K) = RHOI1
1931 VI3D(K) = 0.
1932 ENDIF
1933 LTK(K) = LOG(TK3D(K))
1934 LQI(K) = -1.*LOG(QI3D(K))
1935 MDI(K) = EXP(-3.2653646+2.0539073*LTK(K)-0.25*LQI(K))/1.E3
1936 NI3D(K) = 1.E9*QI3D(K)*V2M3/RHOI(K)/MDI(K)**3.
1937 I3M3D(K) = QI3D(K)*V2M3/RHOI(K)
1938 IF (ICE_SHAPE.EQ.0) THEN
1939 FI3D(K) = I3M3D(K)
1940 ELSEIF (ICE_SHAPE.EQ.1) THEN
1941 ADAGR(K) = (MAX(MIN(ITBLE(HID(K)),2.),0.5))**THRD
1942 ZETA(K) = (ADAGR(K)-1.)/(ADAGR(K)+2.)
1943 I3M0(K) = NI3D(K)*DI0**3.
1944 FI3D(K) = (I3M3D(K)/I3M0(K))**ZETA(K)*I3M3D(K)
1945 ENDIF
1946 IF (AFAI_3M.EQ.0) THEN
1947 AFAI(K) = AFAI0
1948 AI3D(K) = 0.
1949 ELSE
1950 BDI(K) = (I3M3D(K)/NI3D(K))**THRD*1.E3
1951 BDI(K) = MIN(MAX(BDI(K),DIMIN*1.E3),DIMAX*1.E3)
1952 FDI(K) = 7.4015986E-2+0.79866676*BDI(K)-9.4468892E-3* &
1953 LOG(NI3D(K))+0.38235092*BDI(K)**2.+ &
1954 2.9811542E-4*LOG(NI3D(K))**2.+1.9052614E-2* &
1955 BDI(K)*LOG(NI3D(K))
1956 KDX(K) = MAX(KCIMIN,MIN(KCIMAX,(BDI(K)/FDI(K))**3.))
1957 AFAI(K) = (6.*KDX(K)-3.+SQRT(8.*KDX(K)+1.))/(2.-2.* &
1958 KDX(K))
1959 AFAI(K) = MIN(MAX(AFAI(K),AFAMIN),AFAMAX)
1960 ! AFAI(K) = MAX(AFAMIN,12.*TANH(0.7*(BDI(K)-1.7))+11.)
1961 IF (AFAI_3M.EQ.1) THEN
1962 KDX(K) = (AFAI(K)**2.+3.*AFAI(K)+2.)/(AFAI(K)**2.+ &
1963 6.*AFAI(K)+9.)
1964 AI3D(K) = (KDX(K)*NI3D(K)*I3M3D(K)**2.)**THRD
1965 ELSEIF (AFAI_3M.EQ.2) THEN
1966 AI3D(K) = 0.
1967 ENDIF
1968 ENDIF
1969 ENDIF
1970 IF (QS3D(K).GE.QSMALL.AND.NS3D(K).LT.NSMALL) THEN
1971 IF (ICE_RHOS.EQ.0) THEN
1972 RHOS(K) = RHOS0
1973 VS3D(K) = 0.
1974 ELSE
1975 LTK(K) = LOG(TK3D(K))
1976 LQS(K) = -1.*LOG(QS3D(K))
1977 IF (TK3D(K).LT.TK0C) THEN
1978 RHOS(K) = 15740.702-6098.0087*LTK(K)+503.33089* &
1979 LQS(K)+594.29913*LTK(K)**2.+1.9033961* &
1980 LQS(K)**2.-94.950429*LTK(K)*LQS(K)
1981 ELSE
1982 RHOS(K) = EXP(-64808.666+23113.508*LTK(K)-36.46632* &
1983 LQS(K)-2060.6024*LTK(K)**2.-0.005729458* &
1984 LQS(K)**2.+6.5057411*LTK(K)*LQS(K))
1985 ENDIF
1986 RHOS(K) = MIN(RHOIMAX,MAX(RHOIMIN,RHOS(K)))
1987 IF (ICE_RHOS.EQ.1) THEN
1988 VS3D(K) = QS3D(K)/RHOS(K)
1989 ELSEIF (ICE_RHOS.EQ.2) THEN
1990 VS3D(K) = 0.
1991 ENDIF
1992 ENDIF
1993 LTK(K) = LOG(TK3D(K))
1994 LQS(K) = -1.*LOG(QS3D(K))
1995 MDS(K) = EXP(-123.23898+40.74706*LTK(K)-3.0333477* &
1996 LTK(K)**2.-0.31219981*LQS(K)+0.0012798222* &
1997 LQS(K)**2.)/1.E3
1998 NS3D(K) = 1.E9*QS3D(K)*V2M3/RHOS(K)/MDS(K)**3.
1999 S3M3D(K) = QS3D(K)*V2M3/RHOS(K)
2000 IF (AGG_SHAPE.EQ.0) THEN
2001 SASPR(K) = 1.
2002 FS3D(K) = 0.
2003 ELSEIF (AGG_SHAPE.EQ.1) THEN
2004 SASPR(K) = 0.7
2005 FS3D(K) = SASPR(K)*S3M3D(K)
2006 ENDIF
2007 IF (AFAS_3M.EQ.0) THEN
2008 AFAS(K) = AFAS0
2009 AS3D(K) = 0.
2010 ELSE
2011 BDS(K) = (S3M3D(K)/NS3D(K))**THRD*1.E3
2012 BDS(K) = MIN(MAX(BDS(K),DSMIN*1.E3),DSMAX*1.E3)
2013 IF (TK3D(K).GE.TK0C) THEN
2014 FDS(K) = -0.21911541+1.2739845*BDS(K)+0.10141003* &
2015 LOG(NS3D(K))+0.30063818*BDS(K)**2.- &
2016 4.3857765E-3*LOG(NS3D(K))**2.-0.078801732* &
2017 BDS(K)*LOG(NS3D(K))
2018 ELSE
2019 IF (QC3D(K).GE.1.E-8) THEN
2020 FDS(K) = -1.1527014+2.9067645*BDS(K)+0.25316062* &
2021 LOG(NS3D(K))-0.17768557*BDS(K)**2.- &
2022 0.013117292*LOG(NS3D(K))**2.-0.17020429* &
2023 BDS(K)*LOG(NS3D(K))
2024 ELSE
2025 FDS(K) = -0.2813929+1.7275463*BDS(K)+0.045550156* &
2026 LOG(NS3D(K))-0.16526226*BDS(K)**2.- &
2027 1.7699916E-3*LOG(NS3D(K))**2.- &
2028 4.6441257E-2*BDS(K)*LOG(NS3D(K))
2029 ENDIF
2030 ENDIF
2031 KDX(K) = MAX(KCSMIN,MIN(KCSMAX,(BDS(K)/FDS(K))**3.))
2032 AFAS(K) = (6.*KDX(K)-3.+SQRT(8.*KDX(K)+1.))/(2.-2.* &
2033 KDX(K))
2034 AFAS(K) = MIN(MAX(AFAS(K),AFAMIN),AFAMAX)
2035 ! AFAS(K) = MAX(AFAMIN,4.5*TANH(0.5*(BDS(K)-5.))+5.5)
2036 IF (AFAS_3M.EQ.1) THEN
2037 KDX(K) = (AFAS(K)**2.+3.*AFAS(K)+2.)/(AFAS(K)**2.+ &
2038 6.*AFAS(K)+9.)
2039 AS3D(K) = (KDX(K)*NS3D(K)*S3M3D(K)**2.)**THRD
2040 ELSEIF (AFAS_3M.EQ.2) THEN
2041 AS3D = 0.
2042 ENDIF
2043 ENDIF
2044 ENDIF
2045 IF (QG3D(K).GE.QSMALL.AND.NG3D(K).LT.NSMALL) THEN
2046 IF (ICE_RHOG.EQ.0) THEN
2047 RHOG(K) = RHOG1
2048 VG3D(K) = 0.
2049 ELSEIF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
2050 LTK(K) = LOG(TK3D(K))
2051 LQG(K) = -1.*LOG(QG3D(K))
2052 IF (TK3D(K).LT.TK0C) THEN
2053 RHOG(K) = EXP(-509.23219+187.98419*LTK(K)+1.5493489* &
2054 LQG(K)-17.147561*LTK(K)**2.-0.005829723* &
2055 LQG(K)**2.-0.26664109*LTK(K)*LQG(K))
2056 ELSE
2057 RHOG(K) = EXP(-2894.6795+1050.5173*LTK(K)-11.536497* &
2058 LQG(K)-95.054373*LTK(K)**2.-0.001986964* &
2059 LQG(K)**2.+2.0502147*LTK(K)*LQG(K))
2060 ENDIF
2061 VG3D(K) = QG3D(K)/RHOG(K)
2062 ENDIF
2063 LTK(K) = LOG(TK3D(K))
2064 LQG(K) = -1.*LOG(QG3D(K))
2065 MDG(K) = EXP(-2205.8027+1225.8046*LTK(K)-226.27995* &
2066 LTK(K)**2.+13.929644*LTK(K)**3.-0.25*LQG(K))/1.E3
2067 NG3D(K) = 1.E9*QG3D(K)*V2M3/RHOG(K)/MDG(K)**3.
2068 G3M3D(K) = QG3D(K)*V2M3/RHOG(K)
2069 IF (AFAG_3M.EQ.0) THEN
2070 AFAG(K) = AFAG0
2071 AG3D(K) = 0.
2072 ELSE
2073 BDG(K) = (G3M3D(K)/NG3D(K))**THRD*1.E3
2074 BDG(K) = MIN(MAX(BDG(K),DGMIN*1.E3),DGMAX*1.E3)
2075 IF (TK3D(K).GE.TK0C) THEN
2076 FDG(K) = 0.58006354+0.79661229*BDG(K)-0.18394382* &
2077 LOG(NG3D(K))+6.7371044E-2*BDG(K)**2.+ &
2078 9.832945E-3*LOG(NG3D(K))**2.+0.12433055* &
2079 BDG(K)*LOG(NG3D(K))
2080 ELSE
2081 IF (QC3D(K).GE.1.E-8) THEN
2082 FDG(K) = 0.17363469+1.5044291*BDG(K)-0.050639722* &
2083 LOG(NG3D(K))+1.5101052E-2*BDG(K)**2.+ &
2084 2.5974719E-3*LOG(NG3D(K))**2.+0.01961464*&
2085 BDG(K)*LOG(NG3D(K))
2086 ELSE
2087 FDG(K) = 0.59259317-0.89933515*BDG(K)+2.0893032* &
2088 BDG(K)**2.-0.50305755*BDG(K)**3.- &
2089 2.2446793E-2*LOG(NG3D(K))+2.7589047E-3* &
2090 LOG(NG3D(K))**2.
2091 ENDIF
2092 ENDIF
2093 KDX(K) = MAX(KCGMIN,MIN(KCGMAX,(BDG(K)/FDG(K))**3.))
2094 AFAG(K) = (6.*KDX(K)-3.+SQRT(8.*KDX(K)+1.))/(2.-2.* &
2095 KDX(K))
2096 AFAG(K) = MIN(MAX(AFAG(K),AFAMIN),AFAMAX)
2097 ! AFAG(K) = MAX(AFAMIN,5.5*TANH(0.7*(BDG(K)-4.5))+8.5)
2098 IF (AFAG_3M.EQ.1) THEN
2099 KDX(K) = (AFAG(K)**2.+3.*AFAG(K)+2.)/(AFAG(K)**2.+ &
2100 6.*AFAG(K)+9.)
2101 AG3D(K) = (KDX(K)*NG3D(K)*G3M3D(K)**2.)**THRD
2102 ELSEIF (AFAG_3M.EQ.2) THEN
2103 AG3D = 0.
2104 ENDIF
2105 ENDIF
2106 ENDIF
2107 IF (QH3D(K).GE.QSMALL.AND.NH3D(K).LT.NSMALL) THEN
2108 LTK(K) = LOG(TK3D(K))
2109 LQH(K) = -1.*LOG(QH3D(K))
2110 NH3D(K) = EXP(22.929406-4.2328364*LTK(K)+0.30647567* &
2111 LTK(K)**2.-0.009233271*LTK(K)**3.-0.25*LQH(K))
2112 H3M3D(K) = QH3D(K)*V2M3/RHOH
2113 IF (AFAH_3M.EQ.0) THEN
2114 AFAH(K) = AFAH0
2115 AH3D(K) = 0.
2116 ELSE
2117 BDH(K) = (H3M3D(K)/NH3D(K))**THRD*1.E3
2118 BDH(K) = MIN(MAX(BDH(K),DHMIN*1.E3),DHMAX*1.E3)
2119 IF (TK3D(K).GE.TK0C) THEN
2120 FDH(K) = 1.157754+0.37852874*BDH(K)-0.11129737* &
2121 LOG(NH3D(K))+0.13929599*BDH(K)**2.+ &
2122 8.1105237E-3*LOG(NH3D(K))**2.+5.7432113E-2* &
2123 BDH(K)*LOG(NH3D(K))
2124 ELSE
2125 FDH(K) = -0.48246793+2.0407077*BDH(K)+0.022262969* &
2126 LOG(NH3D(K))-0.158389*BDH(K)**2.- &
2127 5.5545804E-3*LOG(NH3D(K))**2.+2.9443577E-2* &
2128 BDH(K)*LOG(NH3D(K))
2129 ENDIF
2130 KDX(K) = MAX(KCHMIN,MIN(KCHMAX,(BDH(K)/FDH(K))**3.))
2131 AFAH(K) = (6.*KDX(K)-3.+SQRT(8.*KDX(K)+1.))/(2.-2.* &
2132 KDX(K))
2133 AFAH(K) = MIN(MAX(AFAH(K),AFAMIN),AFAMAX)
2134 ! AFAH(K) = MAX(AFAMIN,3.7*TANH(0.3*(BDH(K)-9.))+6.5)
2135 IF (AFAH_3M.EQ.1) THEN
2136 KDX(K) = (AFAH(K)**2.+3.*AFAH(K)+2.)/(AFAH(K)**2.+ &
2137 6.*AFAH(K)+9.)
2138 AH3D(K) = (KDX(K)*NH3D(K)*H3M3D(K)**2.)**THRD
2139 ELSEIF (AFAH_3M.EQ.2) THEN
2140 AH3D(K) = 0.
2141 ENDIF
2142 ENDIF
2143 ENDIF
2144 !-----------------------------------------------------------------------------
2145 IF (SSRW(K).LT.-1.E-1) THEN
2146 IF (QR3D(K).LT.QSMAL1) THEN
2147 QV3D(K) = QV3D(K)+QR3D(K)
2148 TK3D(K) = TK3D(K)-QR3D(K)*XXLV(K)/CPM(K)
2149 QR3D(K) = 0.; NR3D(K) = 0.
2150 ENDIF
2151 IF (QC3D(K).LT.QSMAL1) THEN
2152 QV3D(K) = QV3D(K)+QC3D(K)
2153 TK3D(K) = TK3D(K)-QC3D(K)*XXLV(K)/CPM(K)
2154 QC3D(K) = 0.; NC3D(K) = 0.
2155 ENDIF
2156 ENDIF
2157 IF (SSRI(K).LT.-1.E-1) THEN
2158 IF (QI3D(K).LT.QSMAL1) THEN
2159 QV3D(K) = QV3D(K)+QI3D(K)
2160 TK3D(K) = TK3D(K)-QI3D(K)*XXLS(K)/CPM(K)
2161 QI3D(K) = 0.; NI3D(K) = 0.; I3M3D(K) = 0.; FI3D(K) = 0.
2162 VI3D(K) = 0.; AI3D(K) = 0.
2163 ENDIF
2164 IF (QS3D(K).LT.QSMAL1) THEN
2165 QV3D(K) = QV3D(K)+QS3D(K)
2166 TK3D(K) = TK3D(K)-QS3D(K)*XXLS(K)/CPM(K)
2167 QS3D(K) = 0.; NS3D(K) = 0.; VS3D(K) = 0.; AS3D(K) = 0.
2168 FS3D(K) = 0.
2169 ENDIF
2170 IF (QG3D(K).LT.QSMAL1) THEN
2171 QV3D(K) = QV3D(K)+QG3D(K)
2172 TK3D(K) = TK3D(K)-QG3D(K)*XXLS(K)/CPM(K)
2173 QG3D(K) = 0.; NG3D(K) = 0.; VG3D(K) = 0.; AG3D(K) = 0.
2174 ENDIF
2175 IF (QH3D(K).LT.QSMAL1) THEN
2176 QV3D(K) = QV3D(K)+QH3D(K)
2177 TK3D(K) = TK3D(K)-QH3D(K)*XXLS(K)/CPM(K)
2178 QH3D(K) = 0.; NH3D(K) = 0.; AH3D(K) = 0.
2179 ENDIF
2180 ENDIF
2181 !----- MELT VERY SMALL SNOW/GRAUPEL/HAIL MIXING RATIOS, ADD TO RAIN ----
2182 IF (TK3D(K).GE.TK0C.AND.QS3D(K).LT.QLIMIT) THEN
2183 QR3D(K) = QR3D(K)+QS3D(K)
2184 NR3D(K) = NR3D(K)+NS3D(K)
2185 TK3D(K) = TK3D(K)-QS3D(K)*XXLF(K)/CPM(K)
2186 QS3D(K) = 0.; NS3D(K) = 0.; VS3D(K) = 0.; AS3D(K) = 0.
2187 FS3D(K) = 0.
2188 ENDIF
2189 IF (TK3D(K).GE.TK0C.AND.QG3D(K).LT.QLIMIT) THEN
2190 QR3D(K) = QR3D(K)+QG3D(K)
2191 NR3D(K) = NR3D(K)+NG3D(K)
2192 TK3D(K) = TK3D(K)-QG3D(K)*XXLF(K)/CPM(K)
2193 QG3D(K) = 0.; NG3D(K) = 0.; VG3D(K) = 0.; AG3D(K) = 0.
2194 ENDIF
2195 IF (TK3D(K).GE.TK0C.AND.QH3D(K).LT.QLIMIT) THEN
2196 QR3D(K) = QR3D(K)+QH3D(K)
2197 NR3D(K) = NR3D(K)+NH3D(K)
2198 TK3D(K) = TK3D(K)-QH3D(K)*XXLF(K)/CPM(K)
2199 QH3D(K) = 0.; NH3D(K) = 0.; AH3D(K) = 0.
2200 ENDIF
2201 ENDDO
2202 !------- INITIALIZE VARIABLE,ONLY T&QV ARE TREATED DIFFERENTLY ---------
2203 DO K = KTS,KTE
2204 TAIR(K) = TK3D(K)
2205 QVAP(K) = QV3D(K)
2206 DTAIR(K) = -W3D(K)*G/CP ! Lagrangian parcel dry adiabatic lapse rate
2207 DQVAP(K) = 0.
2208 PRES(K) = P3D(K)
2209 TK0(K) = TAIR(K)-DTAIR(K)*DT ! diabatically decend parcel
2210 P40(K) = PRES(K)*(TK0(K)/TAIR(K))**(CP/R)
2211 TAIR(K) = TK0(K)
2212 IV1 = 1
2213 DO IV = 1,NAER
2214 IV2 = IV1+1
2215 DO_FR(K,IV) = .TRUE. ! FIND CUT OFF RADIUS
2216 RX0(K,IV) = 99. ! initial R cutoff
2217 IF (NAERN(IV).GE.2) THEN ! have info of dry and total aerosol
2218 AERO(K,IV1) = MIN(AERO(K,IV1),AERO(K,IV2)) ! dry aerosol < total aerosol
2219 DO IM = 1,NCCN ! calculate CCN # [#/kg] from CCN mass
2220 ZCCNS(IM,K,IV) = AERO(K,IV2)*WMAS(IM,IV)*RFACT(IM,IV)
2221 ENDDO
2222 ELSE ! only info available is total aerosol
2223 DO IM = 1,NCCN ! calculate CCN # [#/kg] from CCN mass
2224 ZCCNS(IM,K,IV) = AERO(K,IV1)*WMAS(IM,IV)*RFACT(IM,IV)
2225 ENDDO
2226 ENDIF
2227 IV1 = IV1+NAERN(IV)
2228 ENDDO
2229 ENDDO ! INITILIZATION LOOPS
2231 SDTL = 0. ! initial integrated largedt timestep
2232 DO IT = 1,INT((DT-DT20S*0.01)/DT20S)+1
2233 DTL = MIN(DT20S,DT-SDTL) ! initial largedt timestep
2234 DO K = KTS,KTE
2235 DTS = DTL ! initial smalldt timestep (could be changed later)
2236 SDTS = 0. ! initial integrated smalldt timestep
2237 TMP = W3D(K)*G/CP/TK0(K) ! 1-TAIR/TK0
2238 XDNC(K) = 0.; XDNR(K) = 0.; GQCTR(K) = 0.; ADAGR(K) = 1.
2239 RHOI(K) = RHOI0; RHOS(K) = RHOS0; RHOG(K) = RHOG0
2240 AFAC(K) = AFAC0; AFAR(K) = AFAR0; AFAI(K) = AFAI0
2241 AFAS(K) = AFAS0; AFAG(K) = AFAG0; AFAH(K) = AFAH0
2242 AVI(K) = AVI0; BVI(K) = BVI0; AVS(K) = AVS0; BVS(K) = BVS0
2243 AVG(K) = AVG0; BVG(K) = BVG0; AVH(K) = AVH0; BVH(K) = BVH0
2244 AMI(K) = AMI0; BMI(K) = BMI0; AMS(K) = AMS0; AMG(K) = AMG0
2245 IASPR(K) = 1.; SASPR(K) = 1.; QACac(K) = 0.; QACar(K) = 0.
2246 111 CONTINUE
2248 PRES(K) = P40(K)*(1.-TMP*(SDTL+SDTS))**(CP/R)
2249 DPDT(K) = -G*W3D(K)*PRES(K)/(R*TK0(K)*(1.-TMP*(SDTL+SDTS)))
2250 ESW(K) = MIN(0.99*PRES(K),POLYSVP(TAIR(K),0))
2251 ESI(K) = MIN(0.99*PRES(K),POLYSVP(TAIR(K),1))
2252 IF (ESI(K).GT.ESW(K)) ESI(K) = ESW(K)
2253 QVSW(K) = 0.622*ESW(K)/(PRES(K)-ESW(K))
2254 QVSI(K) = 0.622*ESI(K)/(PRES(K)-ESI(K))
2255 SSRW(K) = QVAP(K)/QVSW(K)-1.
2256 SSRI(K) = QVAP(K)/QVSI(K)-1.
2257 XXLV(K) = 3.1484E6-2370.*TAIR(K)
2258 CPM(K) = CP*(1.+0.887*QVAP(K))
2259 RHO(K) = PRES(K)/(TAIR(K)*(1.+0.61*QVAP(K)))/R ! [KG/M**3]
2260 CNDMAX = (QVAP(K)-QVSW(K))/(1.+XXLV(K)**2.*QVAP(K)/ &
2261 (CPM(K)*RV*TAIR(K)**2.))
2262 !--------------------------- CCN ACTIVATION. ---------------------------
2263 IF (SSRW(K).GT.RSMALL.AND.SSRW(K).GT.S3D(K)) THEN
2264 DCLDMT(K) = 0.; DCLDMC(K) = 0.; DCLDMR(K) = 0.
2265 IV1 = 1
2266 DO IV = 1,NAER
2267 DO J = 1,NAERN(IV)
2268 ABCD(J) = AERO(K,IV1-1+J)
2269 ENDDO
2270 IF (AERO(K,IV1).GT.1.E-20.AND.NAERN(IV).GE.2.AND. &
2271 W3D(K).GT.1.E-5) THEN
2272 CALL ACTIVA(TAIR(K),W3D(K),NC3D(K),NR3D(K),ABCD, &
2273 QACac(K),QACar(K),RX0(K,IV),ZCCNS(1,K,IV), &
2274 SSRW(K),IV,DO_FR(K,IV))
2275 DCLDMC(K) = DCLDMC(K)+QACac(K)
2276 DCLDMR(K) = DCLDMR(K)+QACar(K)
2277 DO J = 1,NAERN(IV)
2278 AERO(K,IV1-1+J) = ABCD(J)
2279 ENDDO
2280 ENDIF
2281 IV1 = IV1+NAERN(IV)
2282 ENDDO
2283 DCLDMT(K) = DCLDMC(K)+DCLDMR(K)
2284 IF (DCLDMT(K).GT.RLIMIT) THEN
2285 IF (DCLDMT(K).GT.CNDMAX) THEN
2286 DCLDMC(K) = DCLDMC(K)*(CNDMAX/DCLDMT(K))
2287 DCLDMR(K) = DCLDMR(K)*(CNDMAX/DCLDMT(K))
2288 DCLDMT(K) = DCLDMC(K)+DCLDMR(K)
2289 ENDIF
2290 QVAP(K) = MAX(0.,QVAP(K)-DCLDMT(K))
2291 QC3D(K) = MAX(0.,QC3D(K)+DCLDMC(K))
2292 QR3D(K) = MAX(0.,QR3D(K)+DCLDMR(K))
2293 CPM(K) = CP*(1.+0.887*QVAP(K))
2294 XXLV(K) = 3.1484E6-2370.*TAIR(K)
2295 TAIR(K) = TAIR(K)+XXLV(K)*DCLDMT(K)/CPM(K)
2296 ENDIF
2297 ESW(K) = MIN(0.99*PRES(K),POLYSVP(TAIR(K),0))
2298 ESI(K) = MIN(0.99*PRES(K),POLYSVP(TAIR(K),1))
2299 IF (ESI(K).GT.ESW(K)) ESI(K) = ESW(K)
2300 SSRW(K) = QVAP(K)/(0.622*ESW(K)/(PRES(K)-ESW(K)))-1.
2301 SSRI(K) = QVAP(K)/(0.622*ESI(K)/(PRES(K)-ESI(K)))-1.
2302 RHO(K) = PRES(K)/(TAIR(K)*(1.+0.61*QVAP(K)))/R
2303 ENDIF
2304 S3D(K) = MAX(S3D(K),SSRW(K))
2305 !------------------------- ICE NUCLEATION ------------------------------
2306 IF (TAIR(K).LT.(TK0C-2.).AND.SSRI(K).GT.1.E-4) THEN
2307 CALL ICENU(TAIR(K),PRES(K),DTS,RHO(K),QVAP(K),QI3D(K), &
2308 NI3D(K),VI3D(K),FI3D(K),AI3D(K),I3M3D(K),AERO(K,5))
2309 ESW(K) = MIN(0.99*PRES(K),POLYSVP(TAIR(K),0))
2310 ESI(K) = MIN(0.99*PRES(K),POLYSVP(TAIR(K),1))
2311 IF (ESI(K).GT.ESW(K)) ESI(K) = ESW(K)
2312 SSRW(K) = QVAP(K)/(0.622*ESW(K)/(PRES(K)-ESW(K)))-1.
2313 SSRI(K) = QVAP(K)/(0.622*ESI(K)/(PRES(K)-ESI(K)))-1.
2314 RHO(K) = PRES(K)/(TAIR(K)*(1.+0.61*QVAP(K)))/R
2315 ENDIF
2316 !-----------MICROPHYSICAL TENDENCY CALCULATION IN SMALL TIMESTEP -------
2317 IF (QC3D(K).GE.QSMALL.OR.QR3D(K).GE.QSMALL.OR.QI3D(K).GE. &
2318 QSMALL.OR.QS3D(K).GE.QSMALL.OR.QG3D(K).GE.QSMALL.OR. &
2319 QH3D(K).GE.QSMALL) THEN
2320 CALL SMALL_DT(DTL,DTS,SDTS,DTAIR(K),DQVAP(K),DPDT(K), &
2321 RHO(K),TAIR(K),PRES(K),QVAP(K),QC3D(K),QR3D(K), &
2322 QI3D(K),QS3D(K),QG3D(K),QH3D(K),NC3D(K),NR3D(K), &
2323 NI3D(K),NS3D(K),NG3D(K),NH3D(K),VI3D(K),VS3D(K), &
2324 VG3D(K),FI3D(K),FS3D(K),AI3D(K),AS3D(K),AG3D(K), &
2325 AH3D(K),I3M3D(K),SASPR(K),XDNC(K),XDNR(K),GQCTR(K))
2326 ENDIF
2327 !----------------- UPDATE TIME & PROGNOSTIC VARIABLES ------------------
2328 TAIR(K) = TAIR(K)+DTAIR(K)*DTS
2329 QVAP(K) = QVAP(K)+DQVAP(K)*DTS
2330 SDTS = SDTS+DTS
2332 IF (SDTS.GE.DTL) GOTO 333
2333 GOTO 111
2334 333 CONTINUE
2335 !----------------- RAIN DROP DEACTIVATION. -----------------------------
2336 IF (XDNR(K).GT.1.) THEN
2337 IV0 = 0
2338 DO IV = 1,NAER
2339 IF (NAERN(IV).EQ.4) THEN
2340 IV3 = IV0+3
2341 IV4 = IV0+4
2342 IF (NR3D(K).GT.1.) THEN
2343 XMASS = AERO(K,IV4)*MIN(1.,XDNR(K)/NR3D(K))
2344 ELSE
2345 XMASS = AERO(K,IV4)
2346 ENDIF
2347 AERO(K,IV3) = AERO(K,IV3)+XMASS
2348 AERO(K,IV4) = AERO(K,IV4)-XMASS
2349 ENDIF
2350 IV0 = IV0+NAERN(IV)
2351 ENDDO
2352 ENDIF
2353 !----------------- CLOUD DROP DEACTIVATION. ----------------------------
2354 IF (XDNC(K).GT.1.) THEN
2355 IV1 = 1
2356 DO IV = 1,NAER
2357 IV2 = IV1+1
2358 IV3 = IV2+1
2359 IF (NAERN(IV).GE.3) THEN
2360 IF (NC3D(K).GT.1.) THEN
2361 XMASS = AERO(K,IV3)*MIN(1.,XDNC(K)/NC3D(K))
2362 ELSE
2363 XMASS = AERO(K,IV3)
2364 ENDIF
2365 AERO(K,IV1) = AERO(K,IV1)+XMASS
2366 AERO(K,IV3) = AERO(K,IV3)-XMASS
2367 AERO(K,IV1) = MIN(AERO(K,IV1),AERO(K,IV2))
2368 ELSEIF (NAERN(IV).EQ.2) THEN
2369 CALL DEACTIVA(XDNC(K),QC3D(K),NC3D(K),AERO(K,IV1),&
2370 AERO(K,IV2),AERO(K,IV3),RX0(K,IV), &
2371 ZCCNS(1,K,IV),IV,DO_FR(K,IV))
2372 ELSE
2373 XMASS = AERO(K,IV1)*MIN(1.,XDNC(K)/ &
2374 (ZCCNS(2,K,IV)+ZCCNS(3,K,IV))) ! COARSE AND ACCUMULATION MODE
2375 AERO(K,IV1) = AERO(K,IV1)+XMASS
2376 ENDIF
2377 IV1 = IV1+NAERN(IV)
2378 ENDDO
2379 ENDIF
2380 PRES(K) = P40(K)*(1.-TMP*(SDTL+SDTS))**(CP/R)
2381 RHO(K) = PRES(K)/(TAIR(K)*(1.+0.61*QVAP(K)))/R
2382 ENDDO
2383 !-----------MICROPHYSICAL TENDENCY CALCULATION IN LARGE TIMESTEP -------
2384 DO K = KTS,KTE
2385 IF (QC3D(K).GE.QSMALL.OR.QR3D(K).GE.QSMALL.OR.QI3D(K).GE. &
2386 QSMALL.OR.QS3D(K).GE.QSMALL.OR.QG3D(K).GE.QSMALL.OR. &
2387 QH3D(K).GE.QSMALL) THEN
2388 CALL LARGE_DT(DTL,TAIR(K),QVAP(K),PRES(K),RHO(K), &
2389 QC3D(K),QR3D(K),QI3D(K),QS3D(K),QG3D(K),QH3D(K), &
2390 NC3D(K),NR3D(K),NI3D(K),NS3D(K),NG3D(K),NH3D(K), &
2391 VI3D(K),VS3D(K),VG3D(K),FI3D(K),FS3D(K),AI3D(K), &
2392 AS3D(K),AG3D(K),AH3D(K),I3M3D(K),SASPR(K),GQCTR(K))
2393 ENDIF
2394 IV0 = 0
2395 DO IV = 1,NAER ! for all aerosol compoment
2396 IF (NAERN(IV).GE.4) THEN ! with aerosol in cloud/precip. recored
2397 IV3 = IV0+3 ! aerosols in clouds ll
2398 IV4 = IV0+4 ! aerosols in rains
2399 IF (GQCTR(K).GT.0.) THEN ! + from cloud to precip.
2400 XMASS = GQCTR(K)*AERO(K,IV3) ! + from cloud to precip.
2401 ELSE ! - from precip. to cloud
2402 XMASS = GQCTR(K)*AERO(K,IV4) ! - from precip. to cloud
2403 ENDIF
2404 AERO(K,IV3) = AERO(K,IV3)-XMASS ! update aerosol in cloud
2405 AERO(K,IV4) = AERO(K,IV4)+XMASS ! update aerosol in precipi.
2406 ENDIF
2407 IV0 = IV0+NAERN(IV)
2408 ENDDO
2409 ENDDO
2410 SDTL = SDTL+DTL
2411 ENDDO ! FOR IT LOOPS
2412 !----- AT SUBSATURATION, REMOVE SMALL AMOUNTS OF HYDROMETEORS ----------
2413 DO K = KTS,KTE
2414 ESW(K) = MIN(0.99*PRES(K),POLYSVP(TAIR(K),0))
2415 ESI(K) = MIN(0.99*PRES(K),POLYSVP(TAIR(K),1))
2416 IF (ESI(K).GT.ESW(K)) ESI(K) = ESW(K)
2417 SSRW(K) = QVAP(K)/(0.622*ESW(K)/(PRES(K)-ESW(K)))-1.
2418 SSRI(K) = QVAP(K)/(0.622*ESI(K)/(PRES(K)-ESI(K)))-1.
2419 XXLV(K) = 3.1484E6-2370.*TAIR(K)
2420 XXLS(K) = 3.15E6-2.37E3*TAIR(K)+0.3337E6
2421 CPM(K) = CP*(1.+0.887*QVAP(K))
2422 IF (SSRW(K).LT.-1.E-1) THEN
2423 IF (QR3D(K).LT.QSMAL1) THEN
2424 QVAP(K) = QVAP(K)+QR3D(K)
2425 TAIR(K) = TAIR(K)-QR3D(K)*XXLV(K)/CPM(K)
2426 QR3D(K) = 0.; NR3D(K) = 0.
2427 ENDIF
2428 IF (QC3D(K).LT.QSMAL1) THEN
2429 QVAP(K) = QVAP(K)+QC3D(K)
2430 TAIR(K) = TAIR(K)-QC3D(K)*XXLV(K)/CPM(K)
2431 QC3D(K) = 0.; NC3D(K) = 0.
2432 ENDIF
2433 ENDIF
2434 IF (SSRI(K).LT.-1.E-1) THEN
2435 IF (QI3D(K).LT.QSMAL1) THEN
2436 QVAP(K) = QVAP(K)+QI3D(K)
2437 TAIR(K) = TAIR(K)-QI3D(K)*XXLS(K)/CPM(K)
2438 QI3D(K) = 0.; NI3D(K) = 0.; I3M3D(K) = 0.; FI3D(K) = 0.
2439 VI3D(K) = 0.; AI3D(K) = 0.
2440 ENDIF
2441 IF (QS3D(K).LT.QSMAL1) THEN
2442 QVAP(K) = QVAP(K)+QS3D(K)
2443 TAIR(K) = TAIR(K)-QS3D(K)*XXLS(K)/CPM(K)
2444 QS3D(K) = 0.; NS3D(K) = 0.; VS3D(K) = 0.; AS3D(K) = 0.
2445 FS3D(K) = 0.
2446 ENDIF
2447 IF (QG3D(K).LT.QSMAL1) THEN
2448 QVAP(K) = QVAP(K)+QG3D(K)
2449 TAIR(K) = TAIR(K)-QG3D(K)*XXLS(K)/CPM(K)
2450 QG3D(K) = 0.; NG3D(K) = 0.; VG3D(K) = 0.; AG3D(K) = 0.
2451 ENDIF
2452 IF (QH3D(K).LT.QSMAL1) THEN
2453 QVAP(K) = QVAP(K)+QH3D(K)
2454 TAIR(K) = TAIR(K)-QH3D(K)*XXLS(K)/CPM(K)
2455 QH3D(K) = 0.; NH3D(K) = 0.; AH3D(K) = 0.
2456 ENDIF
2457 ENDIF
2458 IF (TAIR(K).GT.TK0C.AND.QI3D(K).GT.0.) THEN
2459 QR3D(K) = QR3D(K)+QI3D(K)
2460 TAIR(K) = TAIR(K)-QI3D(K)*XXLF(K)/CPM(K)
2461 NR3D(K) = NR3D(K)+NI3D(K)
2462 QI3D(K) = 0.; NI3D(K) = 0.; I3M3D(K) = 0.; FI3D(K) = 0.
2463 VI3D(K) = 0.; AI3D(K) = 0.
2464 ENDIF
2465 IF (QC3D(K).LT.QSMALL.OR.NC3D(K).LT.NSMALL) THEN
2466 QVAP(K) = QVAP(K)+QC3D(K)
2467 TAIR(K) = TAIR(K)-QC3D(K)*XXLV(K)/CPM(K)
2468 QC3D(K) = 0.; NC3D(K) = 0.
2469 ENDIF
2470 IF (QR3D(K).LT.QSMALL.OR.NR3D(K).LT.NSMALL) THEN
2471 QVAP(K) = QVAP(K)+QR3D(K)
2472 TAIR(K) = TAIR(K)-QR3D(K)*XXLV(K)/CPM(K)
2473 QR3D(K) = 0.; NR3D(K) = 0.
2474 ENDIF
2475 IF (QI3D(K).LT.QSMALL.OR.NI3D(K).LT.NSMALL) THEN
2476 QVAP(K) = QVAP(K)+QI3D(K)
2477 TAIR(K) = TAIR(K)-QI3D(K)*XXLS(K)/CPM(K)
2478 QI3D(K) = 0.; NI3D(K) = 0.; I3M3D(K) = 0.; FI3D(K) = 0.
2479 VI3D(K) = 0.; AI3D(K) = 0.
2480 ENDIF
2481 IF (QS3D(K).LT.QSMALL.OR.NS3D(K).LT.NSMALL) THEN
2482 QVAP(K) = QVAP(K)+QS3D(K)
2483 TAIR(K) = TAIR(K)-QS3D(K)*XXLS(K)/CPM(K)
2484 QS3D(K) = 0.; NS3D(K) = 0.; VS3D(K) = 0.; AS3D(K) = 0.
2485 FS3D(K) = 0.
2486 ENDIF
2487 IF (QG3D(K).LT.QSMALL.OR.NG3D(K).LT.NSMALL) THEN
2488 QVAP(K) = QVAP(K)+QG3D(K)
2489 TAIR(K) = TAIR(K)-QG3D(K)*XXLS(K)/CPM(K)
2490 QG3D(K) = 0.; NG3D(K) = 0.; VG3D(K) = 0.; AG3D(K) = 0.
2491 ENDIF
2492 IF (QH3D(K).LT.QSMALL.OR.NH3D(K).LT.NSMALL) THEN
2493 QVAP(K) = QVAP(K)+QH3D(K)
2494 TAIR(K) = TAIR(K)-QH3D(K)*XXLS(K)/CPM(K)
2495 QH3D(K) = 0.; NH3D(K) = 0.; AH3D(K) = 0.
2496 ENDIF
2497 RHO(K) = PRES(K)/(TAIR(K)*(1.+0.61*QVAP(K)))/R
2498 VT_QC(K) = 0.; VT_NC(K) = 0.; VT_QR(K) = 0.; VT_NR(K) = 0.
2499 VT_QI(K) = 0.; VT_NI(K) = 0.; VT_QS(K) = 0.; VT_NS(K) = 0.
2500 VT_QG(K) = 0.; VT_NG(K) = 0.; VT_QH(K) = 0.; VT_NH(K) = 0.
2501 VT_VI(K) = 0.; VT_VS(K) = 0.; VT_VG(K) = 0.; VT_FI(K) = 0.
2502 VT_FS(K) = 0.; VT_AI(K) = 0.; VT_AS(K) = 0.; VT_AG(K) = 0.
2503 VT_AH(K) = 0.; VTI3M(K) = 0.
2504 IF (QC3D(K).GE.QSMALL.OR.QR3D(K).GE.QSMALL.OR.QI3D(K).GE. &
2505 QSMALL.OR.QS3D(K).GE.QSMALL.OR.QG3D(K).GE.QSMALL.OR. &
2506 QH3D(K).GE.QSMALL) THEN
2507 CALL SEDI_FALL(TAIR(K),PRES(K),QVAP(K),QC3D(K),QR3D(K), &
2508 QI3D(K),QS3D(K),QG3D(K),QH3D(K),NC3D(K),NR3D(K), &
2509 NI3D(K),NS3D(K),NG3D(K),NH3D(K),VI3D(K),VS3D(K), &
2510 VG3D(K),FI3D(K),FS3D(K),AI3D(K),AS3D(K),AG3D(K), &
2511 AH3D(K),I3M3D(K),VT_QC(K),VT_QR(K),VT_QI(K),VT_QS(K), &
2512 VT_QG(K),VT_QH(K),VT_NC(K),VT_NR(K),VT_NI(K),VT_NS(K),&
2513 VT_NG(K),VT_NH(K),VT_VI(K),VT_VS(K),VT_VG(K),VT_FI(K),&
2514 VT_FS(K),VT_AI(K),VT_AS(K),VT_AG(K),VT_AH(K),VTI3M(K),&
2515 SASPR(K),RHO(K))
2516 ENDIF
2517 IF (QC3D(K).GE.QSMALL.AND.NC3D(K).GE.NSMALL) THEN
2518 MVDC(K) = (QC3D(K)*iAMW/NC3D(K))**THRD
2519 IF (MVDC(K).GT.DCR) THEN
2520 QR3D(K) = QR3D(K)+QC3D(K)
2521 NR3D(K) = NR3D(K)+NC3D(K)
2522 QC3D(K) = 0.; NC3D(K) = 0.
2523 ENDIF
2524 ENDIF
2525 IF (QR3D(K).GE.QSMALL.AND.NR3D(K).GE.NSMALL) THEN
2526 MVDR(K) = (QR3D(K)*iAMW/NR3D(K))**THRD
2527 IF (MVDR(K).LT.DCR) THEN
2528 QC3D(K) = QC3D(K)+QR3D(K)
2529 NC3D(K) = NC3D(K)+NR3D(K)
2530 QR3D(K) = 0.; NR3D(K) = 0.
2531 ENDIF
2532 ENDIF
2533 IF (QH3D(K).GE.QSMALL.AND.NH3D(K).GE.NSMALL) THEN
2534 MVDH(K) = (QH3D(K)*iAMH/NH3D(K))**THRD
2535 IF (MVDH(K).LT.DHMIN) THEN
2536 QG3D(K) = QG3D(K)+QH3D(K)
2537 NG3D(K) = NG3D(K)+NH3D(K)
2538 VG3D(K) = VG3D(K)+QH3D(K)/RHOG0
2539 QH3D(K) = 0.; NH3D(K) = 0.
2540 IF (AH3D(K).GE.ASMALL.AND.AFAG_3M.EQ.1) THEN
2541 AG3D(K) = AG3D(K)+AH3D(K)
2542 AH3D(K) = 0.
2543 ENDIF
2544 ENDIF
2545 ENDIF
2546 !----------------- FOR TENDENCIES DUE TO PRECIPITATION/SEDIMENTATION ---
2547 TEMPC = QC3D(K)+QI3D(K) ! QC+QI
2548 IF (TEMPC.GT.0.) THEN
2549 VTMEAN(K,1) = (VT_QC(K)*QC3D(K)+VT_QI(K)*QI3D(K))/TEMPC ! SEDIMENTATION SPEED OF WET AEROSOL IN QC+QI
2550 ELSE
2551 VTMEAN(K,1) = 0.
2552 ENDIF
2553 TEMPR = QR3D(K)+QS3D(K)+QG3D(K)+QH3D(K) ! QR+QS+QG+QH
2554 IF (TEMPR.GT.0.) THEN
2555 VTMEAN(K,2) = (VT_QR(K)*QR3D(K)+VT_QS(K)*QS3D(K)+VT_QG(K)* &
2556 QG3D(K)+VT_QH(K)*QH3D(K))/TEMPR ! SEDIMENTATION SPEED OF WET AEROSOL IN QR+QS+QG+QH
2557 ELSE
2558 VTMEAN(K,2) = 0.
2559 ENDIF
2560 TEMPT = TEMPC+TEMPR ! QC+QR+QI+QS+QG
2561 IF (TEMPT.GT.0.) THEN
2562 VTMEAN(K,3) = (VTMEAN(K,1)*TEMPC+VTMEAN(K,2)*TEMPR)/TEMPT ! MEAN SEDIMENTATION SPEED OF WET AEROSOL
2563 ! IN QC+QR+QI+QS+QG+QH
2564 ELSE
2565 VTMEAN(K,3) = 0.
2566 ENDIF
2567 ENDDO
2568 !----------------- CALCULATED FALLING TERMS ----------------------------
2569 CALL PTFLUX(QC3D(1),VT_QC(1),RHO(1),DZ3D(1),KTE,DT,DTMN,CLODNCV)
2570 CALL PTFLUX(QR3D(1),VT_QR(1),RHO(1),DZ3D(1),KTE,DT,DTMN,RAINNCV)
2571 CALL PTFLUX(QI3D(1),VT_QI(1),RHO(1),DZ3D(1),KTE,DT,DTMN,ICENCV)
2572 CALL PTFLUX(QS3D(1),VT_QS(1),RHO(1),DZ3D(1),KTE,DT,DTMN,SNOWNCV)
2573 CALL PTFLUX(QG3D(1),VT_QG(1),RHO(1),DZ3D(1),KTE,DT,DTMN,GRAPNCV)
2574 CALL PTFLUX(QH3D(1),VT_QH(1),RHO(1),DZ3D(1),KTE,DT,DTMN,HAILNCV)
2575 RAINNC = RAINNC+CLODNCV+RAINNCV+ICENCV+SNOWNCV+GRAPNCV+HAILNCV
2576 SNOWNC = SNOWNC+ICENCV+SNOWNCV
2577 GRAPNC = GRAPNC+GRAPNCV
2578 HAILNC = HAILNC+HAILNCV
2579 SR = (ICENCV+SNOWNCV+GRAPNCV+HAILNCV)/ &
2580 (CLODNCV+RAINNCV+ICENCV+SNOWNCV+GRAPNCV+HAILNCV+1.E-12)
2581 CALL FLFLUX(NC3D(1),VT_NC(1),RHO(1),DZ3D(1),KTE,DT)
2582 CALL FLFLUX(NR3D(1),VT_NR(1),RHO(1),DZ3D(1),KTE,DT)
2583 CALL FLFLUX(NI3D(1),VT_NI(1),RHO(1),DZ3D(1),KTE,DT)
2584 CALL FLFLUX(NS3D(1),VT_NS(1),RHO(1),DZ3D(1),KTE,DT)
2585 CALL FLFLUX(NG3D(1),VT_NG(1),RHO(1),DZ3D(1),KTE,DT)
2586 CALL FLFLUX(NH3D(1),VT_NH(1),RHO(1),DZ3D(1),KTE,DT)
2587 CALL PTFLUX(VI3D(1),VT_VI(1),RHO(1),DZ3D(1),KTE,DT,DTMN,VINCV)
2588 CALL PTFLUX(VS3D(1),VT_VS(1),RHO(1),DZ3D(1),KTE,DT,DTMN,VSNCV)
2589 CALL PTFLUX(VG3D(1),VT_VG(1),RHO(1),DZ3D(1),KTE,DT,DTMN,VGNCV)
2590 CALL PTFLUX(FI3D(1),VT_FI(1),RHO(1),DZ3D(1),KTE,DT,DTMN,FINCV)
2591 CALL PTFLUX(FS3D(1),VT_FS(1),RHO(1),DZ3D(1),KTE,DT,DTMN,FSNCV)
2592 CALL PTFLUX(AI3D(1),VT_AI(1),RHO(1),DZ3D(1),KTE,DT,DTMN,AINCV)
2593 CALL PTFLUX(AS3D(1),VT_AS(1),RHO(1),DZ3D(1),KTE,DT,DTMN,ASNCV)
2594 CALL PTFLUX(AG3D(1),VT_AG(1),RHO(1),DZ3D(1),KTE,DT,DTMN,AGNCV)
2595 CALL PTFLUX(AH3D(1),VT_AH(1),RHO(1),DZ3D(1),KTE,DT,DTMN,AHNCV)
2596 CALL PTFLUX(I3M3D(1),VTI3M(1),RHO(1),DZ3D(1),KTE,DT,DTMN,I3MNCV)
2598 IV0 = 0
2599 DO IV = 1,NAER
2600 IF (NAERN(IV).GT.3) THEN
2601 CALL FLFLUX(AERO(1,IV0+3),VTMEAN(1,1),RHO(1),DZ3D(1),KTE,DT)! SEDI. OF AEROSOLS IN CLOUDS
2602 CALL FLFLUX(AERO(1,IV0+4),VTMEAN(1,2),RHO(1),DZ3D(1),KTE,DT)! SEDI. OF AEROSOLS IN PRECIP.
2603 ELSEIF (NAERN(IV).EQ.3) THEN
2604 CALL FLFLUX(AERO(1,IV0+3),VTMEAN(1,3),RHO(1),DZ3D(1),KTE,DT)! SEDI. OF AEROSOLS IN HYDROM.
2605 ENDIF
2606 IV0 = IV0+NAERN(IV)
2607 ENDDO
2608 !----------------------------------------------------------------------
2609 DO K = KTS,KTE
2610 TK3D(K) = TAIR(K)
2611 QV3D(K) = QVAP(K)
2612 IF (QC3D(K).GE.QSMALL.AND.NC3D(K).GE.NSMALL) THEN
2613 CALL SOLVE_AFAC(TK3D(K),QC3D(K),NC3D(K),LAMC(K),MVDC(K), &
2614 AFAC(K))
2615 ELSE
2616 QC3D(K) = 0.; NC3D(K) = 0.; MVDC(K) = 0.; AFAC(K) = 0.
2617 LAMC(K) = 0.
2618 ENDIF
2619 IF (QR3D(K).GE.QSMALL.AND.NR3D(K).GE.NSMALL) THEN
2620 CALL SOLVE_AFAR(TK3D(K),QR3D(K),NR3D(K),LAMR(K),MVDR(K), &
2621 AFAR(K))
2622 ELSE
2623 QR3D(K) = 0.; NR3D(K) = 0.; MVDR(K) = 0.; LAMR(K) = 0.
2624 AFAR(K) = 0.
2625 ENDIF
2626 IF (QI3D(K).GE.QSMALL.AND.NI3D(K).GE.NSMALL) THEN
2627 CALL SOLVE_AFAI(TK3D(K),PRES(K),RHO(K),QV3D(K),QI3D(K), &
2628 NI3D(K),VI3D(K),FI3D(K),AI3D(K),I3M3D(K),ADAGR(K), &
2629 ZETA(K),LAMI(K),AFAI(K),MVDI(K),RHOI(K),AMI(K),BMI(K),&
2630 AVI(K),BVI(K),BEST(K))
2631 IASPR(K) = FI3D(K)/I3M3D(K)
2632 ELSE
2633 QI3D(K) = 0.; NI3D(K) = 0.; MVDI(K) = 0.; I3M3D(K) = 0.
2634 FI3D(K) = 0.; VI3D(K) = 0.; AFAI(K) = 0.; IASPR(K) = 1.
2635 ADAGR(K) = 1.; RHOI(K) = 0.; AI3D(K) = 0.; LAMI(K) = 0.
2636 ENDIF
2637 IF (AS3D(K).LT.ASMALL) THEN
2638 AS3D(K) = 0.
2639 ENDIF
2640 IF (QS3D(K).GE.QSMALL.AND.NS3D(K).GE.NSMALL) THEN
2641 CALL SOLVE_AFAS(TK3D(K),RHO(K),QS3D(K),QC3D(K),NS3D(K), &
2642 VS3D(K),FS3D(K),AS3D(K),AFAS(K),LAMS(K),MVDS(K), &
2643 RHOS(K),SASPR(K),AMS(K),AVS(K),BVS(K))
2644 ELSE
2645 QS3D(K) = 0.; NS3D(K) = 0.; VS3D(K) = 0.; AS3D(K) = 0.
2646 MVDS(K) = 0.; RHOS(K) = 0.; AFAS(K) = 0.; LAMS(K) = 0.
2647 FS3D(K) = 0.; SASPR(K) = 1.
2648 ENDIF
2649 IF (AG3D(K).LT.ASMALL) THEN
2650 AG3D(K) = 0.
2651 ENDIF
2652 IF (QG3D(K).GE.QSMALL.AND.NG3D(K).GE.NSMALL) THEN
2653 CALL SOLVE_AFAG(TK3D(K),RHO(K),QG3D(K),QC3D(K),NG3D(K), &
2654 VG3D(K),AG3D(K),LAMG(K),AFAG(K),MVDG(K),RHOG(K), &
2655 AMG(K),AVG(K),BVG(K))
2656 ELSE
2657 QG3D(K) = 0.; NG3D(K) = 0.; MVDG(K) = 0.; VG3D(K) = 0.
2658 AG3D(K) = 0.; AFAG(K) = 0.; RHOG(K) = 0.; LAMG(K) = 0.
2659 ENDIF
2660 IF (AH3D(K).LT.ASMALL) THEN
2661 AH3D(K) = 0.
2662 ENDIF
2663 IF (QH3D(K).GE.QSMALL.AND.NH3D(K).GE.NSMALL) THEN
2664 CALL SOLVE_AFAH(TK3D(K),RHO(K),QH3D(K),NH3D(K),AH3D(K), &
2665 LAMH(K),AFAH(K),MVDH(K),AVH(K),BVH(K))
2666 ELSE
2667 QH3D(K) = 0.; NH3D(K) = 0.; MVDH(K) = 0.; LAMH(K) = 0.
2668 AH3D(K) = 0.; AFAH(K) = 0.
2669 ENDIF
2670 IF ((QC3D(K)+QR3D(K)).LT.QSMALL) THEN
2671 AERO(K,1) = MAX(RLIMIT,AERO(K,1)+AERO(K,3))
2672 AERO(K,1) = MIN(AERO(K,1),AERO(K,2))
2673 AERO(K,3) = 0.
2674 ENDIF
2675 IF ((QR3D(K)+QS3D(K)+QG3D(K)+QH3D(K)).LT.QSMALL) THEN
2676 AERO(K,1) = MAX(RLIMIT,AERO(K,1)+AERO(K,4))
2677 AERO(K,1) = MIN(AERO(K,1),AERO(K,2))
2678 AERO(K,4) = 0.
2679 ENDIF
2680 QDCN3D(K) = AERO(K,1)
2681 QTCN3D(K) = AERO(K,2)
2682 QCCN3D(K) = AERO(K,3)
2683 QRCN3D(K) = AERO(K,4)
2684 QNIN3D(K) = AERO(K,5)
2685 !------------------------------------------------------------------------
2686 ENDDO
2688 END SUBROUTINE NTU_MICRO
2689 !======================================================================
2691 !======================================================================
2692 SUBROUTINE ACTIVA(TK1D,W1D,NC1D,NR1D,ABCD,QACac,QACar,RX0,ZCCNS, &
2693 SSW,IAE,DO_FR)
2694 !======================================================================
2695 IMPLICIT NONE
2696 INTEGER :: IAE ! (I) aerosol component
2697 REAL :: TK1D,NC1D,NR1D,QACac,QACar,NACac,NACar,RX0,SSW
2698 REAL, INTENT(IN) :: W1D
2699 DOUBLE PRECISION :: X1,X3,DMASS,DERF
2700 REAL, DIMENSION(NCCN) :: ZCCNS
2701 REAL, DIMENSION(MAER) :: ABCD
2702 LOGICAL :: DO_FR
2703 INTEGER :: IM
2704 REAL :: GAMAA,ALPHA,SSRW,ES0,RX9,RX1,XMASS,RACT,ZCN9,ZCN99, &
2705 ZCCN10,ZCCN15,ZCCN20,ZCCN25,RACT10,RACT15,RACT20,RACT25, &
2706 WR10,WR15,WR20,WR25,WR10TO15,WR15TO20,WR20TO25,WR25PLUS
2707 REAL, PARAMETER :: RS10 = 10.E-6, RS15 = 15.E-6, RS20 = 20.E-6, &
2708 RS25 = 25.E-6
2710 QACac = 0.; QACar = 0.; NACac = 0.; NACar = 0.
2711 !------ decide the number of each mode and radius for CCN cut-off ------
2712 IF (DO_FR) THEN
2713 CALL FIND_RC0(DBLE(ABCD(1)/ABCD(2)),CNMOD(1,IAE),CNSTD(1,IAE),&
2714 WMAS(1,IAE),RX0,TBLXF(1,IAE),TBLRC)
2715 DO_FR = .FALSE.
2716 ENDIF
2717 IF (RX0.EQ.1.E-9) RETURN ! RC=RC_MIN, no dry aerosol available
2718 RX1 = RX0
2719 !----------------- Kohler Curve parameters -----------------------------
2720 SSRW = MIN(SSW,0.03)
2721 ES0 = 0.0761-1.55E-4*(TK1D-TK0C) ! [J/M**2]
2722 ALPHA = 2.*ES0/(RV*TK1D*RHOW) ! [J/m^2]/[J/kg/K]/[K]/[kg/m^3] = [m]
2723 GAMAA = 4.*ALPHA**3./(27.*BETA1(IAE)) ! [m^3]
2724 RX9 = (GAMAA/(SSRW**2.))**THRD ! critical dry radius [m]
2725 RX9 = MAX(RX9,RXMIN(IAE)) ! set lower limit of RX
2726 IF (RX1.LE.RX9) RETURN
2727 !----------------- RAINDROP ACTIVATION ---------------------------------
2728 IF (RX1.GT.RS10) THEN ! force all aerosol > RS10 into rain
2729 DMASS = 0.D+0
2730 DO IM = 1,NCCN
2731 X3 = DLNX(RX1,CNMOD(IM,IAE),CNSTD(IM,IAE),3)
2732 X1 = DLNX(RS10,CNMOD(IM,IAE),CNSTD(IM,IAE),3)
2733 DMASS = DMASS+DBLE(ZCCNS(IM))/DBLE(RFACT(IM,IAE))*(DERF(X3)-DERF(X1))/2.D+0 ! aerosol into rain
2734 ENDDO
2735 XMASS = MAX(0.,REAL(DMASS))
2736 XMASS = MIN(ABCD(1),XMASS)
2737 IF (NAERN(IAE).GE.4) THEN
2738 ABCD(4) = ABCD(4)+XMASS ! update aerosol in rain
2739 ELSEIF (NAERN(IAE).EQ.3) THEN
2740 ABCD(3) = ABCD(3)+XMASS ! update aerosol in (cloud+rain)
2741 ENDIF
2742 ABCD(1) = ABCD(1)-XMASS ! update dry aerosol
2743 CALL RSWHITBY(W1D,RS10,ZCCN10,RACT10,BETA1(IAE),ALPHA,ZCCNS, &
2744 CNMOD(1,IAE),CNSTD(1,IAE))
2745 CALL RSWHITBY(W1D,RS15,ZCCN15,RACT15,BETA1(IAE),ALPHA,ZCCNS, &
2746 CNMOD(1,IAE),CNSTD(1,IAE))
2747 CALL RSWHITBY(W1D,RS20,ZCCN20,RACT20,BETA1(IAE),ALPHA,ZCCNS, &
2748 CNMOD(1,IAE),CNSTD(1,IAE))
2749 CALL RSWHITBY(W1D,RS25,ZCCN25,RACT25,BETA1(IAE),ALPHA,ZCCNS, &
2750 CNMOD(1,IAE),CNSTD(1,IAE))
2751 WR10 = C4PI3W*RACT10**3. ! [kg]
2752 WR15 = C4PI3W*RACT15**3. ! [kg]
2753 WR20 = C4PI3W*RACT20**3. ! [kg]
2754 WR25 = C4PI3W*RACT25**3. ! [kg]
2755 WR10TO15 = 0.5*(WR10+WR15)*(ZCCN10-ZCCN15) ! [kg/kg]
2756 WR15TO20 = 0.5*(WR15+WR20)*(ZCCN15-ZCCN20) ! [kg/kg]
2757 WR20TO25 = 0.5*(WR20+WR25)*(ZCCN20-ZCCN25) ! [kg/kg]
2758 WR25PLUS = WR25*ZCCN25 ! [kg/kg]
2759 NACar = ZCCN10 ! [1/kg]
2760 QACar = WR10TO15+WR15TO20+WR20TO25+WR25PLUS ! [kg/kg]
2761 RX1 = RS10 ! [m]
2762 !----------------- end sectionalize rain embryo ------------------------
2763 !----------------- single category rain embryo -------------------------
2764 NR1D = NR1D+NACar ! [ #/kg]
2765 ENDIF
2766 !----------------- CLOUD DROP ACTIVATION ------------------------------
2767 IF (RX1.GT.RX9) THEN
2768 DMASS = 0.D+0
2769 DO IM = 1,NCCN
2770 X3 = DLNX(RX1,CNMOD(IM,IAE),CNSTD(IM,IAE),3)
2771 X1 = DLNX(RX9,CNMOD(IM,IAE),CNSTD(IM,IAE),3)
2772 DMASS = DMASS+DBLE(ZCCNS(IM))/DBLE(RFACT(IM,IAE))*(DERF(X3)-DERF(X1))/2.D+0 ! aerosol into rain
2773 ENDDO
2774 XMASS = MAX(0.,REAL(DMASS))
2775 XMASS = MIN(XMASS,ABCD(1))
2776 IF (NAERN(IAE).GE.3) THEN
2777 ABCD(3) = ABCD(3)+XMASS ! update wet aerosol in (cloud+rain)
2778 ENDIF
2779 ABCD(1) = ABCD(1)-XMASS ! update dry aerosol
2780 CALL CCNWHITBY(W1D,RS10,RX9,ZCN99,RACT,BETA1(IAE),ALPHA,ZCCNS,&
2781 CNMOD(1,IAE),CNSTD(1,IAE))
2782 CALL CCNWHITBY(W1D,RX1,RX9,ZCN9,RACT,BETA1(IAE),ALPHA,ZCCNS, &
2783 CNMOD(1,IAE),CNSTD(1,IAE))
2784 NACac = MIN(ZCN9,MAX(ZCN99-NC1D,0.)) ! Total # should less than ZCN99
2785 QACac = NACac*C4PI3W*RACT**3. ! [kg/kg]
2786 NC1D = NC1D+NACac ! [#/kg]
2787 RX1 = RX9
2788 ENDIF
2789 RX0 = RX1
2791 END SUBROUTINE ACTIVA
2792 !======================================================================
2793 !
2794 !----------------- FUNCTION FOR CALCULATE lnX --------------------------
2795 FUNCTION DLNX(RX,XMODE,SIGMA,N)
2796 !======================================================================
2797 INTEGER :: N
2798 REAL :: RX,XMODE,SIGMA
2799 DOUBLE PRECISION :: DRX,DXMODE,DSTDV,DLNX,DLOG,DSQRT
2801 DRX = DBLE(RX)
2802 DXMODE = DBLE(XMODE)
2803 DSTDV = DBLE(SIGMA)
2804 DLNX = (DLOG(DRX/DXMODE)-DSTDV**2.*DBLE(N))/(DSQRT(2.D+0)*DSTDV)
2806 END FUNCTION DLNX
2807 !----------------- FUNCTION FOR CALCULATE lnX --------------------------
2808 FUNCTION DLNX2(DRX,XMODE,SIGMA,N)
2809 INTEGER :: N
2810 REAL :: XMODE,SIGMA
2811 DOUBLE PRECISION :: DRX,DXMODE,DSTDV,DLNX2,DLOG,DSQRT
2813 DXMODE = DBLE(XMODE)
2814 DSTDV = DBLE(SIGMA)
2815 DLNX2 = (DLOG(DRX/DXMODE)-DSTDV**2.*DBLE(N))/(DSQRT(2.D+0)*DSTDV)
2817 END FUNCTION DLNX2
2818 !======================================================================
2819 !
2820 !======================================================================
2821 SUBROUTINE RSWHITBY(W1D,RSX,Z,RACT,BETA1,ALPHA,ZCCN,CNMOD,CNSTD)
2822 !======================================================================
2823 IMPLICIT NONE
2824 !----------------- calculate number of CCN with dry radii > R0 ---------
2825 INTEGER :: IM
2826 REAL :: RSX, &! smallest dry radius of rain embryo (input)
2827 RWS0, &! wet radius at S = 1
2828 RACT, &! activation radius (output)
2829 Z, &! number of CCN that fits the criterion (output)
2830 BETA1,ALPHA,TEMP,TEMP1,TEMP2,TMPX,TEMP4,ERF
2831 REAL, INTENT(IN) :: W1D
2832 REAL, DIMENSION(NCCN) :: ZCCN,CNMOD,CNSTD
2833 !----- integrate the number concentration of aerosols with size > RACT--
2834 Z = 0.
2835 DO IM = 1,NCCN
2836 TEMP1 = ZCCN(IM)/2.
2837 TEMP2 = SQRT2*CNSTD(IM)
2838 TEMP = (LOG(RSX/CNMOD(IM)))/TEMP2
2839 Z = Z+TEMP1*(1.-ERF(TEMP))
2840 END DO
2841 RWS0 = SQRT(BETA1*RSX**3./ALPHA) ! wet radius at S = 1
2842 TMPX = LOG10(RSX*1.E6)
2843 TEMP4 = -0.61425115+(-0.66624878-0.17367658*TMPX)*TMPX
2844 RACT = 10.**TEMP4*RWS0*W1D**(-0.11782)
2846 END SUBROUTINE RSWHITBY
2847 !----------------------------------------------------------------------
2848 SUBROUTINE CCNWHITBY(W1D,RSX,RS9,ZCN9,RACT,BETA1,ALPHA,ZCCN, &
2849 CNMOD,CNSTD)
2850 !======================================================================
2851 IMPLICIT NONE
2852 !---- derive number of cloud drop activation according to Whitby's distributions
2853 INTEGER :: IM
2854 REAL :: RSX, &! previously activated smallest dry radius
2855 RS9, &! current activated smallest dry radius
2856 ZCN9, &! newly activated number concentration (#/mol)
2857 RACT, &! wet radius of the activated drop
2858 RWS0, &! wet radius at S = 1
2859 BETA1,ALPHA,TMPX,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,ERF
2860 REAL, INTENT(IN) :: W1D
2861 REAL, DIMENSION(NCCN) :: ZCCN,CNMOD,CNSTD
2863 RWS0 = SQRT(BETA1*RS9**3./ALPHA) ! wet radius at S = 1
2864 TMPX = LOG10(RSX*1.E6)
2865 TMP1 = -0.61425115+(-0.66624878-0.17367658*TMPX)*TMPX
2866 RACT = 10.**TMP1*RWS0*W1D**(-0.11782) ! activation size
2867 ZCN9 = 0.
2868 DO IM = 1,NCCN
2869 TMP2 = ZCCN(IM)/2.
2870 TMP3 = SQRT2*CNSTD(IM)
2871 TMP4 = (LOG(RSX/CNMOD(IM)))/TMP3
2872 TMP5 = (LOG(RS9/CNMOD(IM)))/TMP3
2873 TMP6 = TMP2*(ERF(TMP4)-ERF(TMP5))
2874 ZCN9 = ZCN9+TMP6
2875 END DO
2877 END SUBROUTINE CCNWHITBY
2878 !======================================================================
2879 !
2880 !======================================================================
2881 SUBROUTINE DEACTIVA(NACcv,QC1D,NC1D,DCN,TCN,WCN,RC,ZCCNS,IAE, &
2882 DO_FR)
2883 !======================================================================
2884 IMPLICIT NONE
2885 INTEGER :: IAE ! (I) aerosol component
2886 LOGICAL :: DO_FR
2887 REAL :: NC1D,NACcv,QC1D,DCN,TCN,WCN, &! (I/O) wet aerosol mixing ratio [kg/kg]
2888 RC ! (I/O) R-CUTOFF [um]
2889 REAL, DIMENSION(NCCN) :: ZCCNS ! (I) # of each mode in [#/kg]
2890 INTEGER :: I,IM
2891 DOUBLE PRECISION :: DNACcv, &! # of deactivated cloud droplet
2892 DMASS, &! mass of deactivated wet aerosol
2893 DSQRT2,X0,X1,X2,X3,S1,S2,DERF,DEXP,DSQRT
2894 !----------------- deactivation of cloud drops -------------------------
2895 DSQRT2 = DSQRT(2.D+0)
2896 DNACcv = DBLE(MIN(NACcv,NC1D))
2897 IF (QC1D.LT.RSMALL) THEN
2898 DNACcv = DBLE(NC1D) ! deactivate all cld drop for negligiable QC
2899 NC1D = RLIMIT
2900 ENDIF
2901 DMASS = 0.D+0
2902 IF (DNACcv.GT.1.D+1) THEN
2903 !------ decide the number of each mode and radius for CCN cut-off ------
2904 IF (DO_FR) THEN
2905 CALL FIND_RC0(DBLE(DCN/TCN),CNMOD(1,IAE),CNSTD(1,IAE), &
2906 WMAS(1,IAE),RC,TBLXF(1,IAE),TBLRC)
2907 DO_FR = .FALSE.
2908 ENDIF
2909 S1 = 0.D+0
2910 DO IM = 1,NCCN
2911 X0 = DLNX(RC,CNMOD(IM,IAE),CNSTD(IM,IAE),0)
2912 S1 = S1+DBLE(ZCCNS(IM))*(1.D+0-DERF(X0))*5.D-1 ! # for all with r > RC
2913 ENDDO
2914 IF (DNACcv.GT.S1) THEN
2915 DCN = DCN+WCN
2916 WCN = 0.
2917 CALL FIND_RC0(DBLE(DCN/TCN),CNMOD(1,IAE),CNSTD(1,IAE), &
2918 WMAS(1,IAE),RC,TBLXF(1,IAE),TBLRC)
2919 RETURN
2920 ENDIF
2921 S1 = 0.
2922 DO IM = 1,NCCN
2923 X0 = DLNX(RC,CNMOD(IM,IAE),CNSTD(IM,IAE),0)
2924 S1 = S1+DBLE(ZCCNS(IM)/CNSTD(IM,IAE))/DSQRT2*DPDF(X0) ! # between 0 & RC
2925 ENDDO
2926 X1 = DBLE(RC)
2927 X2 = DBLE(RC)*DEXP(DNACcv/S1)
2928 DO I = 1,4 ! iteratively fixed dN 3 times
2929 S1 = 0.D+0
2930 S2 = 0.D+0
2931 DO IM = 1,NCCN
2932 X0 = DLNX2(X1,CNMOD(IM,IAE),CNSTD(IM,IAE),0)
2933 X3 = DLNX2(X2,CNMOD(IM,IAE),CNSTD(IM,IAE),0)
2934 S1 = S1+DBLE(ZCCNS(IM)/CNSTD(IM,IAE))/DSQRT2*DPDF(X3)
2935 S2 = S2+DBLE(ZCCNS(IM))*(DERF(X3)-DERF(X0))*5.D-1 ! # between X1 & X2
2936 ENDDO
2937 DNACcv = DNACcv-S2
2938 X1 = X2
2939 X2 = X2*DEXP(DNACcv/S1)
2940 ENDDO
2941 X1 = DBLE(RC)
2942 X2 = MAX(X1,X2)
2943 DO IM = 1,NCCN
2944 X0 = DLNX2(X1,CNMOD(IM,IAE),CNSTD(IM,IAE),3)
2945 X3 = DLNX2(X2,CNMOD(IM,IAE),CNSTD(IM,IAE),3)
2946 DMASS = DMASS+DBLE(ZCCNS(IM))/DBLE(RFACT(IM,IAE))*(DERF(X3)-DERF(X0))*5.D-1 ! MASS between X0 & X3
2947 ENDDO
2948 DCN = DCN+MIN(WCN,REAL(DMASS))
2949 WCN = WCN-MIN(WCN,REAL(DMASS))
2950 RC = REAL(X2)
2951 ENDIF
2953 END SUBROUTINE DEACTIVA
2954 !======================================================================
2955 !
2956 !======================================================================
2957 SUBROUTINE ICENU(TK1D,P1D,DT,RHO,QV1D,QI1D,NI1D,VI1D,FI1D,AI1D, &
2958 I3M1D,QNIN)
2959 !======================================================================
2960 IMPLICIT NONE
2961 INTEGER :: IDEPNU
2962 REAL :: TK1D,P1D,DT,RHO,QV1D,QI1D,NI1D,VI1D,FI1D,AI1D,I3M1D,QNIN,&
2963 QVSI,XXLS,ESI,QNDvi,NNDvi,VNDvi,FNDvi,ANDvi,INDvi,NVI0, &
2964 EPA,RGDEP,SFCTNV,ICED,GGDEP,SRI,ARDEP0,ARDEP,COSM1,GEOF1,&
2965 IJDEP0,IJDEP,DC1,DC2,DC3,TC1D,INR0,DANGLE,DACTE,QVDMAX, &
2966 NNUMAX,SSRI,CPM
2968 QNDvi = 0.;NNDvi = 0.;VNDvi = 0.;FNDvi = 0.;ANDvi = 0.;INDvi = 0.
2970 IDEPNU = 8 ! Ice deposition-nucleation equation option
2971 TC1D = TK1D-TK0C
2972 XXLS = 3.15E6-2.37E3*TK1D+0.3337E6
2973 ESI = MIN(0.99*P1D,POLYSVP(TK1D,1))
2974 QVSI = 0.622*ESI/(P1D-ESI)
2975 SRI = QV1D/QVSI
2976 SSRI = QV1D/QVSI-1.
2977 QVDMAX = (QV1D-QVSI)/(1.+XXLS**2.*QV1D/(CP*RV*TK1D**2.)) ! SUPERSATURATED WATER FIXED DUE TO TEMPERATURE CHANGE
2978 NNUMAX = 0.98*QVDMAX/MI0 ! INITIATION OF CLOUD ICE CONSTRAINED by 0.98*SUPICE
2979 ICED = 916.7-0.175*TC1D-5.E-4*TC1D**2. ! ICE DENSITY
2980 SRI = QV1D/QVSI ! SATURATION RATIO OVER ICE
2981 SFCTNV = ((76.1-0.155*TC1D)+(28.5+0.25*TC1D))*1.E-3 ! SURFACE TENSION OVER ICE/VAPOR
2983 IF (IDEPNU.EQ.0) THEN ! NO DEPOSITION NUCLEATION
2984 NNDvi = 0.
2985 ELSEIF (IDEPNU.EQ.1) THEN ! Fletcher (1962)
2986 NVI0 = 1.E-2*EXP(0.6*(TK0C-MAX(TK1D,2.46E2)))
2987 NNDvi = MIN(QNIN,NNUMAX,MAX(0.,NVI0/RHO-NI1D))
2988 ELSEIF (IDEPNU.EQ.2) THEN ! Cooper
2989 NVI0 = 5.*EXP(0.304*(TK0C-MAX(TK1D,2.46E2)))
2990 NNDvi = MIN(QNIN,NNUMAX,MAX(0.,NVI0/RHO-NI1D))
2991 ELSEIF (IDEPNU.EQ.3) THEN ! Huffman (1973)
2992 NVI0 = 1007.08*SSRI**4.5*1.E3
2993 NNDvi = MIN(QNIN,NNUMAX,MAX(0.,NVI0/RHO-NI1D))
2994 ELSEIF (IDEPNU.EQ.4) THEN ! Meyers et al (1992)
2995 NVI0 = 1.E3*EXP(1.296E1*SSRI-6.39E-1)
2996 NNDvi = MIN(QNIN,NNUMAX,MAX(0.,NVI0/RHO-NI1D))
2997 ELSEIF (IDEPNU.EQ.5.AND.INSPEC.EQ.4) THEN ! Bacteria(P. syringae):Yankofsky 1981
2998 NVI0 = QNIN*1.1776*EXP(-89318./((LOG(SRI))**2.*TK1D**3.))
2999 NNDvi = MIN(QNIN,NNUMAX,MAX(0.,NVI0*DT))
3000 ELSEIF (IDEPNU.EQ.6) THEN ! DUST (Field 2006)(Asia)
3001 NVI0 = QNIN*4.337E-1*EXP(-2.E6/((LOG(SRI))**2.*TK1D**3.))
3002 NNDvi = MIN(QNIN,NNUMAX,MAX(0.,NVI0*DT))
3003 ELSEIF (IDEPNU.EQ.7) THEN
3004 IF (INSPEC.EQ.1) THEN ! SOOT
3005 DC1 = -0.5411955; DC2 = 1.879918; DC3 = 1.607947 ! CHEN Table3
3006 INR0 = 0.4E-7; DANGLE = 28.; DACTE = -20.E-20 ! HOOSE Table3
3007 ELSEIF (INSPEC.EQ.2) THEN ! SAHARAN DUST
3008 DC1 = -0.3353619; DC2 = 1.990979; DC3 = 2.175539 ! CHEN Table3
3009 INR0 = 1.75E-7; DANGLE = 5.06; DACTE = 3.35E-20 ! CHEN Table6
3010 ELSEIF (INSPEC.EQ.3) THEN ! ASIAN DUST
3011 DC1 = -0.3598818; DC2 = 1.982032; DC3 = 2.025390 ! CHEN Table3
3012 INR0 = 2.E-7; DANGLE = 8.1; DACTE = 1.82E-20 ! CHEN Table6
3013 ENDIF
3014 EPA = ESI*SRI
3015 RGDEP = 2.*2.99E-26*SFCTNV/(ICED*BOLTZ*TK1D*LOG(SRI)) ! GERM RADIUS FOR DEPOSITION NUCLEATION
3016 GGDEP = C4PI3*SFCTNV*RGDEP**2. ! HOMOGENEOUS ENERGY
3017 ARDEP0 = SFCTNV**5.E-1*(BOLTZ*TK1D)**(-1.5)/1.E13
3018 ARDEP = EPA**2.*ARDEP0/ICED
3019 COSM1 = LOG(1.-COS(DANGLE*PI/1.8E2))
3020 GEOF1 = MIN(1.,EXP(DC1+DC2*COSM1+DC3*RGDEP/INR0))
3021 IJDEP0 = EXP((-1.*DACTE-GEOF1*GGDEP)/(BOLTZ*TK1D))
3022 IJDEP = ARDEP*INR0**2.*GEOF1**5.E-1*IJDEP0
3023 NVI0 = QNIN*(1.-EXP(-IJDEP*DT))
3024 NNDvi = MIN(QNIN,NNUMAX,MAX(0.,NVI0))
3025 ELSEIF (IDEPNU.EQ.8) THEN
3026 NVI0 = MAX(0.,5.94E-5*((TK0C-TK1D)**3.33)*((1.E6/1.E6)** &! set naer05=1e6/kg (derived to cm-3 at STP below)
3027 (0.0264*(TK0C-TK1D)+3.3E-3))*1.E3) ! units of #/kg
3028 NNDvi = MIN(QNIN,NNUMAX,MAX(0.,NVI0/RHO-NI1D))
3029 ENDIF
3030 QNDvi = NNDvi*MI0
3031 VNDvi = QNDvi*iRHOI0
3032 FNDvi = QNDvi*1.*iAMI0 ! ISOMETRIC
3033 ANDvi = (KCIMIN*NNDvi*INDvi**2.)**THRD
3034 INDvi = QNDvi*iAMI0
3035 QNIN = MAX(0.,QNIN-NNDvi)
3036 QV1D = MAX(0.,QV1D-QNDvi)
3037 QI1D = MAX(0.,QI1D+QNDvi)
3038 NI1D = MAX(0.,NI1D+NNDvi)
3039 IF (ICE_RHOI.EQ.0.OR.ICE_RHOI.EQ.2) THEN
3040 VI1D = 0.
3041 ELSEIF (ICE_RHOI.EQ.1) THEN
3042 VI1D = MAX(0.,VI1D+VNDvi)
3043 ENDIF
3044 FI1D = MAX(0.,FI1D+FNDvi)
3045 I3M1D = MAX(0.,I3M1D+INDvi)
3046 IF (AFAI_3M.EQ.0.OR.AFAI_3M.EQ.2) THEN
3047 AI1D = 0.
3048 ELSEIF (AFAI_3M.EQ.1) THEN
3049 AI1D = MAX(0.,AI1D+ANDvi)
3050 ENDIF
3051 CPM = CP*(1.+0.887*QV1D)
3052 XXLS = 3.15E6-2370.*TK1D+0.3337E6
3053 TK1D = TK1D+XXLS*QNDvi/CPM
3055 END SUBROUTINE ICENU
3056 !======================================================================
3057 !
3058 !======================================================================
3059 SUBROUTINE SEDI_FALL(TK1D,P1D,QV1D,QC1D,QR1D,QI1D,QS1D,QG1D,QH1D,&
3060 NC1D,NR1D,NI1D,NS1D,NG1D,NH1D,VI1D,VS1D,VG1D,FI1D, &
3061 FS1D,AI1D,AS1D,AG1D,AH1D,I3M1D,VTQC,VTQR,VTQI,VTQS, &
3062 VTQG,VTQH,VTNC,VTNR,VTNI,VTNS,VTNG,VTNH,VTVI,VTVS, &
3063 VTVG,VTFI,VTFS,VTAI,VTAS,VTAG,VTAH,VTI3M,SASPR,RHO)
3064 !======================================================================
3065 IMPLICIT NONE
3066 REAL :: TK1D,P1D,QV1D,QC1D,QR1D,QI1D,QS1D,QG1D,QH1D,NC1D,NR1D, &
3067 NI1D,NS1D,NG1D,NH1D,VI1D,VS1D,VG1D,FI1D,FS1D,AI1D,AS1D, &
3068 AG1D,AH1D,I3M1D,VTQC,VTQR,VTQI,VTQS,VTQG,VTQH,VTNC,VTNR, &
3069 VTNI,VTNS,VTNG,VTNH,VTVI,VTVS,VTVG,VTFI,VTFS,VTAI,VTAS, &
3070 VTAG,VTAH,VTI3M,QRHO,RHOAJ,RHO,MVRC,MVRR,GUC,GUR,LAMC, &
3071 LAMR,LAMI,LAMS,LAMG,LAMH,RHOI,RHOS,RHOG,AFAC,AFAR,AFAI, &
3072 AFAS,AFAG,AFAH,ADAGR,ZETA3,AMI,BMI,AMS,AMG,AVI,BVI,AVS, &
3073 BVS,AVG,BVG,AVH,BVH,ZETA,FSQC,FSQR,FSQI,FSQS,FSQG,FSQH, &
3074 FSNC,FSNR,FSNI,FSNS,FSNG,FSNH,FSVI,FSVS,FSVG,FSFI,FSAI, &
3075 FSAS,FSAG,FSAH,MVDC,MVDR,MVDI,MVDS,MVDG,MVDH,BEST,SASPR
3076 REAL, PARAMETER :: AVTC = 8.8462E+02, BVTC = 9.7593E+07
3077 REAL, PARAMETER :: CVTC = -3.4249E+11, AVTR = 2.1454E+00
3078 REAL, PARAMETER :: BVTR = -2.2812E-04, CVTR = 2.9676E-09
3079 REAL, PARAMETER :: CQC1 = 2.0901E+01, CQC2 = 9.9111E-01
3080 REAL, PARAMETER :: CQC3 = 4.4182E+00, CNC1 = 1.8276E+01
3081 REAL, PARAMETER :: CNC2 = 1.0015E+00, CNC3 = 1.9838E+00
3082 REAL, PARAMETER :: CQR1 = 1.5943E+01, CQR2 = 1.1898E+00
3083 REAL, PARAMETER :: CQR3 = 4.0073E+00, CNR1 = 9.4791E+00
3084 REAL, PARAMETER :: CNR2 = 9.7607E-01, CNR3 = 1.0858E+00
3086 QRHO = SQRT(RHO)
3087 RHOAJ = (RHOSU/RHO)**0.54
3088 IF (QC1D.GE.QSMALL) THEN
3089 CALL SOLVE_AFAC(TK1D,QC1D,NC1D,LAMC,MVDC,AFAC)
3090 IF (LIQ_VTC.EQ.0) THEN
3091 FSQC = EXP(GAMLN(BVC0+BMW+AFAC+1.)-GAMLN(BMW+AFAC+1.)- &
3092 BVC0*LOG(LAMC))
3093 FSNC = EXP(GAMLN(BVC0+AFAC+1.)-GAMLN(AFAC+1.)-BVC0* &
3094 LOG(LAMC))
3095 VTQC = RHOAJ*FSQC*AVC0
3096 VTNC = RHOAJ*FSNC*AVC0
3097 ELSEIF (LIQ_VTC.EQ.1) THEN
3098 MVRC = MIN(MAX((QC1D/NC1D/C4PI3W)**THRD,RCMIN),RCMAX)
3099 GUC = EXP(EXP(AFU+BFU*(LOG(MVRC))**3.+CFU*QRHO**3.))
3100 VTQC = EXP(CQC1+CQC2*LOG(NC1D)+CQC3*LOG(MVRC))*GUC/QC1D
3101 VTNC = EXP(CNC1+CNC2*LOG(NC1D)+CNC3*LOG(MVRC))*GUC/NC1D
3102 ELSEIF (LIQ_VTC.EQ.2) THEN
3103 MVRC = MIN(MAX((QC1D/NC1D/C4PI3W)**THRD,RCMIN),RCMAX)
3104 GUC = EXP(EXP(AFU+BFU*(LOG(MVRC))**3.+CFU*QRHO**3.))
3105 VTQC = MVRC*(AVTC+BVTC*MVRC+CVTC*MVRC**2.)*GUC
3106 VTNC = MVRC*(AVTC+BVTC*MVRC+CVTC*MVRC**2.)*GUC
3107 ENDIF
3108 VTQC = MIN(VTQC,VTCMAX)
3109 VTNC = MIN(VTNC,VTCMAX)
3110 ENDIF
3111 IF (QR1D.GE.QSMALL) THEN
3112 CALL SOLVE_AFAR(TK1D,QR1D,NR1D,LAMR,MVDR,AFAR)
3113 IF (LIQ_VTR.EQ.0) THEN
3114 FSQR = EXP(GAMLN(BVR0+BMW+AFAR+1.)-GAMLN(BMW+AFAR+1.)- &
3115 BVR0*LOG(LAMR))
3116 FSNR = EXP(GAMLN(BVR0+AFAR+1.)-GAMLN(AFAR+1.)-BVR0* &
3117 LOG(LAMR))
3118 VTQR = RHOAJ*FSQR*AVR0
3119 VTNR = RHOAJ*FSNR*AVR0
3120 ELSEIF (LIQ_VTR.EQ.1) THEN
3121 MVRR = MIN(MAX((QR1D/NR1D/C4PI3W)**THRD,RRMIN),RRMAX)
3122 GUR = EXP(EXP(AFU+BFU*(LOG(MVRR))**3.+CFU*QRHO**3.))
3123 VTQR = EXP(CQR1+CQR2*LOG(NR1D)+CQR3*LOG(MVRR))*GUR/QR1D
3124 VTNR = EXP(CNR1+CNR2*LOG(NR1D)+CNR3*LOG(MVRR))*GUR/NR1D
3125 ELSEIF (LIQ_VTR.EQ.2) THEN
3126 MVRR = MIN(MAX((QR1D/NR1D/C4PI3W)**THRD,RRMIN),RRMAX)
3127 GUR = EXP(EXP(AFU+BFU*(LOG(MVRR))**3.+CFU*QRHO**3.))
3128 VTQR = EXP(AVTR+BVTR/MVRR+CVTR/(MVRR**2.))*GUR
3129 VTNR = EXP(AVTR+BVTR/MVRR+CVTR/(MVRR**2.))*GUR
3130 ENDIF
3131 VTQR = MIN(VTQR,VTRMAX)
3132 VTNR = MIN(VTNR,VTRMAX)
3133 ENDIF
3134 IF (QI1D.GE.QSMALL) THEN
3135 CALL SOLVE_AFAI(TK1D,P1D,RHO,QV1D,QI1D,NI1D,VI1D,FI1D,AI1D, &
3136 I3M1D,ADAGR,ZETA,LAMI,AFAI,MVDI,RHOI,AMI,BMI,AVI,BVI, &
3137 BEST)
3138 FSQI = EXP(GAMLN(BVI+BMI+AFAI+1.)-GAMLN(BMI+AFAI+1.)-BVI* &
3139 LOG(LAMI))
3140 FSNI = EXP(GAMLN(BVI+AFAI+1.)-GAMLN(AFAI+1.)-BVI*LOG(LAMI))
3141 FSVI = EXP(GAMLN(BVI+AFAI+4.)-GAMLN(AFAI+4.)-BVI*LOG(LAMI))
3142 VTQI = MIN(RHOAJ*FSQI*AVI,VTIMAX)
3143 VTNI = MIN(RHOAJ*FSNI*AVI,VTIMAX)
3144 VTVI = MIN(RHOAJ*FSVI*AVI,VTIMAX)
3145 IF (AI1D.GE.ASMALL) THEN
3146 FSAI = EXP(GAMLN(BVI+AFAI+3.)-GAMLN(AFAI+3.)-BVI*LOG(LAMI))
3147 VTAI = MIN(RHOAJ*FSAI*AVI,VTIMAX)
3148 ENDIF
3149 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
3150 ZETA3 = 3.*(ADAGR-1.)/(ADAGR+2.)
3151 FSFI = EXP(GAMLN(BVI+ZETA3+AFAI+4.)-GAMLN(ZETA3+AFAI+4.)- &
3152 BVI*LOG(LAMI))
3153 VTFI = MIN(RHOAJ*FSFI*AVI,VTIMAX)
3154 VTI3M = MIN(RHOAJ*FSVI*AVI,VTIMAX)
3155 ENDIF
3156 ENDIF
3157 IF (QS1D.GE.QSMALL) THEN
3158 CALL SOLVE_AFAS(TK1D,RHO,QS1D,QC1D,NS1D,VS1D,FS1D,AS1D,AFAS, &
3159 LAMS,MVDS,RHOS,SASPR,AMS,AVS,BVS)
3160 FSQS = EXP(GAMLN(BVS+BMS+AFAS+1.)-GAMLN(BMS+AFAS+1.)-BVS* &
3161 LOG(LAMS))
3162 FSNS = EXP(GAMLN(BVS+AFAS+1.)-GAMLN(AFAS+1.)-BVS*LOG(LAMS))
3163 FSVS = EXP(GAMLN(BVS+AFAS+4.)-GAMLN(AFAS+4.)-BVS*LOG(LAMS))
3164 VTQS = MIN(RHOAJ*FSQS*AVS,VTSMAX)
3165 VTNS = MIN(RHOAJ*FSNS*AVS,VTSMAX)
3166 VTVS = MIN(RHOAJ*FSVS*AVS,VTSMAX)
3167 VTFS = VTVS
3168 IF (AS1D.GE.ASMALL) THEN
3169 FSAS = EXP(GAMLN(BVS+AFAS+3.)-GAMLN(AFAS+3.)-BVS*LOG(LAMS))
3170 VTAS = MIN(RHOAJ*FSAS*AVS,VTSMAX)
3171 ENDIF
3172 ENDIF
3173 IF (QG1D.GE.QSMALL) THEN
3174 CALL SOLVE_AFAG(TK1D,RHO,QG1D,QC1D,NG1D,VG1D,AG1D,LAMG,AFAG, &
3175 MVDG,RHOG,AMG,AVG,BVG)
3176 FSQG = EXP(GAMLN(BVG+BMG+AFAG+1.)-GAMLN(BMG+AFAG+1.)-BVG* &
3177 LOG(LAMG))
3178 FSNG = EXP(GAMLN(BVG+AFAG+1.)-GAMLN(AFAG+1.)-BVG*LOG(LAMG))
3179 FSVG = EXP(GAMLN(BVG+AFAG+4.)-GAMLN(AFAG+4.)-BVG*LOG(LAMG))
3180 VTQG = MIN(RHOAJ*FSQG*AVG,VTGMAX)
3181 VTNG = MIN(RHOAJ*FSNG*AVG,VTGMAX)
3182 VTVG = MIN(RHOAJ*FSVG*AVG,VTGMAX)
3183 IF (AG1D.GE.ASMALL) THEN
3184 FSAG = EXP(GAMLN(BVG+AFAG+3.)-GAMLN(AFAG+3.)-BVG*LOG(LAMG))
3185 VTAG = MIN(RHOAJ*FSAG*AVG,VTGMAX)
3186 ENDIF
3187 ENDIF
3188 IF (QH1D.GE.QSMALL) THEN
3189 CALL SOLVE_AFAH(TK1D,RHO,QH1D,NH1D,AH1D,LAMH,AFAH,MVDH,AVH,BVH)
3190 FSQH = EXP(GAMLN(BVH+BMH+AFAH+1.)-GAMLN(BMH+AFAH+1.)-BVH* &
3191 LOG(LAMH))
3192 FSNH = EXP(GAMLN(BVH+AFAH+1.)-GAMLN(AFAH+1.)-BVH*LOG(LAMH))
3193 VTQH = MIN(RHOAJ*FSQH*AVH,VTHMAX)
3194 VTNH = MIN(RHOAJ*FSNH*AVH,VTHMAX)
3195 IF (AH1D.GE.ASMALL) THEN
3196 FSAH = EXP(GAMLN(BVH+AFAH+3.)-GAMLN(AFAH+3.)-BVH*LOG(LAMH))
3197 VTAH = MIN(RHOAJ*FSAH*AVH,VTHMAX)
3198 ENDIF
3199 ENDIF
3201 END SUBROUTINE SEDI_FALL
3202 !======================================================================
3203 !
3204 !======================================================================
3205 SUBROUTINE PTFLUX(Q1D,VT1D,RHO,DZ,NK,DT,DTMN,PRT1D)
3206 !======================================================================
3207 IMPLICIT NONE
3208 INTEGER :: K,NK,NS,NSTEP
3209 INTEGER, PARAMETER :: MAXSTP = 1000
3210 REAL :: PRT1D, &! input/output ; accumulative prcipitation (cm)
3211 DT, &! time step for integration(=2*DTMN*60 for leapfrog scheme)
3212 DTMN ! time step (min)
3213 REAL, DIMENSION(NK) :: Q1D,VT1D,RHO,DZ,DQDT
3214 !------------ FOR TENDENCIES DUE TO PRECIPITATION/SEDIMENTATION -------
3215 NSTEP = 1
3216 DO K = 1,NK
3217 NSTEP = MAX(NSTEP,INT(VT1D(K)*DT/DZ(K)+1.))
3218 IF (NSTEP.GT.80) THEN
3219 PRINT *,'IN PREFLUX',K,NSTEP,DT,VT1D(K),DZ(K),Q1D(K),RHO(K)
3220 ENDIF
3221 ENDDO
3222 IF (NSTEP.GT.MAXSTP) THEN
3223 PRINT *,'NSTEP FOR PRECIP. IS: ',NSTEP,VT1D,DT,DZ
3224 STOP
3225 ENDIF
3226 DO NS = 1,NSTEP
3227 DQDT(1) = -VT1D(1)*Q1D(1)/DZ(1)
3228 DO K = 2,NK,1
3229 DQDT(K) = (VT1D(K-1)*RHO(K-1)*Q1D(K-1)- &
3230 VT1D(K)*RHO(K)*Q1D(K))/(DZ(K)*RHO(K))
3231 ENDDO
3232 PRT1D = PRT1D+VT1D(NK)*RHO(NK)*Q1D(NK)*DTMN*60./REAL(NSTEP) ! accumulate precipitation [kg/m^2]; 1 kg/m^2 = 1 mm
3233 DO K = 1,NK
3234 Q1D(K) = Q1D(K)+DQDT(K)*DT/REAL(NSTEP)
3235 ENDDO
3236 ENDDO
3238 END SUBROUTINE PTFLUX
3239 !======================================================================
3240 !
3241 !======================================================================
3242 SUBROUTINE FLFLUX(Q1D,VT1D,RHO,DZ,NK,DT)
3243 !======================================================================
3244 IMPLICIT NONE
3245 INTEGER :: NSTEP,K,NK,NS
3246 INTEGER, PARAMETER :: MAXSTP = 1000
3247 REAL :: DT
3248 REAL, DIMENSION(NK) :: Q1D,VT1D,RHO,DZ,DQDT
3249 !-- INPUT DATA FOR STEPSIZE RK4 CALCULATION FOR TENDENCIES DUE TO PRECIPITATION/SEDIMENTATION
3250 NSTEP = 1
3251 DO K = 1,NK
3252 NSTEP = MAX(NSTEP,INT(VT1D(K)*DT/DZ(K)+1.))
3253 ENDDO
3254 DO NS = 1,NSTEP
3255 DQDT(1) = -VT1D(1)*Q1D(1)/DZ(1)
3256 DO K = 2,NK,1
3257 DQDT(K) = (VT1D(K-1)*RHO(K-1)*Q1D(K-1)- &
3258 VT1D(K)*RHO(K)*Q1D(K))/(DZ(K)*RHO(K))
3259 ENDDO
3260 DO K = 1,NK
3261 Q1D(K) = Q1D(K)+DQDT(K)*DT/REAL(NSTEP)
3262 ENDDO
3263 ENDDO
3265 END SUBROUTINE FLFLUX
3266 !======================================================================
3267 !
3268 !======================================================================
3269 SUBROUTINE SMALL_DT(DT,DTS,SDTS,DTKDT,DQVDT,DPDT,RHO,TK1D,P1D, &
3270 QV1D,QC1D,QR1D,QI1D,QS1D,QG1D,QH1D,NC1D,NR1D,NI1D, &
3271 NS1D,NG1D,NH1D,VI1D,VS1D,VG1D,FI1D,FS1D,AI1D,AS1D, &
3272 AG1D,AH1D,I3M1D,SASPR,XDNC,XDNR,GQCTR)
3273 !======================================================================
3274 IMPLICIT NONE
3275 INTEGER :: I,HID
3276 REAL :: DT,DTS,SDTS, &! TIME STEP(s)& SUB-TIME STEP(s)& DTS MUST<DT-SDTS
3277 DTKDT,DQVDT,DPDT ! TEMPERATURE,WATER VAPOR,PRESSURE FORCING
3278 REAL :: RHO,P1D,CPM,ESW,ESI,QVSW,QVSI,SSRW,SSRI,XXLV,XXLS,XXLF, &
3279 QV1D,TK1D,QC1D,QR1D,QI1D,QS1D,QG1D,QH1D,GQCTR,NC1D,NR1D, &
3280 NI1D,NS1D,NG1D,NH1D,VI1D,VS1D,VG1D,FI1D,FS1D,AI1D,AS1D, &
3281 AG1D,AH1D,I3M1D,AFAC,AFAR,AFAI,AFAS,AFAG,AFAH,ADAGR,ZETA,&
3282 AMI,BMI,AMS,AMG,AVI,BVI,AVS,BVS,AVG,BVG,AVH,BVH,DV,MUA, &
3283 KAP,SCN,TC1D,iDT,SASPR,ELCLD,ELDLD,ELCLC,CAPS
3284 REAL :: QVTEND,QCTEND,QRTEND,QITEND,QSTEND,QGTEND,QHTEND,RATIO, &
3285 QVSOUR,QCSOUR,QRSOUR,QISOUR,QSSOUR,QGSOUR,QHSOUR,QVSINK, &
3286 QCSINK,QRSINK,QISINK,QSSINK,QGSINK,QHSINK,NCSOUR,NISOUR, &
3287 NCSINK,NISINK,NSSOUR,NSSINK,FISOUR,FISINK,FSSOUR,FSSINK, &
3288 VISOUR,VISINK,VSSOUR,VSSINK,VGSOUR,VGSINK,AISOUR,AISINK, &
3289 ASSOUR,ASSINK,AGSOUR,AGSINK,AHSOUR,AHSINK,IISOUR,IISINK, &
3290 QVWTEND,QVITEND,DRHIDT,DRHWDT
3291 REAL :: XDNC ! deactivated cloud drops (#/kg) = NACcv*DTS
3292 REAL :: XDNR ! raindrop evap into cloud drop
3293 REAL :: DTSI ! TIME TO REACH RHI=100% (NEGATIVE MEANS THAT TIME IS)
3294 REAL :: DTSW ! TIME TO REACH RHW=100% (NEVER HAPPEN OR ALREADY PAST)
3295 REAL :: QACcv,QACrc,QVDvc,QVDvr,QVDvi,QVDvs,QVDvg,QVDvh,QSBiv, &
3296 QSBsv,QSBgv,QSBhv,QEVcv,QEVrv,QEVsv,QEVgv,QEVhv,NACcv, &
3297 NACrc,NSBiv,NSBsv,NSBgv,NSBhv,VVDvi,VSBiv,VVDvg,VSBgv, &
3298 VEVgv,FVDvi,VVDvs,VSBsv,VEVsv,FSBiv,FVDvs,FSBsv,FEVsv, &
3299 AVDvi,ASBiv,AVDvs,ASBsv,AEVsv,AVDvg,ASBgv,AEVgv,AVDvh, &
3300 ASBhv,AEVhv,IVDvi,ISBiv
3301 REAL :: MVDC,MVDR,MVDI,MVDS,MVDG,MVDH,MVRC,MVRR,BTMP,BSTMP,BGTMP,&
3302 BHTMP,ABW,ABI,RHOAJ,LMVRC,LMVRR,RHOI,RHOS,RHOG,VENQS, &
3303 VENQG,VENQH,SUMDEP,VDMAX,EVMAX,SBMAX,SUMCND,SUMEVP, &
3304 SUMSUB,H2Z,H4Z,ZETA2,ZETA3,ZETA4,ZETA5,GVHAB,IPH,IPG,GI1,&
3305 INHGR,BEST,DNIVD,DNSVD,DNGVD,QTMP0,QTMP1,QTMP2,QTMP3, &
3306 QTMP4,QTMP5,QTMP6,QTMP7,QTMP8,QTMP9,FTMP0,FTMP1,FTMP2, &
3307 FTMP3,FTMP4,FTMP5,FTMP6,FTMP7,FTMP8,FTMP9,ATMP0,ATMP1, &
3308 ATMP2,ATMP3,ATMP4,ATMP5,ATMP6,ATMP7,ATMP8,ATMP9,LAMC, &
3309 LAMR,LAMI,LAMS,LAMG,LAMH,VENQI,VENFI,VENAI,VENAS,VENAG, &
3310 VENAH,VENIC,VENIA,VENQI0,VENAI0,RAT1,RAT2,LLMI,LLMS,LLMG,&
3311 LLMH
3312 REAL, PARAMETER :: TORR = 1.E-2 ! for 0.01 changes
3313 REAL, PARAMETER :: AQ1 = 6.6793E+0, BQ1 = 1.0090E+0 ! See CL04 Tables
3314 REAL, PARAMETER :: CQ1 = 1.4095E+0, AQ2 = 9.9912E+0 !
3315 REAL, PARAMETER :: BQ2 = -4.7678E-1, CQ2 = -3.1388E-2 !
3316 REAL, PARAMETER :: AN9 = -1.0593E+0, BN9 = 8.9774E-1 !
3317 REAL, PARAMETER :: CN9 = -2.8403E-1, DN9 = 1.6328E+0 !
3318 REAL, PARAMETER :: AN10 = 8.2841E+0, BN10 = 9.7219E-1 !
3319 REAL, PARAMETER :: CN10 = -5.0808E-1 !
3320 REAL :: ZC1,ZC2,ZC3,ZC4,ZP1,ZP2,ZP3,ZP4 ! See CT16
3321 DATA ZC1,ZC2,ZC3,ZC4/0.69509913,-0.46685819,0.30490087,1.62148100/
3322 DATA ZP1,ZP2,ZP3,ZP4/0.36793126,1.82782890,0.63206874,-1.00164090/
3324 QVTEND = 0.; QVWTEND = 0.; QVITEND = 0.; QCTEND = 0.; QRTEND = 0.
3325 QITEND = 0.; QSTEND = 0.; QGTEND = 0.; QHTEND = 0.
3326 MVRC = 0.; MVRR = 0.; MVDC = 0.; MVDR = 0.; MVDI = 0.
3327 MVDS = 0.; MVDG = 0.; MVDH = 0.; QACcv = 0.; QACrc = 0.
3328 QVDvc = 0.; QVDvr = 0.; QVDvi = 0.; QVDvs = 0.; QVDvg = 0.
3329 QVDvh = 0.; QSBiv = 0.; QSBsv = 0.; QSBgv = 0.; QSBhv = 0.
3330 QEVcv = 0.; QEVrv = 0.; QEVsv = 0.; QEVgv = 0.; QEVhv = 0.
3331 NACcv = 0.; NACrc = 0.; NSBiv = 0.; NSBsv = 0.; NSBgv = 0.
3332 NSBhv = 0.; VVDvi = 0.; VSBiv = 0.; VVDvs = 0.; VSBsv = 0.
3333 VEVsv = 0.; VVDvg = 0.; VSBgv = 0.; VEVgv = 0.; FVDvi = 0.
3334 FSBiv = 0.; FVDvs = 0.; FSBsv = 0.; FEVsv = 0.; IVDvi = 0.
3335 ISBiv = 0.; AVDvi = 0.; ASBiv = 0.; AVDvs = 0.; ASBsv = 0.
3336 AEVsv = 0.; AVDvg = 0.; ASBgv = 0.; AEVgv = 0.; AVDvh = 0.
3337 ASBhv = 0.; AEVhv = 0.
3339 ESW = MIN(0.99*P1D,POLYSVP(TK1D,0))
3340 ESI = MIN(0.99*P1D,POLYSVP(TK1D,1))
3341 IF (ESI.GT.ESW) ESI = ESW
3342 QVSW = 0.622*ESW/(P1D-ESW)
3343 QVSI = 0.622*ESI/(P1D-ESI)
3344 SSRW = QV1D/QVSW-1.
3345 SSRI = QV1D/QVSI-1.
3346 XXLV = 3.1484E6-2370.*TK1D
3347 XXLS = 3.15E6-2370.*TK1D+0.3337E6
3348 XXLF = 2836310.8-(3.1484E6-2370.*TK1D)
3349 ELDLD = (1.+XXLS*XXLS*QV1D/(CP*RV*TK1D**2.))
3350 ELCLD = (1.+XXLV*XXLS*QV1D/(CP*RV*TK1D**2.))
3351 ELCLC = (1.+XXLV*XXLV*QV1D/(CP*RV*TK1D**2.))
3352 DRHWDT = (1.+SSRW)*(DPDT/P1D+DQVDT/QV1D-XXLV*DTKDT/(RV*TK1D**2.)) ! caused by large scale QV & P T changes
3353 DRHIDT = (1.+SSRI)*(DPDT/P1D+DQVDT/QV1D-XXLS*DTKDT/(RV*TK1D**2.)) ! caused by large scale QV & P T changes
3355 IF (ABS(DRHWDT).LT.RLIMIT) THEN
3356 DTSW = 1.E7 ! very long time to reach saturation
3357 ELSE
3358 DTSW = -SSRW/DRHWDT*1.01 ! time to reach saturation
3359 ENDIF ! negative means the right time has past
3360 IF (ABS(DRHIDT).LT.RLIMIT) THEN
3361 DTSI = 1.E7 ! very long time to reach saturation
3362 ELSE
3363 DTSI = -SSRI/DRHIDT*1.01 ! time to reach saturation
3364 ENDIF ! negative means the right time has past
3365 IF (TK1D.GT.TK0C) THEN
3366 IF (DTSW.GT.0.) DTS = MIN(DT,DTSW,DT-SDTS)
3367 ELSE
3368 IF (DTSI.GT.0.) DTS = MIN(DT,DTSI,DT-SDTS)
3369 IF (DTSW.GT.0.) DTS = MIN(DT,DTS,DTSW,DT-SDTS)
3370 ENDIF
3371 DTS = MAX(DTMIN,MIN(DT,DT-SDTS))
3373 iDT = 1./DTS
3374 TC1D = TK1D-TK0C
3375 DV = 2.11E-5*(TK1D/TK0C)**1.94*(101325./P1D) ! DIFFUSIVITY OF WATER VAPOR IN AIR(PRUPPACHER&KLETT:13-3)
3376 MUA = 1.72E-5*(393./(TK1D+120.))*(TK1D/TK0C)**1.5 ! DYNAMIC VISCOSITY OF AIR (ROGER AND YAU,P.102)
3377 KAP = 2.3971E-2+0.0078E-2*TC1D ! THERMAL CONDUCTIVITY OF AIR
3378 SCN = (MUA/(RHO*DV))**THRD ! SCHMIDT NUMBER
3379 CPM = CP*(1.+0.887*QV1D)
3380 ABW = TK1D*RV/ESW/DV+XXLV*(XXLV/TK1D/RV-1.)/TK1D/KAP
3381 ABI = TK1D*RV/ESI/DV+XXLS*(XXLS/TK1D/RV-1.)/TK1D/KAP
3382 RHOAJ = (RHOSU/RHO)**0.54
3383 HID = MAX(MIN(NINT(ABS(TC1D)/0.25),120),0)
3384 INHGR = ITBLE(HID)
3385 GVHAB = (INHGR-1.)/(INHGR+2.)+1.
3387 IF (QC1D.GE.QSMALL) THEN
3388 CALL SOLVE_AFAC(TK1D,QC1D,NC1D,LAMC,MVDC,AFAC)
3389 MVRC = MIN(MAX((QC1D/NC1D/C4PI3W)**THRD,RCMIN),RCMAX)
3390 LMVRC = LOG(MVRC)
3391 ENDIF
3392 IF (QR1D.GE.QSMALL) THEN
3393 CALL SOLVE_AFAR(TK1D,QR1D,NR1D,LAMR,MVDR,AFAR)
3394 MVRR = MIN(MAX((QR1D/NR1D/C4PI3W)**THRD,RRMIN),RRMAX)
3395 LMVRR = LOG(MVRR)
3396 ENDIF
3397 IF (QI1D.GE.QSMALL) THEN
3398 CALL SOLVE_AFAI(TK1D,P1D,RHO,QV1D,QI1D,NI1D,VI1D,FI1D,AI1D, &
3399 I3M1D,ADAGR,ZETA,LAMI,AFAI,MVDI,RHOI,AMI,BMI,AVI,BVI, &
3400 BEST)
3401 GI1 = GAMLN(AFAI+1.)
3402 LLMI = LOG(LAMI)
3403 IF (ICE_VENT.EQ.3) THEN
3404 IF ((ADAGR-1.).GE.SLIMIT) THEN
3405 BTMP = SCN*SQRT(AVI*RHOAJ/MUA)
3406 IPH = 3.*ADAGR/(ADAGR+2.)
3407 ZETA2 = 2.*(ADAGR-1.)/(ADAGR+2.)
3408 ZETA3 = 3.*(ADAGR-1.)/(ADAGR+2.)
3409 ZETA4 = 4.*(ADAGR-1.)/(ADAGR+2.)
3410 ZETA5 = 5.*(ADAGR-1.)/(ADAGR+2.)
3411 H2Z = ZC2*ZETA
3412 H4Z = ZC4*ZETA
3413 QTMP0 = EXP(GAMLN(H2Z+AFAI+2.)-GI1-LLMI*(H2Z+1.))
3414 QTMP1 = EXP(GAMLN(H4Z+AFAI+2.)-GI1-LLMI*(H4Z+1.))
3415 QTMP2 = LLMI*(H2Z+BVI/2.+IPH/2.+1.)
3416 QTMP3 = LLMI*(H4Z+BVI/2.+IPH/2.+1.)
3417 QTMP4 = EXP(GAMLN(H2Z+BVI/2.+IPH/2.+AFAI+2.)-GI1-QTMP2)
3418 QTMP5 = EXP(GAMLN(H4Z+BVI/2.+IPH/2.+AFAI+2.)-GI1-QTMP3)
3419 QTMP6 = LLMI*(H2Z+BVI+IPH+1.)
3420 QTMP7 = LLMI*(H4Z+BVI+IPH+1.)
3421 QTMP8 = EXP(GAMLN(H2Z+BVI+IPH+AFAI+2.)-GI1-QTMP6)
3422 QTMP9 = EXP(GAMLN(H4Z+BVI+IPH+AFAI+2.)-GI1-QTMP7)
3423 FTMP0 = EXP(GAMLN(H2Z+ZETA3+AFAI+2.)-GI1-LLMI*(H2Z+ZETA3+ &
3424 1.))
3425 FTMP1 = EXP(GAMLN(H4Z+ZETA3+AFAI+2.)-GI1-LLMI*(H4Z+ZETA3+ &
3426 1.))
3427 FTMP2 = LLMI*(H2Z+BVI/2.+IPH/2.+ZETA3+1.)
3428 FTMP3 = LLMI*(H4Z+BVI/2.+IPH/2.+ZETA3+1.)
3429 FTMP4 = EXP(GAMLN(H2Z+BVI/2.+IPH/2.+ZETA3+AFAI+2.)-GI1- &
3430 FTMP2)
3431 FTMP5 = EXP(GAMLN(H4Z+BVI/2.+IPH/2.+ZETA3+AFAI+2.)-GI1- &
3432 FTMP3)
3433 FTMP6 = LLMI*(H2Z+BVI+IPH+ZETA3+1.)
3434 FTMP7 = LLMI*(H4Z+BVI+IPH+ZETA3+1.)
3435 FTMP8 = EXP(GAMLN(H2Z+ZETA3+BVI+IPH+AFAI+2.)-GI1-FTMP6)
3436 FTMP9 = EXP(GAMLN(H4Z+ZETA3+BVI+IPH+AFAI+2.)-GI1-FTMP7)
3437 ATMP0 = EXP(GAMLN(H2Z+AFAI+1.)-GI1-LLMI*H2Z)
3438 ATMP1 = EXP(GAMLN(H4Z+AFAI+1.)-GI1-LLMI*H4Z)
3439 ATMP2 = LLMI*(H2Z+BVI/2.+IPH/2.+ZETA3)
3440 ATMP3 = LLMI*(H4Z+BVI/2.+IPH/2.+ZETA3)
3441 ATMP4 = EXP(GAMLN(H2Z+BVI/2.+IPH/2.+ZETA3+AFAI+1.)-GI1- &
3442 ATMP2)
3443 ATMP5 = EXP(GAMLN(H4Z+BVI/2.+IPH/2.+ZETA3+AFAI+1.)-GI1- &
3444 ATMP3)
3445 ATMP6 = LLMI*(H2Z+BVI+IPH)
3446 ATMP7 = LLMI*(H4Z+BVI+IPH)
3447 ATMP8 = EXP(GAMLN(H2Z+BVI+IPH+AFAI+1.)-GI1-ATMP6)
3448 ATMP9 = EXP(GAMLN(H4Z+BVI+IPH+AFAI+1.)-GI1-ATMP7)
3449 VENQI = ZC1*QTMP0/DI0**H2Z+ZC3*QTMP1/DI0**H4Z+VENC1*ZC1* &
3450 BTMP*QTMP4/DI0**(H2Z+ZETA)+VENC1*ZC3*BTMP*QTMP5/ &
3451 DI0**(H4Z+ZETA)+VENC2*ZC1*BTMP**2.*QTMP8/DI0**(H2Z+&
3452 ZETA2)+VENC2*ZC3*BTMP**2.*QTMP9/DI0**(H4Z+ZETA2)
3453 VENFI = ZC1*FTMP0/DI0**(ZETA3+H2Z)+ZC3*FTMP1/DI0**(ZETA3+ &
3454 H4Z)+VENC1*ZC1*BTMP*FTMP4/DI0**(H2Z+ZETA4)+VENC1* &
3455 ZC3*BTMP*FTMP5/DI0**(H4Z+ZETA4)+VENC2*ZC1*BTMP**2.*&
3456 FTMP8/DI0**(H2Z+ZETA5)+VENC2*ZC3*BTMP**2.*FTMP9/ &
3457 DI0**(H4Z+ZETA5)
3458 VENAI = ZC1*ATMP0/DI0**H2Z+ZC3*ATMP1/DI0**H4Z+VENC1*ZC1* &
3459 BTMP*ATMP4/DI0**(H2Z+ZETA)+VENC1*ZC3*BTMP*ATMP5/ &
3460 DI0**(H4Z+ZETA)+VENC2*ZC1*BTMP**2.*ATMP8/DI0**(H2Z+&
3461 ZETA2)+VENC2*ZC3*BTMP**2.*ATMP9/DI0**(H4Z+ZETA2)
3462 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
3463 BTMP = SCN*SQRT(AVI*RHOAJ/MUA)
3464 IPG = 3./(ADAGR+2.)
3465 ZETA2 = 2.*(ADAGR-1.)/(ADAGR+2.)
3466 ZETA3 = 3.*(ADAGR-1.)/(ADAGR+2.)
3467 ZETA4 = 2.5*(ADAGR-1.)/(ADAGR+2.)
3468 H2Z = ZP2*ZETA
3469 H4Z = ZP4*ZETA
3470 QTMP0 = EXP(GAMLN(H2Z+AFAI+2.)-GI1-LLMI*(H2Z+1.))
3471 QTMP1 = EXP(GAMLN(H4Z+AFAI+2.)-GI1-LLMI*(H4Z+1.))
3472 QTMP2 = LLMI*(H2Z+BVI/2.+IPG/2.+1.)
3473 QTMP3 = LLMI*(H4Z+BVI/2.+IPG/2.+1.)
3474 QTMP4 = EXP(GAMLN(H2Z+BVI/2.+IPG/2.+AFAI+2.)-GI1-QTMP2)
3475 QTMP5 = EXP(GAMLN(H4Z+BVI/2.+IPG/2.+AFAI+2.)-GI1-QTMP3)
3476 QTMP6 = LLMI*(H2Z+BVI+IPG+1.)
3477 QTMP7 = LLMI*(H4Z+BVI+IPG+1.)
3478 QTMP8 = EXP(GAMLN(H2Z+BVI+IPG+AFAI+2.)-GI1-QTMP6)
3479 QTMP9 = EXP(GAMLN(H4Z+BVI+IPG+AFAI+2.)-GI1-QTMP7)
3480 FTMP0 = EXP(GAMLN(H2Z+ZETA3+AFAI+2.)-GI1-LLMI*(H2Z+ZETA3+ &
3481 1.))
3482 FTMP1 = EXP(GAMLN(H4Z+ZETA3+AFAI+2.)-GI1-LLMI*(H4Z+ZETA3+ &
3483 1.))
3484 FTMP2 = LLMI*(H2Z+BVI/2.+IPG/2.+ZETA3+1.)
3485 FTMP3 = LLMI*(H4Z+BVI/2.+IPG/2.+ZETA3+1.)
3486 FTMP4 = EXP(GAMLN(H2Z+BVI/2.+IPG/2.+ZETA3+AFAI+2.)-GI1- &
3487 FTMP2)
3488 FTMP5 = EXP(GAMLN(H4Z+BVI/2.+IPG/2.+ZETA3+AFAI+2.)-GI1- &
3489 FTMP3)
3490 FTMP6 = LLMI*(H2Z+BVI+IPG+ZETA3+1.)
3491 FTMP7 = LLMI*(H4Z+BVI+IPG+ZETA3+1.)
3492 FTMP8 = EXP(GAMLN(H2Z+BVI+IPG+ZETA3+AFAI+2.)-GI1-FTMP6)
3493 FTMP9 = EXP(GAMLN(H4Z+BVI+IPG+ZETA3+AFAI+2.)-GI1-FTMP7)
3494 ATMP0 = EXP(GAMLN(H2Z+AFAI+1.)-GI1-LLMI*H2Z)
3495 ATMP1 = EXP(GAMLN(H4Z+AFAI+1.)-GI1-LLMI*H4Z)
3496 ATMP2 = LLMI*(H2Z+BVI/2.+IPG/2.)
3497 ATMP3 = LLMI*(H4Z+BVI/2.+IPG/2.)
3498 ATMP4 = EXP(GAMLN(H2Z+BVI/2.+IPG/2.+AFAI+1.)-GI1-ATMP2)
3499 ATMP5 = EXP(GAMLN(H4Z+BVI/2.+IPG/2.+AFAI+1.)-GI1-ATMP3)
3500 ATMP6 = LLMI*(H2Z+BVI+IPG)
3501 ATMP7 = LLMI*(H4Z+BVI+IPG)
3502 ATMP8 = EXP(GAMLN(H2Z+BVI+IPG+AFAI+1.)-GI1-ATMP6)
3503 ATMP9 = EXP(GAMLN(H4Z+BVI+IPG+AFAI+1.)-GI1-ATMP7)
3504 VENQI = ZP1*QTMP0/DI0**H2Z+ZP3*QTMP1/DI0**H4Z+VENP1*ZP1* &
3505 BTMP*QTMP4/DI0**(H2Z-ZETA/2.)+VENP1*ZP3*BTMP*QTMP5/&
3506 DI0**(H4Z-ZETA/2.)+VENP2*ZP1*BTMP**2.*QTMP8/DI0** &
3507 (H2Z-ZETA)+VENP2*ZP3*BTMP**2.*QTMP9/DI0**(H4Z-ZETA)
3508 VENFI = ZP1*FTMP0/DI0**(H2Z+ZETA3)+ZP3*FTMP1/DI0**(H4Z+ &
3509 ZETA3)+VENP1*ZP1*BTMP*FTMP4/DI0**(H2Z+ZETA4)+VENP1*&
3510 ZP3*BTMP*FTMP5/DI0**(H4Z+ZETA4)+VENP2*ZP1*BTMP**2.*&
3511 FTMP8/DI0**(H2Z+ZETA2)+VENP2*ZP3*BTMP**2.*FTMP9/ &
3512 DI0**(H4Z+ZETA2)
3513 VENAI = ZP1*ATMP0/DI0**H2Z+ZP3*ATMP1/DI0**H4Z+VENP1*ZP1* &
3514 BTMP*ATMP4/DI0**(H2Z-ZETA/2.)+VENP1*ZP3*BTMP*ATMP5/&
3515 DI0**(H4Z-ZETA/2.)+VENP2*ZP1*BTMP**2.*ATMP8/DI0**( &
3516 H2Z-ZETA)+VENP2*ZP3*BTMP**2.*ATMP9/DI0**(H4Z-ZETA)
3517 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
3518 BTMP = SCN*SQRT(AVI*RHOAJ/MUA)
3519 QTMP0 = EXP(GAMLN(AFAI+2.)-GI1-LOG(LAMI))
3520 QTMP1 = LLMI*(1.5+BVI/2.)
3521 QTMP2 = EXP(GAMLN(BVI/2.+AFAI+2.5)-GI1-QTMP1)
3522 ATMP1 = LLMI*(0.5+BVI/2.)
3523 ATMP2 = EXP(GAMLN(BVI/2.+AFAI+1.5)-GI1-ATMP1)
3524 VENQI = AVSG*QTMP0+BVSG*BTMP*QTMP2
3525 VENFI = VENQI
3526 VENAI = AVSG+BVSG*BTMP*ATMP2
3527 ENDIF
3528 ELSEIF (ICE_VENT.EQ.1.OR.ICE_VENT.EQ.2) THEN
3529 IF ((ADAGR-1.).GE.SLIMIT) THEN
3530 IPH = 3.*ADAGR/(ADAGR+2.)
3531 IPG = 3./(ADAGR+2.)
3532 ZETA2 = 2.*(ADAGR-1.)/(ADAGR+2.)
3533 ZETA3 = 3.*(ADAGR-1.)/(ADAGR+2.)
3534 ZETA4 = 4.*(ADAGR-1.)/(ADAGR+2.)
3535 ZETA5 = 5.*(ADAGR-1.)/(ADAGR+2.)
3536 H2Z = ZC2*ZETA
3537 H4Z = ZC4*ZETA
3538 QTMP0 = EXP(GAMLN(H2Z+AFAI+2.)-GI1-LLMI*(H2Z+1.))
3539 QTMP1 = EXP(GAMLN(H4Z+AFAI+2.)-GI1-LLMI*(H4Z+1.))
3540 FTMP0 = EXP(GAMLN(H2Z+ZETA3+AFAI+2.)-GI1-LLMI*(H2Z+ZETA3+ &
3541 1.))
3542 FTMP1 = EXP(GAMLN(H4Z+ZETA3+AFAI+2.)-GI1-LLMI*(H4Z+ZETA3+ &
3543 1.))
3544 ATMP0 = EXP(GAMLN(H2Z+AFAI+1.)-GI1-LLMI*H2Z)
3545 ATMP1 = EXP(GAMLN(H4Z+AFAI+1.)-GI1-LLMI*H4Z)
3546 IF (BEST.LE.1.) THEN
3547 BTMP = SCN**2.*(AVI*RHOAJ/MUA)
3548 QTMP2 = LLMI*(H2Z+BVI+IPH+1.)
3549 QTMP3 = LLMI*(H4Z+BVI+IPH+1.)
3550 QTMP4 = EXP(GAMLN(H2Z+BVI+IPH+AFAI+2.)-GI1-QTMP2)
3551 QTMP5 = EXP(GAMLN(H4Z+BVI+IPH+AFAI+2.)-GI1-QTMP3)
3552 FTMP2 = LLMI*(H2Z+BVI+IPH+ZETA3+1.)
3553 FTMP3 = LLMI*(H4Z+BVI+IPH+ZETA3+1.)
3554 FTMP4 = EXP(GAMLN(H2Z+BVI+IPH+ZETA3+AFAI+2.)-GI1-FTMP2)
3555 FTMP5 = EXP(GAMLN(H4Z+BVI+IPH+ZETA3+AFAI+2.)-GI1-FTMP3)
3556 ATMP2 = LLMI*(H2Z+BVI+IPH)
3557 ATMP3 = LLMI*(H4Z+BVI+IPH)
3558 ATMP4 = EXP(GAMLN(H2Z+BVI+IPH+AFAI+1.)-GI1-ATMP2)
3559 ATMP5 = EXP(GAMLN(H4Z+BVI+IPH+AFAI+1.)-GI1-ATMP3)
3560 VENQI = AVIS*ZC1*QTMP0/DI0**H2Z+AVIS*ZC3*QTMP1/DI0**H4Z+&
3561 BVIS*ZC1*BTMP*QTMP4/DI0**(H2Z+ZETA2)+BVIS*ZC3* &
3562 BTMP*QTMP5/DI0**(H4Z+ZETA2)
3563 VENFI = AVIS*ZC1*FTMP0/DI0**(ZETA3+H2Z)+AVIS*ZC3*FTMP1/ &
3564 DI0**(H4Z+ZETA3)+BVIS*ZC1*BTMP*FTMP4/DI0**(H2Z+ &
3565 ZETA5)+BVIS*ZC3*BTMP*FTMP5/DI0**(H4Z+ZETA5)
3566 VENAI = AVIS*ZC1*ATMP0/DI0**H2Z+AVIS*ZC3*ATMP1/DI0**H4Z+&
3567 BVIS*ZC1*BTMP*ATMP4/DI0**(H2Z+ZETA2)+BVIS*ZC3* &
3568 BTMP*ATMP5/DI0**(H4Z+ZETA2)
3569 IF (ICE_VENT.EQ.2) THEN
3570 QTMP6 = LLMI*(BVI+IPH)
3571 QTMP7 = LLMI*(BVI+IPG)
3572 QTMP8 = EXP(GAMLN(BVI+IPH+AFAI+1.)-GI1-QTMP6)
3573 QTMP9 = EXP(GAMLN(BVI+IPG+AFAI+1.)-GI1-QTMP7)
3574 VENIC = AVIS+BVIS*BTMP*QTMP8/DI0**ZETA2
3575 VENIA = AVIS+BVIS*BTMP*QTMP9*DI0**ZETA
3576 INHGR = INHGR*VENIC/VENIA
3577 GVHAB = (INHGR-1.)/(INHGR+2.)+1.
3578 ENDIF
3579 ELSEIF (BEST.GT.1.) THEN
3580 BTMP = SCN*SQRT(AVI*RHOAJ/MUA)
3581 QTMP2 = LLMI*(H2Z+BVI/2.+IPH/2.+1.)
3582 QTMP3 = LLMI*(H4Z+BVI/2.+IPH/2.+1.)
3583 QTMP4 = EXP(GAMLN(H2Z+BVI/2.+IPH/2.+AFAI+2.)-GI1-QTMP2)
3584 QTMP5 = EXP(GAMLN(H4Z+BVI/2.+IPH/2.+AFAI+2.)-GI1-QTMP3)
3585 FTMP2 = LLMI*(H2Z+BVI/2.+IPH/2.+ZETA3+1.)
3586 FTMP3 = LLMI*(H4Z+BVI/2.+IPH/2.+ZETA3+1.)
3587 FTMP4 = EXP(GAMLN(H2Z+BVI/2.+IPH/2.+ZETA3+AFAI+2.)-GI1- &
3588 FTMP2)
3589 FTMP5 = EXP(GAMLN(H4Z+BVI/2.+IPH/2.+ZETA3+AFAI+2.)-GI1- &
3590 FTMP3)
3591 ATMP2 = LLMI*(H2Z+BVI/2.+IPH/2.+ZETA3)
3592 ATMP3 = LLMI*(H4Z+BVI/2.+IPH/2.+ZETA3)
3593 ATMP4 = EXP(GAMLN(H2Z+BVI/2.+IPH/2.+ZETA3+AFAI+1.)-GI1- &
3594 ATMP2)
3595 ATMP5 = EXP(GAMLN(H4Z+BVI/2.+IPH/2.+ZETA3+AFAI+1.)-GI1- &
3596 ATMP3)
3597 VENQI = AVSG*ZC1*QTMP0/DI0**H2Z+AVSG*ZC3*QTMP1/DI0**H4Z+&
3598 BVSG*ZC1*BTMP*QTMP4/DI0**(H2Z+ZETA)+BVSG*ZC3* &
3599 BTMP*QTMP5/DI0**(H4Z+ZETA)
3600 VENFI = AVSG*ZC1*FTMP0/DI0**(ZETA3+H2Z)+AVSG*ZC3*FTMP1/ &
3601 DI0**(H4Z+ZETA3)+BVSG*ZC1*BTMP*FTMP4/DI0**(H2Z+ &
3602 ZETA4)+BVSG*ZC3*BTMP*FTMP5/DI0**(H4Z+ZETA4)
3603 VENAI = AVSG*ZC1*ATMP0/DI0**H2Z+AVSG*ZC3*ATMP1/DI0**H4Z+&
3604 BVSG*ZC1*BTMP*ATMP4/DI0**(H2Z+ZETA)+BVSG*ZC3* &
3605 BTMP*ATMP5/DI0**(H4Z+ZETA)
3606 IF (ICE_VENT.EQ.2) THEN
3607 QTMP6 = LLMI*(BVI/2.+IPH/2.)
3608 QTMP7 = LLMI*(BVI/2.+IPG/2.)
3609 QTMP8 = EXP(GAMLN(BVI/2.+IPH/2.+AFAI+1.)-GI1-QTMP6)
3610 QTMP9 = EXP(GAMLN(BVI/2.+IPG/2.+AFAI+1.)-GI1-QTMP7)
3611 VENIC = AVSG+BVSG*BTMP*QTMP8/DI0**ZETA
3612 VENIA = AVSG+BVSG*BTMP*QTMP9*DI0**(ZETA/2.)
3613 INHGR = INHGR*VENIC/VENIA
3614 GVHAB = (INHGR-1.)/(INHGR+2.)+1.
3615 ENDIF
3616 ENDIF
3617 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
3618 IPG = 3./(ADAGR+2.)
3619 IPH = 3.*ADAGR/(ADAGR+2.)
3620 ZETA2 = 2.*(ADAGR-1.)/(ADAGR+2.)
3621 ZETA3 = 3.*(ADAGR-1.)/(ADAGR+2.)
3622 ZETA4 = 2.5*(ADAGR-1.)/(ADAGR+2.)
3623 H2Z = ZP2*ZETA
3624 H4Z = ZP4*ZETA
3625 QTMP0 = EXP(GAMLN(H2Z+AFAI+2.)-GI1-LLMI*(H2Z+1.))
3626 QTMP1 = EXP(GAMLN(H4Z+AFAI+2.)-GI1-LLMI*(H4Z+1.))
3627 FTMP0 = EXP(GAMLN(H2Z+ZETA3+AFAI+2.)-GI1-LLMI*(H2Z+ZETA3+ &
3628 1.))
3629 FTMP1 = EXP(GAMLN(H4Z+ZETA3+AFAI+2.)-GI1-LLMI*(H4Z+ZETA3+ &
3630 1.))
3631 ATMP0 = EXP(GAMLN(H2Z+AFAI+1.)-GI1-LLMI*H2Z)
3632 ATMP1 = EXP(GAMLN(H4Z+AFAI+1.)-GI1-LLMI*H4Z)
3633 IF (BEST.LE.1.) THEN
3634 BTMP = SCN**2.*(AVI*RHOAJ/MUA)
3635 QTMP2 = LLMI*(H2Z+BVI+IPG+1.)
3636 QTMP3 = LLMI*(H4Z+BVI+IPG+1.)
3637 QTMP4 = EXP(GAMLN(H2Z+BVI+IPG+AFAI+2.)-GI1-QTMP2)
3638 QTMP5 = EXP(GAMLN(H4Z+BVI+IPG+AFAI+2.)-GI1-QTMP3)
3639 FTMP2 = LLMI*(H2Z+BVI+IPG+ZETA3+1.)
3640 FTMP3 = LLMI*(H4Z+BVI+IPG+ZETA3+1.)
3641 FTMP4 = EXP(GAMLN(H2Z+BVI+IPG+ZETA3+AFAI+2.)-GI1-FTMP2)
3642 FTMP5 = EXP(GAMLN(H4Z+BVI+IPG+ZETA3+AFAI+2.)-GI1-FTMP3)
3643 ATMP2 = LLMI*(H2Z+BVI+IPG)
3644 ATMP3 = LLMI*(H4Z+BVI+IPG)
3645 ATMP4 = EXP(GAMLN(H2Z+BVI+IPG+AFAI+1.)-GI1-ATMP2)
3646 ATMP5 = EXP(GAMLN(H4Z+BVI+IPG+AFAI+1.)-GI1-ATMP3)
3647 VENQI = AVIS*ZP1*QTMP0/DI0**H2Z+AVIS*ZP3*QTMP1/DI0**H4Z+&
3648 BVIS*ZP1*BTMP*QTMP4/DI0**(H2Z-ZETA)+BVIS*ZP3* &
3649 BTMP*QTMP5/DI0**(H4Z-ZETA)
3650 VENFI = AVIS*ZP1*FTMP0/DI0**(ZETA3+H2Z)+AVIS*ZP3*FTMP1/ &
3651 DI0**(H4Z+ZETA3)+BVIS*ZP1*BTMP*FTMP4/DI0**(H2Z+ &
3652 ZETA2)+BVIS*ZP3*BTMP*FTMP5/DI0**(H4Z+ZETA2)
3653 VENAI = AVIS*ZP1*ATMP0/DI0**H2Z+AVIS*ZP3*ATMP1/DI0**H4Z+&
3654 BVIS*ZP1*BTMP*ATMP4/DI0**(H2Z-ZETA)+BVIS*ZP3* &
3655 BTMP*ATMP5/DI0**(H4Z-ZETA)
3656 IF (ICE_VENT.EQ.2) THEN
3657 QTMP6 = LLMI*(BVI+IPH)
3658 QTMP7 = LLMI*(BVI+IPG)
3659 QTMP8 = EXP(GAMLN(BVI+IPH+AFAI+1.)-GI1-QTMP6)
3660 QTMP9 = EXP(GAMLN(BVI+IPG+AFAI+1.)-GI1-QTMP7)
3661 VENIC = AVIS+BVIS*BTMP*QTMP8/DI0**ZETA2
3662 VENIA = AVIS+BVIS*BTMP*QTMP9*DI0**ZETA
3663 INHGR = INHGR*VENIC/VENIA
3664 GVHAB = (INHGR-1.)/(INHGR+2.)+1.
3665 ENDIF
3666 ELSEIF (BEST.GT.1.) THEN
3667 BTMP = SCN*SQRT(AVI*RHOAJ/MUA)
3668 QTMP2 = LLMI*(H2Z+BVI/2.+IPG/2.+1.)
3669 QTMP3 = LLMI*(H4Z+BVI/2.+IPG/2.+1.)
3670 QTMP4 = EXP(GAMLN(H2Z+BVI/2.+IPG/2.+AFAI+2.)-GI1-QTMP2)
3671 QTMP5 = EXP(GAMLN(H4Z+BVI/2.+IPG/2.+AFAI+2.)-GI1-QTMP3)
3672 FTMP2 = LLMI*(H2Z+BVI/2.+IPG/2.+ZETA3+1.)
3673 FTMP3 = LLMI*(H4Z+BVI/2.+IPG/2.+ZETA3+1.)
3674 FTMP4 = EXP(GAMLN(H2Z+BVI/2.+IPG/2.+ZETA3+AFAI+2.)-GI1- &
3675 FTMP2)
3676 FTMP5 = EXP(GAMLN(H4Z+BVI/2.+IPG/2.+ZETA3+AFAI+2.)-GI1- &
3677 FTMP3)
3678 ATMP2 = LLMI*(H2Z+BVI/2.+IPG/2.)
3679 ATMP3 = LLMI*(H4Z+BVI/2.+IPG/2.)
3680 ATMP4 = EXP(GAMLN(H2Z+BVI/2.+IPG/2.+AFAI+1.)-GI1-ATMP2)
3681 ATMP5 = EXP(GAMLN(H4Z+BVI/2.+IPG/2.+AFAI+1.)-GI1-ATMP3)
3682 VENQI = AVSG*ZP1*QTMP0/DI0**H2Z+AVSG*ZP3*QTMP1/DI0**H4Z+&
3683 BVSG*ZP1*BTMP*QTMP4/DI0**(H2Z-ZETA/2.)+BVSG*ZP3*&
3684 BTMP*QTMP5/DI0**(H4Z-ZETA/2.)
3685 VENFI = AVSG*ZP1*FTMP0/DI0**(ZETA3+H2Z)+AVSG*ZP3*FTMP1/ &
3686 DI0**(H4Z+ZETA3)+BVSG*ZP1*BTMP*FTMP4/DI0**(H2Z+ &
3687 ZETA4)+BVSG*ZP3*BTMP*FTMP5/DI0**(H4Z+ZETA4)
3688 VENAI = AVSG*ZP1*ATMP0/DI0**H2Z+AVSG*ZP3*ATMP1/DI0**H4Z+&
3689 BVSG*ZP1*BTMP*ATMP4/DI0**(H2Z-ZETA/2.)+BVSG*ZP3*&
3690 BTMP*ATMP5/DI0**(H4Z-ZETA/2.)
3691 IF (ICE_VENT.EQ.2) THEN
3692 QTMP6 = LLMI*(BVI/2.+IPH/2.)
3693 QTMP7 = LLMI*(BVI/2.+IPG/2.)
3694 QTMP8 = EXP(GAMLN(BVI/2.+IPH/2.+AFAI+1.)-GI1-QTMP6)
3695 QTMP9 = EXP(GAMLN(BVI/2.+IPG/2.+AFAI+1.)-GI1-QTMP7)
3696 VENIC = AVSG+BVSG*BTMP*QTMP8/DI0**ZETA
3697 VENIA = AVSG+BVSG*BTMP*QTMP9*DI0**(ZETA/2.)
3698 INHGR = INHGR*VENIC/VENIA
3699 GVHAB = (INHGR-1.)/(INHGR+2.)+1.
3700 ENDIF
3701 ENDIF
3702 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
3703 QTMP0 = EXP(GAMLN(AFAI+2.)-GI1-LOG(LAMI))
3704 IF (BEST.LE.1.) THEN
3705 BTMP = SCN**2.*(AVI*RHOAJ/MUA)
3706 QTMP2 = LLMI*(2.+BVI)
3707 QTMP3 = EXP(GAMLN(BVI+AFAI+3.)-GI1-QTMP2)
3708 ATMP2 = LLMI*(1.+BVI)
3709 ATMP3 = EXP(GAMLN(BVI+AFAI+2.)-GI1-ATMP2)
3710 VENQI = AVIS*QTMP0+BVIS*BTMP*QTMP3
3711 VENFI = VENQI
3712 VENAI = AVIS+BVIS*BTMP*ATMP3
3713 ELSEIF (BEST.GT.1.) THEN
3714 BTMP = SCN*SQRT(AVI*RHOAJ/MUA)
3715 QTMP2 = LLMI*(1.5+BVI/2.)
3716 QTMP3 = EXP(GAMLN(BVI/2.+AFAI+2.5)-GI1-QTMP2)
3717 ATMP2 = LLMI*(0.5+BVI/2.)
3718 ATMP3 = EXP(GAMLN(BVI/2.+AFAI+1.5)-GI1-ATMP2)
3719 VENQI = AVSG*QTMP0+BVSG*BTMP*QTMP3
3720 VENFI = VENQI
3721 VENAI = AVSG+BVSG*BTMP*ATMP3
3722 ENDIF
3723 ENDIF
3724 ELSEIF (ICE_VENT.EQ.0) THEN
3725 IF ((ADAGR-1.).GE.SLIMIT) THEN
3726 H2Z = ZC2*ZETA
3727 H4Z = ZC4*ZETA
3728 ZETA3 = 3.*(ADAGR-1.)/(ADAGR+2.)
3729 QTMP0 = EXP(GAMLN(H2Z+AFAI+2.)-GI1-LLMI*(H2Z+1.))
3730 QTMP1 = EXP(GAMLN(H4Z+AFAI+2.)-GI1-LLMI*(H4Z+1.))
3731 FTMP0 = EXP(GAMLN(H2Z+ZETA3+AFAI+2.)-GI1-LLMI*(H2Z+ZETA3+ &
3732 1.))
3733 FTMP1 = EXP(GAMLN(H4Z+ZETA3+AFAI+2.)-GI1-LLMI*(H4Z+ZETA3+ &
3734 1.))
3735 ATMP0 = EXP(GAMLN(H2Z+AFAI+1.)-GI1-LLMI*H2Z)
3736 ATMP1 = EXP(GAMLN(H4Z+AFAI+1.)-GI1-LLMI*H4Z)
3737 VENQI = ZC1*QTMP0/DI0**H2Z+ZC3*QTMP1/DI0**H4Z
3738 VENFI = ZC1*FTMP0/DI0**(H2Z+ZETA3)+ZC3*FTMP1/DI0**(H4Z+ &
3739 ZETA3)
3740 VENAI = ZC1*ATMP0/DI0**H2Z+ZC3*ATMP1/DI0**H4Z
3741 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
3742 H2Z = ZP2*ZETA
3743 H4Z = ZP4*ZETA
3744 ZETA3 = 3.*(ADAGR-1.)/(ADAGR+2.)
3745 QTMP0 = EXP(GAMLN(H2Z+AFAI+2.)-GI1-LLMI*(H2Z+1.))
3746 QTMP1 = EXP(GAMLN(H4Z+AFAI+2.)-GI1-LLMI*(H4Z+1.))
3747 FTMP0 = EXP(GAMLN(H2Z+ZETA3+AFAI+2.)-GI1-LLMI*(H2Z+ZETA3+ &
3748 1.))
3749 FTMP1 = EXP(GAMLN(H4Z+ZETA3+AFAI+2.)-GI1-LLMI*(H4Z+ZETA3+ &
3750 1.))
3751 ATMP0 = EXP(GAMLN(H2Z+AFAI+1.)-GI1-LLMI*H2Z)
3752 ATMP1 = EXP(GAMLN(H4Z+AFAI+1.)-GI1-LLMI*H4Z)
3753 VENQI = ZP1*QTMP0/DI0**H2Z+ZP3*QTMP1/DI0**H4Z
3754 VENFI = ZP1*FTMP0/DI0**(H2Z+ZETA3)+ZP3*FTMP1/DI0**(H4Z+ &
3755 ZETA3)
3756 VENAI = ZP1*ATMP0/DI0**H2Z+ZP3*ATMP1/DI0**H4Z
3757 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
3758 VENQI = EXP(GAMLN(AFAI+2.)-GI1-LOG(LAMI))
3759 VENFI = VENQI
3760 VENAI = 1.
3761 ENDIF
3762 ENDIF ! ICE_VENT
3763 IF (ICE_SHAPE.EQ.1.AND.AFAI.LE.20.) THEN
3764 QTMP0 = EXP(GAMLN(AFAI+2.)-GI1-LOG(LAMI))
3765 ATMP0 = EXP(GAMLN(AFAI+1.)-GI1-LOG(LAMI))
3766 IF (ICE_VENT.EQ.3) THEN
3767 BTMP = SCN*SQRT(AVI*RHOAJ/MUA)
3768 QTMP1 = LLMI*(1.5+BVI/2.)
3769 QTMP2 = EXP(GAMLN(BVI/2.+AFAI+2.5)-GI1-QTMP1)
3770 ATMP1 = LLMI*(0.5+BVI/2.)
3771 ATMP2 = EXP(GAMLN(BVI/2.+AFAI+1.5)-GI1-ATMP1)
3772 VENQI0 = AVSG*QTMP0+BVSG*BTMP*QTMP2
3773 VENAI0 = AVSG*ATMP0+BVSG*BTMP*ATMP2
3774 ELSEIF (ICE_VENT.EQ.1.OR.ICE_VENT.EQ.2) THEN
3775 IF (BEST.LE.1.) THEN
3776 BTMP = SCN**2.*(AVI*RHOAJ/MUA)
3777 QTMP2 = LLMI*(2.+BVI)
3778 QTMP3 = EXP(GAMLN(BVI+AFAI+3.)-GI1-QTMP2)
3779 ATMP2 = LLMI*(1.+BVI)
3780 ATMP3 = EXP(GAMLN(BVI+AFAI+2.)-GI1-ATMP2)
3781 VENQI0 = AVIS*QTMP0+BVIS*BTMP*QTMP3
3782 VENAI0 = AVIS*ATMP0+BVIS*BTMP*ATMP3
3783 ELSEIF (BEST.GT.1.) THEN
3784 BTMP = SCN*SQRT(AVI*RHOAJ/MUA)
3785 QTMP2 = LLMI*(1.5+BVI/2.)
3786 QTMP3 = EXP(GAMLN(BVI/2.+AFAI+2.5)-GI1-QTMP2)
3787 ATMP2 = LLMI*(0.5+BVI/2.)
3788 ATMP3 = EXP(GAMLN(BVI/2.+AFAI+1.5)-GI1-ATMP2)
3789 VENQI0 = AVSG*QTMP0+BVSG*BTMP*QTMP3
3790 VENAI0 = AVSG*ATMP0+BVSG*BTMP*ATMP3
3791 ENDIF
3792 ELSEIF (ICE_VENT.EQ.0) THEN
3793 VENQI0 = EXP(GAMLN(AFAI+2.)-GI1-LOG(LAMI))
3794 VENAI0 = EXP(GAMLN(AFAI+1.)-GI1-LOG(LAMI))
3795 ENDIF
3796 ENDIF ! DI0_CORRECTION
3797 ELSE
3798 ADAGR = 1.
3799 ZETA = 0.
3800 ENDIF ! QI SMALL
3801 IF (QS1D.GE.QSMALL) THEN
3802 CALL SOLVE_AFAS(TK1D,RHO,QS1D,QC1D,NS1D,VS1D,FS1D,AS1D,AFAS, &
3803 LAMS,MVDS,RHOS,SASPR,AMS,AVS,BVS)
3804 LLMS = LOG(LAMS)
3805 BSTMP = SCN*SQRT(AVS*RHOAJ/MUA)
3806 QTMP1 = LLMS*(1.5+BVS/2.)
3807 QTMP2 = EXP(GAMLN(AFAS+2.)-GAMLN(AFAS+1.)-LOG(LAMS))
3808 QTMP3 = EXP(GAMLN(BVS/2.+AFAS+2.5)-GAMLN(AFAS+1.)-QTMP1)
3809 ATMP1 = LLMS*(0.5+BVS/2.)
3810 ATMP2 = EXP(GAMLN(BVS/2.+AFAS+1.5)-GAMLN(AFAS+1.)-ATMP1)
3811 CAPS = ZP1*SASPR**(ZP2/3.)+ZP3*SASPR**(ZP4/3.)
3812 VENQS = AVSG*QTMP2*CAPS+BVSG*BSTMP*QTMP3*CAPS
3813 VENAS = AVSG*CAPS+BVSG*BSTMP*ATMP2*CAPS
3814 ENDIF
3815 IF (QG1D.GE.QSMALL) THEN
3816 CALL SOLVE_AFAG(TK1D,RHO,QG1D,QC1D,NG1D,VG1D,AG1D,LAMG,AFAG, &
3817 MVDG,RHOG,AMG,AVG,BVG)
3818 LLMG = LOG(LAMG)
3819 BGTMP = SCN*SQRT(AVG*RHOAJ/MUA)
3820 QTMP1 = LLMG*(1.5+BVG/2.)
3821 QTMP2 = EXP(GAMLN(AFAG+2.)-GAMLN(AFAG+1.)-LOG(LAMG))
3822 QTMP3 = EXP(GAMLN(BVG/2.+AFAG+2.5)-GAMLN(AFAG+1.)-QTMP1)
3823 ATMP1 = LLMG*(0.5+BVG/2.)
3824 ATMP2 = EXP(GAMLN(BVG/2.+AFAG+1.5)-GAMLN(AFAG+1.)-ATMP1)
3825 VENQG = AVSG*QTMP2+BVSG*BGTMP*QTMP3
3826 VENAG = AVSG+BVSG*BGTMP*ATMP2
3827 ENDIF
3828 IF (QH1D.GE.QSMALL) THEN
3829 CALL SOLVE_AFAH(TK1D,RHO,QH1D,NH1D,AH1D,LAMH,AFAH,MVDH,AVH,BVH)
3830 LLMH = LOG(LAMH)
3831 BHTMP = SCN*SQRT(AVH*RHOAJ/MUA)
3832 IF (HAIL_VENT.EQ.0) THEN
3833 QTMP1 = LLMH*(1.5+BVH/2.)
3834 QTMP2 = EXP(GAMLN(AFAH+2.)-GAMLN(AFAH+1.)-LOG(LAMH))
3835 QTMP3 = EXP(GAMLN(BVH/2.+AFAH+2.5)-GAMLN(AFAH+1.)-QTMP1)
3836 ATMP1 = LLMH*(0.5+BVH/2.)
3837 ATMP2 = EXP(GAMLN(BVH/2.+AFAH+1.5)-GAMLN(AFAH+1.)-ATMP1)
3838 VENQH = AVRH*QTMP2+BVRH*BHTMP*QTMP3
3839 VENAH = AVRH+BVRH*BHTMP*ATMP2
3840 ELSEIF (HAIL_VENT.EQ.1) THEN
3841 QTMP1 = LLMH*(1.5+BVH/2.)
3842 QTMP2 = EXP(GAMLN(AFAH+2.)-GAMLN(AFAH+1.)-LOG(LAMH))
3843 QTMP3 = EXP(GAMLN(BVH/2.+AFAH+2.5)-GAMLN(AFAH+1.)-QTMP1)
3844 QTMP4 = LLMH*(2.+BVH)
3845 QTMP5 = EXP(GAMLN(BVH+AFAH+3.)-GAMLN(AFAH+1.)-QTMP4)
3846 ATMP1 = LLMH*(0.5+BVH/2.)
3847 ATMP2 = EXP(GAMLN(BVH/2.+AFAH+1.5)-GAMLN(AFAH+1.)-ATMP1)
3848 ATMP3 = LLMH*(1.+BVH)
3849 ATMP4 = EXP(GAMLN(BVH+AFAH+2.)-GAMLN(AFAH+1.)-ATMP3)
3850 VENQH = QTMP2+VENH1*BHTMP*QTMP3+VENH2*BHTMP**2.*QTMP5
3851 VENAH = 1.+VENH1*BHTMP*ATMP2+VENH2*BHTMP**2.*ATMP4
3852 ENDIF
3853 ENDIF
3854 !----------------- WARM RAIN PROCESSES ---------------------------------
3855 IF (QC1D.GE.QSMALL) THEN
3856 IF (SSRW.GT.RSMALL) THEN
3857 QVDvc = SSRW*EXP(AQ1+BQ1*LOG(NC1D)+CQ1*LMVRC)/ABW ! diffusion growth of cloud drops
3858 ELSEIF (SSRW.LT.(-1.*RSMALL)) THEN
3859 QEVcv = MIN(SSRW*EXP(AQ1+BQ1*LOG(NC1D)+CQ1*LMVRC)/ABW,0.) ! diffusion growth of cloud drops
3860 NACcv = -1.*EXP(AN9+BN9*LOG(NC1D)+CN9*LMVRC+DN9*LOG(-SSRW)) ! deactivation of cloud drop into CN
3861 QACcv = NACcv*4.1888E-15 ! deactivation of cloud drop into CN
3862 QACcv = MAX(QACcv,-1.*QC1D*iDT)
3863 NACcv = MAX(NACcv,-1.*NC1D*iDT)
3864 ENDIF
3865 ENDIF
3866 IF (QR1D.GE.QSMALL) THEN
3867 IF (SSRW.GT.RSMALL) THEN
3868 QVDvr = SSRW*NR1D*EXP(AQ2+(BQ2+CQ2*LMVRR)*LMVRR**2.)/ABW ! diffusion growth of raindrops
3869 ELSEIF (SSRW.LT.(-1.*RSMALL)) THEN
3870 QEVrv = SSRW*NR1D*EXP(AQ2+(BQ2+CQ2*LMVRR)*LMVRR**2.)/ABW ! diffusion growth of raindrops
3871 NACrc = SSRW*EXP(AN10+BN10*LOG(NR1D)+CN10*LMVRR)/ABW ! rain drop evaporate into cloud drop
3872 QACrc = NACrc*5.236E-10 ! rain drop evaporate into cloud drop
3873 QEVrv = MIN(QEVrv,0.)
3874 QACrc = MAX(QACrc,-1.*QR1D*iDT)
3875 NACrc = MAX(NACrc,-1.*NR1D*iDT)
3876 ENDIF
3877 ENDIF
3878 IF (SAT_ADJ.EQ.1) THEN
3879 IF ((QVDvc+QVDvr).GE.QSMALL) THEN
3880 VDMAX = (QV1D-QVSW)/(1.+XXLV**2.*QV1D/(CPM*RV*TK1D**2.))*iDT
3881 SUMCND = QVDvc+QVDvr
3882 IF (SUMCND.GT.VDMAX.AND.VDMAX.GE.QSMALL) THEN
3883 RATIO = MIN(1.,VDMAX/(SUMCND+QSMALL))
3884 QVDvc = QVDvc*RATIO
3885 QVDvr = QVDvr*RATIO
3886 ENDIF
3887 ENDIF
3888 ENDIF
3889 !-------------- DEPOSITION/SUBLIMATION TERMS FOR QI,QS,QG,QH -----------
3890 IF (TK1D.LT.TK0C) THEN
3891 IF (QI1D.GE.QSMALL) THEN
3892 DNIVD = RHOI0*EXP(-3.*MAX((QV1D-QVSI)-5.E-5,0.)/INHGR)
3893 DNIVD = MIN(MAX(DNIVD,RHOIMIN),RHOIMAX)
3894 IF (ICE_SHAPE.EQ.1.AND.AFAI.LE.20.) THEN
3895 RAT1 = MIN(1.,MAX(0.,ABS(GAMMP(AFAI+1.,DI0*LAMI))))
3896 RAT2 = 1.-RAT1
3897 QVDvi = 2.*PI*NI1D*(RAT2*VENQI+RAT1*VENQI0)*SSRI/ABI
3898 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
3899 FVDvi = 12.*NI1D*(RAT2*VENFI*GVHAB+RAT1*VENQI0)*SSRI/ &
3900 ABI/DNIVD
3901 IVDvi = 12.*NI1D*(RAT2*VENQI+RAT1*VENQI0)*SSRI/ABI/DNIVD
3902 ENDIF
3903 IF (AI1D.GE.ASMALL) THEN
3904 AVDvi = 8.*NI1D*(RAT2*VENAI+RAT1*VENAI0)*SSRI/ABI/DNIVD
3905 ENDIF
3906 ELSE
3907 QVDvi = 2.*PI*NI1D*VENQI*SSRI/ABI
3908 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
3909 FVDvi = 12.*NI1D*GVHAB*VENFI*SSRI/ABI/DNIVD
3910 IVDvi = 12.*NI1D*VENQI*SSRI/ABI/DNIVD
3911 ENDIF
3912 IF (AI1D.GE.ASMALL) THEN
3913 AVDvi = 8.*NI1D*VENAI*SSRI/ABI/DNIVD
3914 ENDIF
3915 ENDIF
3916 VVDvi = QVDvi/DNIVD
3917 IF (QVDvi.LT.0.) THEN
3918 QSBiv = MIN(QVDvi,0.)
3919 VSBiv = MIN(QVDvi/RHOI,0.)
3920 QVDvi = 0.
3921 VVDvi = 0.
3922 IF (AI1D.GE.ASMALL) THEN
3923 ASBiv = MIN(AVDvi*DNIVD/RHOI,0.)
3924 AVDvi = 0.
3925 ENDIF
3926 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
3927 FSBiv = MIN(FVDvi*DNIVD/RHOI,0.)
3928 ISBiv = MIN(IVDvi*DNIVD/RHOI,0.)
3929 FVDvi = 0.
3930 IVDvi = 0.
3931 ENDIF
3932 ENDIF
3933 ENDIF ! QISMALL
3934 IF (QS1D.GE.QSMALL) THEN
3935 DNSVD = RHOS*EXP(-3.*MAX((QV1D-QVSI)-5.E-5,0.)/1.)
3936 DNSVD = MIN(MAX(DNSVD,RHOIMIN),RHOIMAX)
3937 QVDvs = 2.*PI*NS1D*VENQS*SSRI/ABI
3938 IF (ICE_RHOS.EQ.1) THEN
3939 VVDvs = QVDvs/DNSVD
3940 ENDIF
3941 IF (AGG_SHAPE.EQ.1) THEN
3942 FVDvs = QVDvs/DNSVD*SASPR*V2M3
3943 ENDIF
3944 IF (AS1D.GE.ASMALL) THEN
3945 AVDvs = 8.*NS1D*VENAS*SSRI/ABI/DNSVD
3946 ENDIF
3947 IF (QVDvs.LT.0.) THEN
3948 QSBsv = MIN(QVDvs,0.)
3949 VSBsv = MIN(QVDvs/RHOS,0.)
3950 FSBsv = MIN(FVDvs*DNSVD/RHOS,0.)
3951 QVDvs = 0.
3952 VVDvs = 0.
3953 FVDvs = 0.
3954 IF (AS1D.GE.ASMALL) THEN
3955 ASBsv = MIN(AVDvs*DNSVD/RHOS,0.)
3956 AVDvs = 0.
3957 ENDIF
3958 ENDIF
3959 ENDIF
3960 IF (QG1D.GE.QSMALL) THEN
3961 DNGVD = RHOG*EXP(-3.*MAX((QV1D-QVSI)-5.E-5,0.))
3962 DNGVD = MIN(MAX(DNGVD,RHOIMIN),RHOG0)
3963 QVDvg = 2.*PI*NG1D*VENQG*SSRI/ABI
3964 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
3965 VVDvg = QVDvg/DNGVD
3966 ENDIF
3967 IF (AG1D.GE.ASMALL) THEN
3968 AVDvg = 8.*NG1D*VENAG*SSRI/ABI/DNGVD
3969 ENDIF
3970 IF (QVDvg.LT.0.) THEN
3971 QSBgv = MIN(QVDvg,0.)
3972 QVDvg = 0.
3973 VSBgv = MIN(QVDvg/RHOG,0.)
3974 VVDvg = 0.
3975 IF (AG1D.GE.ASMALL) THEN
3976 ASBgv = MIN(AVDvg*DNGVD/RHOG,0.)
3977 AVDvg = 0.
3978 ENDIF
3979 ENDIF
3980 ENDIF
3981 IF (QH1D.GE.QSMALL) THEN
3982 QVDvh = 2.*PI*NH1D*VENQH*SSRI/ABI
3983 IF (AH1D.GE.ASMALL) THEN
3984 AVDvh = 8.*NH1D*VENAH*SSRI/ABI/RHOH
3985 ENDIF
3986 IF (QVDvh.LT.0.) THEN
3987 QSBhv = MIN(QVDvh,0.)
3988 QVDvh = 0.
3989 IF (AH1D.GE.ASMALL) THEN
3990 ASBhv = MIN(AVDvh,0.)
3991 AVDvh = 0.
3992 ENDIF
3993 ENDIF
3994 ENDIF
3995 IF (SAT_ADJ.EQ.1) THEN
3996 IF ((QVDvi+QVDvs+QVDvg+QVDvh).GE.QSMALL) THEN
3997 VDMAX = (QV1D-QVSI)/(1.+XXLS**2.*QV1D/(CPM*RV*TK1D** &
3998 2.))*iDT
3999 SUMDEP = QVDvi+QVDvs+QVDvg+QVDvh
4000 IF (SUMDEP.GT.VDMAX.AND.VDMAX.GE.QSMALL) THEN
4001 RATIO = MIN(1.,VDMAX/(SUMDEP+QSMALL))
4002 QVDvi = QVDvi*RATIO
4003 QVDvs = QVDvs*RATIO
4004 QVDvg = QVDvg*RATIO
4005 QVDvh = QVDvh*RATIO
4006 VVDvi = VVDvi*RATIO
4007 VVDvs = VVDvs*RATIO
4008 VVDvg = VVDvg*RATIO
4009 FVDvi = FVDvi*RATIO
4010 FVDvs = FVDvs*RATIO
4011 IVDvi = IVDvi*RATIO
4012 AVDvi = AVDvi*RATIO
4013 AVDvs = AVDvs*RATIO
4014 AVDvg = AVDvg*RATIO
4015 AVDvh = AVDvh*RATIO
4016 ENDIF
4017 ENDIF
4018 ENDIF
4019 IF ((QSBiv+QSBsv+QSBgv+QSBhv).LT.0.) THEN
4020 SBMAX = (QV1D-QVSI)/(1.+XXLS**2.*QV1D/(CPM*RV*TK1D** &
4021 2.))*iDT
4022 SUMSUB = QSBiv+QSBsv+QSBgv+QSBhv
4023 IF (SBMAX.LT.0..AND.SUMSUB.LT.SBMAX*0.9999) THEN
4024 QSBiv = QSBiv*MIN(1.,0.9999*SBMAX/SUMSUB)
4025 QSBsv = QSBsv*MIN(1.,0.9999*SBMAX/SUMSUB)
4026 QSBgv = QSBgv*MIN(1.,0.9999*SBMAX/SUMSUB)
4027 QSBhv = QSBhv*MIN(1.,0.9999*SBMAX/SUMSUB)
4028 VSBiv = VSBiv*MIN(1.,0.9999*SBMAX/SUMSUB)
4029 VSBsv = VSBsv*MIN(1.,0.9999*SBMAX/SUMSUB)
4030 VSBgv = VSBgv*MIN(1.,0.9999*SBMAX/SUMSUB)
4031 FSBiv = FSBiv*MIN(1.,0.9999*SBMAX/SUMSUB)
4032 FSBsv = FSBsv*MIN(1.,0.9999*SBMAX/SUMSUB)
4033 ISBiv = ISBiv*MIN(1.,0.9999*SBMAX/SUMSUB)
4034 ASBiv = ASBiv*MIN(1.,0.9999*SBMAX/SUMSUB)
4035 ASBsv = ASBsv*MIN(1.,0.9999*SBMAX/SUMSUB)
4036 ASBgv = ASBgv*MIN(1.,0.9999*SBMAX/SUMSUB)
4037 ASBhv = ASBhv*MIN(1.,0.9999*SBMAX/SUMSUB)
4038 ENDIF
4039 ENDIF
4040 ! ENDIF
4041 ELSE ! TK1D.GE.TK0C
4042 IF (QS1D.GE.QSMALL.AND.SSRW.LT.-1.*RSMALL) THEN
4043 QEVsv = 2.*PI*NS1D*VENQS*SSRW/ABW
4044 QEVsv = MAX(MIN(QEVsv,0.),-1.*QS1D*iDT)
4045 IF (ICE_RHOS.EQ.1) THEN
4046 VEVsv = MAX(MIN(QEVsv/RHOS,0.),-1.*VS1D*iDT)
4047 ENDIF
4048 IF (AGG_SHAPE.EQ.1) THEN
4049 FEVsv = MAX(QEVsv/RHOS*SASPR*V2M3,-1.*FS1D*iDT)
4050 ENDIF
4051 IF (AS1D.GE.ASMALL) THEN
4052 AEVsv = 8.*NS1D*VENAS*SSRW/ABW/RHOS
4053 AEVsv = MAX(MIN(AEVsv,0.),-1.*AS1D*iDT)
4054 ENDIF
4055 ENDIF
4056 IF (QG1D.GE.QSMALL.AND.SSRW.LT.-1.*RSMALL) THEN
4057 QEVgv = 2.*PI*NG1D*VENQG*SSRW/ABW
4058 QEVgv = MAX(MIN(QEVgv,0.),-1.*QG1D*iDT)
4059 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
4060 VEVgv = MAX(MIN(QEVgv/RHOG,0.),-1.*VG1D*iDT)
4061 ENDIF
4062 IF (AG1D.GE.ASMALL) THEN
4063 AEVgv = 8.*NG1D*VENAG*SSRW/ABW/RHOG
4064 AEVgv = MAX(MIN(AEVgv,0.),-1.*AG1D*iDT)
4065 ENDIF
4066 ENDIF
4067 IF (QH1D.GE.QSMALL.AND.SSRW.LT.-1.*RSMALL) THEN
4068 QEVhv = 2.*PI*NH1D*VENQH*SSRW/ABW
4069 QEVhv = MAX(MIN(QEVhv,0.),-1.*QH1D*iDT)
4070 IF (AH1D.GE.ASMALL) THEN
4071 AEVhv = 8.*NH1D*VENAH*SSRW/ABW/RHOH
4072 AEVhv = MAX(MIN(AEVhv,0.),-1.*AH1D*iDT)
4073 ENDIF
4074 ENDIF
4075 IF ((QEVcv+QEVrv+QEVsv+QEVgv+QEVhv).LT.0.) THEN
4076 EVMAX = (QV1D-QVSW)/(1.+XXLV**2.*QV1D/(CPM*RV*TK1D**2.))* &
4077 iDT
4078 SUMEVP = QEVcv+QEVrv+QEVsv+QEVgv+QEVhv
4079 IF (EVMAX.LT.0..AND.SUMEVP.LT.EVMAX*0.9999) THEN
4080 QEVcv = QEVcv*MIN(1.,0.9999*EVMAX/SUMEVP)
4081 QEVrv = QEVrv*MIN(1.,0.9999*EVMAX/SUMEVP)
4082 QEVsv = QEVsv*MIN(1.,0.9999*EVMAX/SUMEVP)
4083 QEVgv = QEVgv*MIN(1.,0.9999*EVMAX/SUMEVP)
4084 QEVhv = QEVhv*MIN(1.,0.9999*EVMAX/SUMEVP)
4085 VEVsv = VEVsv*MIN(1.,0.9999*EVMAX/SUMEVP)
4086 VEVgv = VEVgv*MIN(1.,0.9999*EVMAX/SUMEVP)
4087 FEVsv = FEVsv*MIN(1.,0.9999*EVMAX/SUMEVP)
4088 AEVsv = AEVsv*MIN(1.,0.9999*EVMAX/SUMEVP)
4089 AEVgv = AEVgv*MIN(1.,0.9999*EVMAX/SUMEVP)
4090 AEVhv = AEVhv*MIN(1.,0.9999*EVMAX/SUMEVP)
4091 ENDIF
4092 ENDIF
4093 ENDIF ! TEMPERATURE LOOP
4095 QVWTEND = -QACcv-QVDvc-QVDvr-QEVcv-QEVrv-QEVsv-QEVgv-QEVhv
4096 QVITEND = -QVDvi-QVDvs-QVDvg-QVDvh-QSBiv-QSBsv-QSBgv-QSBhv
4097 QVTEND = QVWTEND+QVITEND
4098 QCTEND = QACcv-QACrc+QVDvc+QEVcv
4099 QRTEND = QACrc+QVDvr+QEVrv
4100 QITEND = QVDvi+QSBiv
4101 QSTEND = QVDvs+QEVsv+QSBsv
4102 QGTEND = QVDvg+QEVgv+QSBgv
4103 QHTEND = QVDvh+QEVhv+QSBhv
4105 DTS = MIN(TORR*MAX(QV1D,1.E-7)/MAX(ABS(QVTEND),QSMALL), &! limited by d(QV)
4106 TORR*MAX(QC1D,QLIMIT)/MAX(ABS(QCTEND),QSMALL), &! limited by d(QC)
4107 TORR*MAX(QR1D,QLIMIT)/MAX(ABS(QRTEND),QSMALL), &! limited by d(QR)
4108 TORR*MAX(QI1D,QLIMIT)/MAX(ABS(QITEND),QSMALL), &! limited by d(QI)
4109 TORR*MAX(QS1D,QLIMIT)/MAX(ABS(QSTEND),QSMALL), &! limited by d(QS)
4110 TORR*MAX(QG1D,QLIMIT)/MAX(ABS(QGTEND),QSMALL), &! limited by d(QG)
4111 TORR*MAX(QH1D,QLIMIT)/MAX(ABS(QHTEND),QSMALL), &! limited by d(QH)
4112 DT,DTS,DT-SDTS)
4113 DTS = MIN(DT-SDTS,MAX(DTMIN,DTS))
4115 !--- CALCULATE TIME TO REACH RHW=100%, RHI=100%
4116 !--- NEGATIVE VALUE MEANS TIME HAS PAST AND WOULD NEVER REACH 100% IN THE FUTURE
4118 DTSI = -(QVWTEND*ELCLD+QVITEND*ELDLD) ! rate of saturation vapor over ice change
4119 DTSW = -(QVWTEND*ELCLC+QVITEND*ELCLD) ! rate of saturation vapor over liquid change
4120 IF (ABS(DTSI).LT.RLIMIT) THEN
4121 DTSI = 1.E5 ! AN ARBITARY VALUE
4122 ELSE
4123 DTSI = SSRI*QV1D/((1.+SSRI)*DTSI) ! time to reach saturation over ice
4124 ENDIF
4125 IF (ABS(DTSW).LT.RLIMIT) THEN
4126 DTSW = 1.E5 ! AN ARBITARY VALUE
4127 ELSE
4128 DTSW = SSRW*QV1D/((1.+SSRW)*DTSW) ! time to reach saturation over liquid
4129 ENDIF
4131 IF (TK1D.GT.TK0C) THEN
4132 IF(DTSW.GT.0.) DTS = MAX(MIN(DTS,DTSW),DTMIN)
4133 ELSE
4134 IF(DTSI.GT.0.) DTS = MAX(MIN(DTS,DTSI),DTMIN)
4135 IF(DTSW.GT.0.) DTS = MAX(MIN(DTS,DTSW),DTMIN)
4136 ENDIF
4138 QVSOUR = QV1D+(-QACcv-QEVcv-QEVrv-QEVsv-QEVgv-QEVhv-QSBiv-QSBsv- &
4139 QSBgv-QSBhv)*DTS
4140 QVSINK = (QVDvc+QVDvr+QVDvi+QVDvs+QVDvg+QVDvh)*DTS
4141 IF (QVSINK.GT.QVSOUR.AND.QVSOUR.GE.QSMALL) THEN
4142 RATIO = MIN(1.,QVSOUR/(QVSINK+QSMALL))
4143 QVDvc = QVDvc*RATIO; QVDvr = QVDvr*RATIO
4144 QVDvi = QVDvi*RATIO; QVDvs = QVDvs*RATIO
4145 QVDvg = QVDvg*RATIO; QVDvh = QVDvh*RATIO
4146 ENDIF
4147 QCSOUR = QC1D+(QVDvc-QACrc)*DTS
4148 QCSINK = (-QACcv-QEVcv)*DTS
4149 IF (QCSINK.GT.QCSOUR.AND.QCSOUR.GE.QSMALL) THEN
4150 RATIO = MIN(1.,QCSOUR/(QCSINK+QSMALL))
4151 QACcv = QACcv*RATIO; QEVcv = QEVcv*RATIO
4152 ENDIF
4153 QRSOUR = QR1D+QVDvr*DTS
4154 QRSINK = (-QACrc-QEVrv)*DTS
4155 IF (QRSINK.GT.QRSOUR.AND.QRSOUR.GE.QSMALL) THEN
4156 RATIO = MIN(1.,QRSOUR/(QRSINK+QSMALL))
4157 QACrc = QACrc*RATIO; QEVrv = QEVrv*RATIO
4158 ENDIF
4159 QISOUR = QI1D+QVDvi*DTS
4160 QISINK = (-QSBiv)*DTS
4161 IF (QISINK.GT.QISOUR.AND.QISOUR.GE.QSMALL) THEN
4162 RATIO = MIN(1.,QISOUR/(QISINK+QSMALL))
4163 QSBiv = QSBiv*RATIO
4164 ENDIF
4165 QSSOUR = QS1D+QVDvs*DTS
4166 QSSINK = (-QEVsv-QSBsv)*DTS
4167 IF (QSSINK.GT.QSSOUR.AND.QSSOUR.GE.QSMALL) THEN
4168 RATIO = MIN(1.,QSSOUR/(QSSINK+QSMALL))
4169 QSBsv = QSBsv*RATIO; QEVsv = QEVsv*RATIO
4170 ENDIF
4171 QGSOUR = QG1D+QVDvg*DTS
4172 QGSINK = (-QSBgv-QEVgv)*DTS
4173 IF (QGSINK.GT.QGSOUR.AND.QGSOUR.GE.QSMALL) THEN
4174 RATIO = MIN(1.,QGSOUR/(QGSINK+QSMALL))
4175 QSBgv = QSBgv*RATIO; QEVgv = QEVgv*RATIO
4176 ENDIF
4177 QHSOUR = QH1D+QVDvh*DTS
4178 QHSINK = (-QSBhv-QEVhv)*DTS
4179 IF (QHSINK.GT.QHSOUR.AND.QHSOUR.GE.QSMALL) THEN
4180 RATIO = MIN(1.,QHSOUR/(QHSINK+QSMALL))
4181 QSBhv = QSBhv*RATIO; QEVhv = QEVhv*RATIO
4182 ENDIF
4183 IF (QI1D.GE.QSMALL) THEN
4184 NSBiv = MIN(QSBiv*NI1D/QI1D,0.)
4185 ENDIF
4186 IF (QS1D.GE.QSMALL) THEN
4187 NSBsv = MIN(QSBsv*NS1D/QS1D,0.)
4188 ENDIF
4189 IF (QG1D.GE.QSMALL) THEN
4190 NSBgv = MIN(QSBgv*NG1D/QG1D,0.)
4191 ENDIF
4192 IF (QH1D.GE.QSMALL) THEN
4193 NSBhv = MIN(QSBhv*NH1D/QH1D,0.)
4194 ENDIF
4195 NCSOUR = NC1D+(-NACrc)*DTS
4196 NCSINK = (-NACcv)*DTS
4197 IF (NCSINK.GT.NCSOUR.AND.NCSOUR.GE.NSMALL) THEN
4198 RATIO = MIN(1.,NCSOUR/(NCSINK+NSMALL))
4199 NACcv = NACcv*RATIO
4200 ENDIF
4201 NISOUR = NI1D
4202 NISINK = (-NSBiv)*DTS
4203 IF (NISINK.GT.NISOUR.AND.NISOUR.GE.NSMALL) THEN
4204 RATIO = MIN(1.,NISOUR/(NISINK+NSMALL))
4205 NSBiv = NSBiv*RATIO
4206 ENDIF
4207 NSSOUR = NS1D
4208 NSSINK = (-NSBsv)*DTS
4209 IF (NSSINK.GT.NSSOUR.AND.NSSOUR.GE.NSMALL) THEN
4210 RATIO = MIN(1.,NSSOUR/(NSSINK+NSMALL))
4211 NSBsv = NSBsv*RATIO
4212 ENDIF
4213 VISOUR = VI1D+VVDvi*DTS
4214 VISINK = (-VSBiv)*DTS
4215 IF (VISINK.GT.VISOUR.AND.VISOUR.GE.ISMALL) THEN
4216 RATIO = MIN(1.,VISOUR/(VISINK+ISMALL))
4217 VSBiv = VSBiv*RATIO
4218 ENDIF
4219 VSSOUR = VS1D+VVDvs*DTS
4220 VSSINK = (-VEVsv-VSBsv)*DTS
4221 IF (VSSINK.GT.VSSOUR.AND.VSSOUR.GE.ISMALL) THEN
4222 RATIO = MIN(1.,VSSOUR/(VSSINK+ISMALL))
4223 VSBsv = VSBsv*RATIO; VEVsv = VEVsv*RATIO
4224 ENDIF
4225 VGSOUR = VG1D+VVDvg*DTS
4226 VGSINK = (-VSBgv-VEVgv)*DTS
4227 IF (VGSINK.GT.VGSOUR.AND.VGSOUR.GE.ISMALL) THEN
4228 RATIO = MIN(1.,VGSOUR/(VGSINK+ISMALL))
4229 VSBgv = VSBgv*RATIO; VEVgv = VEVgv*RATIO
4230 ENDIF
4231 FISOUR = FI1D+FVDvi*DTS
4232 FISINK = (-FSBiv)*DTS
4233 IF (FISINK.GT.FISOUR.AND.FISOUR.GE.ISMALL) THEN
4234 RATIO = MIN(1.,FISOUR/(FISINK+ISMALL))
4235 FSBiv = FSBiv*RATIO
4236 ENDIF
4237 FSSOUR = FS1D+FVDvs*DTS
4238 FSSINK = (-FEVsv-FSBsv)*DTS
4239 IF (FSSINK.GT.FSSOUR.AND.FSSOUR.GE.QSMALL) THEN
4240 RATIO = MIN(1.,FSSOUR/(FSSINK+QSMALL))
4241 FSBsv = FSBsv*RATIO; FEVsv = FEVsv*RATIO
4242 ENDIF
4243 AISOUR = AI1D+AVDvi*DTS
4244 AISINK = (-ASBiv)*DTS
4245 IF (AISINK.GT.AISOUR.AND.AISOUR.GE.ASMALL) THEN
4246 RATIO = MIN(1.,AISOUR/(AISINK+ASMALL))
4247 ASBiv = ASBiv*RATIO
4248 ENDIF
4249 ASSOUR = AS1D+AVDvs*DTS
4250 ASSINK = (-ASBsv-AEVsv)*DTS
4251 IF (ASSINK.GT.ASSOUR.AND.ASSOUR.GE.ASMALL) THEN
4252 RATIO = MIN(1.,ASSOUR/(ASSINK+ASMALL))
4253 ASBsv = ASBsv*RATIO; AEVsv = AEVsv*RATIO
4254 ENDIF
4255 AGSOUR = AG1D+AVDvg*DTS
4256 AGSINK = (-ASBgv-AEVgv)*DTS
4257 IF (AGSINK.GT.AGSOUR.AND.AGSOUR.GE.ASMALL) THEN
4258 RATIO = MIN(1.,AGSOUR/(AGSINK+ASMALL))
4259 ASBgv = ASBgv*RATIO; AEVgv = AEVgv*RATIO
4260 ENDIF
4261 AHSOUR = AH1D+AVDvh*DTS
4262 AHSINK = (-ASBhv-AEVhv)*DTS
4263 IF (AHSINK.GT.AHSOUR.AND.AHSOUR.GE.ASMALL) THEN
4264 RATIO = MIN(1.,AHSOUR/(AHSINK+ASMALL))
4265 ASBhv = ASBhv*RATIO; AEVhv = AEVhv*RATIO
4266 ENDIF
4267 IISOUR = I3M1D+IVDvi*DTS
4268 IISINK = (-ISBiv)*DTS
4269 IF (IISINK.GT.IISOUR.AND.IISOUR.GE.ISMALL) THEN
4270 RATIO = MIN(1.,IISOUR/(IISINK+ISMALL))
4271 ISBiv = ISBiv*RATIO
4272 ENDIF
4273 !----------------- update values of variables -------------------------
4274 QV1D = MAX(0.,QV1D+(-QACcv-QVDvc-QVDvr-QEVcv-QEVrv-QEVsv-QEVgv- &
4275 QEVhv-QVDvi-QVDvs-QVDvg-QVDvh-QSBiv-QSBsv-QSBgv-QSBhv)*DTS)
4276 QC1D = MAX(0.,QC1D+(QACcv-QACrc+QVDvc+QEVcv)*DTS)
4277 QR1D = MAX(0.,QR1D+(QACrc+QVDvr+QEVrv)*DTS)
4278 QI1D = MAX(0.,QI1D+(QVDvi+QSBiv)*DTS)
4279 QS1D = MAX(0.,QS1D+(QVDvs+QSBsv+QEVsv)*DTS)
4280 QG1D = MAX(0.,QG1D+(QVDvg+QSBgv+QEVgv)*DTS)
4281 QH1D = MAX(0.,QH1D+(QVDvh+QSBhv+QEVhv)*DTS)
4282 NC1D = MAX(0.,NC1D+(NACcv-NACrc)*DTS)
4283 NR1D = MAX(0.,NR1D+(NACrc)*DTS)
4284 NI1D = MAX(0.,NI1D+(NSBiv)*DTS)
4285 NS1D = MAX(0.,NS1D+(NSBsv)*DTS)
4286 NG1D = MAX(0.,NG1D+(NSBgv)*DTS)
4287 NH1D = MAX(0.,NH1D+(NSBhv)*DTS)
4288 IF (ICE_RHOI.EQ.0.OR.ICE_RHOI.EQ.2) THEN
4289 VI1D = 0.
4290 ELSEIF (ICE_RHOI.EQ.1) THEN
4291 VI1D = MAX(0.,VI1D+(VVDvi+VSBiv)*DTS)
4292 ENDIF
4293 IF (ICE_RHOS.EQ.0.OR.ICE_RHOS.EQ.2) THEN
4294 VS1D = 0.
4295 ELSEIF (ICE_RHOS.EQ.1) THEN
4296 VS1D = MAX(0.,VS1D+(VVDvs+VSBsv+VEVsv)*DTS)
4297 ENDIF
4298 IF (ICE_RHOG.EQ.0) THEN
4299 VG1D = 0.
4300 ELSEIF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
4301 VG1D = MAX(0.,VG1D+(VVDvg+VSBgv+VEVgv)*DTS)
4302 ENDIF
4303 FI1D = MAX(0.,FI1D+(FVDvi+FSBiv)*DTS)
4304 IF (AGG_SHAPE.EQ.0) THEN
4305 FS1D = 0.
4306 ELSEIF (AGG_SHAPE.EQ.1) THEN
4307 FS1D = MAX(0.,FS1D+(FVDvs+FSBsv+FEVsv)*DTS)
4308 ENDIF
4309 I3M1D = MAX(0.,I3M1D+(IVDvi+ISBiv)*DTS)
4310 IF (AFAI_3M.EQ.0.OR.AFAI_3M.EQ.2) THEN
4311 AI1D = 0.
4312 ELSEIF (AFAI_3M.EQ.1) THEN
4313 AI1D = MAX(0.,AI1D+(AVDvi+ASBiv)*DTS)
4314 ENDIF
4315 IF (AFAS_3M.EQ.0.OR.AFAS_3M.EQ.2) THEN
4316 AS1D = 0.
4317 ELSEIF (AFAS_3M.EQ.1) THEN
4318 AS1D = MAX(0.,AS1D+(AVDvs+ASBsv+AEVsv)*DTS)
4319 ENDIF
4320 IF (AFAG_3M.EQ.0.OR.AFAG_3M.EQ.2) THEN
4321 AG1D = 0.
4322 ELSEIF (AFAG_3M.EQ.1) THEN
4323 AG1D = MAX(0.,AG1D+(AVDvg+ASBgv+AEVgv)*DTS)
4324 ENDIF
4325 IF (AFAH_3M.EQ.0.OR.AFAH_3M.EQ.2) THEN
4326 AH1D = 0.
4327 ELSEIF (AFAH_3M.EQ.1) THEN
4328 AH1D = MAX(0.,AH1D+(AVDvh+ASBhv+AEVhv)*DTS)
4329 ENDIF
4330 XDNC = XDNC+NACcv*DTS
4331 XDNR = XDNR+NACrc*DTS
4332 GQCTR = QACrc*DTS
4333 TK1D = TK1D+((QACcv+QACrc+QVDvc+QVDvr+QEVcv+QEVrv+QEVsv+QEVgv+ &
4334 QEVhv)*XXLV+(QVDvi+QVDvs+QVDvg+QVDvh+QSBiv+QSBsv+QSBgv+ &
4335 QSBhv)*XXLS)/CPM*DTS
4337 IF (QC1D.GE.QSMALL.AND.NC1D.GE.NSMALL) THEN
4338 MVDC = (QC1D*iAMW/NC1D)**THRD
4339 IF (MVDC.GT.DCR) THEN
4340 QR1D = QR1D+QC1D
4341 NR1D = NR1D+NC1D
4342 QC1D = 0.; NC1D = 0.
4343 ENDIF
4344 ENDIF
4345 IF (QR1D.GE.QSMALL.AND.NR1D.GE.NSMALL) THEN
4346 MVDR = (QR1D*iAMW/NR1D)**THRD
4347 IF (MVDR.LT.DCR) THEN
4348 QC1D = QC1D+QR1D
4349 NC1D = NC1D+NR1D
4350 QR1D = 0.; NR1D = 0.
4351 ENDIF
4352 ENDIF
4353 IF (QH1D.GE.QSMALL.AND.NH1D.GE.NSMALL) THEN
4354 MVDH = (QH1D*iAMH/NH1D)**THRD
4355 IF (MVDH.LT.DHMIN) THEN
4356 QG1D = QG1D+QH1D
4357 NG1D = NG1D+NH1D
4358 VG1D = VG1D+QH1D/RHOG0
4359 QH1D = 0.; NH1D = 0.
4360 IF (AH1D.GE.ASMALL.AND.AFAG_3M.EQ.1) THEN
4361 AG1D = AG1D+AH1D
4362 AH1D = 0.
4363 ENDIF
4364 ENDIF
4365 ENDIF
4367 END SUBROUTINE SMALL_DT
4368 !======================================================================
4369 !
4370 !======================================================================
4371 SUBROUTINE LARGE_DT(DT,TK1D,QV1D,P1D,RHO,QC1D,QR1D,QI1D,QS1D, &
4372 QG1D,QH1D,NC1D,NR1D,NI1D,NS1D,NG1D,NH1D,VI1D,VS1D, &
4373 VG1D,FI1D,FS1D,AI1D,AS1D,AG1D,AH1D,I3M1D,SASPR,GQCTR)
4374 !=======================================================================
4375 IMPLICIT NONE
4376 INTEGER :: I,WBIN,CBIN,PBIN,TBIN,DBIN
4377 REAL :: TK1D,QV1D,P1D,TC1D,DT,GQCTR,QI1D,AI1D,AS1D,AG1D,AH1D, &
4378 I3M1D,QNIN,VI1D,VS1D,VG1D,FI1D,FS1D,AFAC,AFAR,AFAI,AFAS, &
4379 AFAG,AFAH,ADAGR,QC1D,QR1D,QS1D,QG1D,QH1D,NC1D,NR1D,NI1D, &
4380 NS1D,NG1D,NH1D,RHOI,RHOS,RHOG,RHOIS,iRHOI,iRHOS,iRHOG, &
4381 ZETA,ZETA2,ZETA3,iAMI,iAMG,DI0Z1,DI0Z2,DI0Z3,DI0Z4,IPG, &
4382 IPH,IPF,SASPR,DNRI,DNIRM,DNIAG,DNSAG,DNSAC,DNGAC,DNSRM, &
4383 DNGRM,AMI,BMI,AMG,AMS,RHO,iRHO,AVI,BVI,AVS,BVS,AVG,BVG, &
4384 AVH,BVH,CAPS,SASR1,SASR2,SASR3,SASR4,SASP1,SASP2,SASP3
4385 REAL :: QHOci,QHOrg,QNMci,QNMrg,QNCci,QFZci,QFZrg,QMLir,QMLic, &
4386 QMLsr,QMLgr,QMLhr,QIMii,QIMcsi,QIMrsi,QIMcgi,QIMrgi, &
4387 QBKrc,QINig,QINsg,QCNcr,QCNis,QCNgh,QRMci,QRMcs,QRMcg, &
4388 QRMch,QRMri,QRMrs,QRMrg,QRMrh,QCLcr,QCLir,QCLis,QCLig, &
4389 QCLih,QCLsr,QCLsg,QCLsh,QCLgr,QCLirg,QCLsrg,QCLgrg,QHwsh,&
4390 QHwml,QHdrm,QCLss
4391 REAL :: NHOci,NHOrg,NNMci,NNMrg,NNCci,NFZci,NFZrg,NMLir,NMLic, &
4392 NMLsr,NMLgr,NMLhr,NIMii,NIMcsi,NIMrsi,NIMcgi,NIMrgi, &
4393 NBKrc,NBKrr,NINig,NINsg,NCNcr,NiCNis,NgCNgh,NhCNgh,NRMci,&
4394 NRMcs,NRMcg,NRMch,NRMri,NRMrs,NRMrg,NRMrh,NCLcc,NCLcr, &
4395 NCLrr,NCLir,NCLis,NCLig,NCLih,NCLsr,NCLss,NCLsg,NCLsh, &
4396 NCLgr,NCLirg,NCLsrg,NCLgrg,NHwsh,NsCNis
4397 REAL :: VIMii,VCLis,ViCLis,VsCLis,VCLig,ViCLig,VgCLig,VCLih, &
4398 ViCNis,VsCNis,ViINig,VgINig,VFZci,VFZrg,VIMcsi,VMLir, &
4399 VMLic,VRMci,VCLir,VHOci,VHOrg,VNMci,VNMrg,VNCci,VIMcgi, &
4400 VIMrsi,VIMrgi,VCLss,VCLsg,VsCLsg,VgCLsg,VCLsh,VsINsg, &
4401 VgINsg,VMLsr,VRMcs,VCLsr,VMLgr,VRMcg,VCNgh,VCLgr,VCLirg, &
4402 VCLsrg,VCLgrg,FHOci,FNMci,FNCci,FRMci,FMLir,FMLic,FCLir, &
4403 FiCLis,FCLig,FIMcsi,FCLih,FiCNis,FINig,FFZci,FIMii, &
4404 FIMcgi,FIMrsi,FIMrgi,FsCNis,FsCLis,FCLsg,FCLsh,FINsg, &
4405 FMLsr,FRMcs,FCLsr,FCLss
4406 REAL :: IHOci,INMci,INCci,IRMci,IMLir,IMLic,ICLir,ICLis,ICLig, &
4407 IIMcsi,ICLih,ICNis,IINig,IFZci,IIMii,IIMcgi,IIMrsi, &
4408 IIMrgi,AHOci,ANMci,ANCci,ARMci,AMLir,AMLic,ACLir,AiCLis, &
4409 AiCLig,AIMcsi,AiCLih,AiCNis,AsCNis,AiINig,AgINig,AFZci, &
4410 AIMii,AIMcgi,AIMrsi,AIMrgi,AMLsr,AsCLis,AsCLsg,AsCLsh, &
4411 ARMcs,ACLsr,AgCLig,AsINsg,AgINsg,AMLgr,ARMcg,AgCNgh, &
4412 AhCNgh,AgCLsg,ACLgr,ACLirg,ACLsrg,ACLgrg,AHOrg,ANMrg, &
4413 AFZrg,AMLhr,ACLss,AhCLih,AhCLsh,ARMch,ARMrg,ARMrh,AHdrm, &
4414 AHwml,ACLss1
4415 REAL :: QCSOUR,QCSINK,QRSOUR,QRSINK,QISOUR,QISINK,QSSOUR,QSSINK, &
4416 QGSOUR,QGSINK,QHSOUR,QHSINK,NCSOUR,NCSINK,NRSOUR,NRSINK, &
4417 NISOUR,NISINK,NSSOUR,NSSINK,NGSOUR,NGSINK,NHSOUR,NHSINK, &
4418 FISOUR,FISINK,FSSOUR,FSSINK,VISOUR,VISINK,VSSOUR,VSSINK, &
4419 VGSOUR,VGSINK,AISOUR,AISINK,ASSOUR,ASSINK,AGSOUR,AGSINK, &
4420 AHSOUR,AHSINK,IISOUR,IISINK
4421 REAL :: RHOAJ,CPM,SSRI,XXLS,XXLF,XXLV,QVSI,ESI,ABI,iDT,SSRW,KAP, &
4422 DV,MUA,SCN,ACTW,ESW,SFCTNW,SFCTNV,EPA,QVSW,TQCI,TQRSG,FF,&
4423 RFZ,ICED,VOLMC,IJHOF,AREAC,RGIMF,GGIMF,ARIMF0,ARIMF, &
4424 COSM2,GEOF2,IJIMF0,IJIMF,GGCNT,NGCNT0,NGCNT1,NGCNT,TCC, &
4425 CNTGG0,CNTGG,PSIA,KDIFF,KAPA,CNTKN,CNTFT0,CNTFT1,CNTF1, &
4426 CNTF2,CNTFT,IJCNT1,IJCNT2,IJCNT3,DC1,DC2,DC3,INR0,FANGLE,&
4427 FACTE,DACTE,RATIO,WNRE,CNRE,PNRE,MRATO,MVRC,MVRR,MVDC, &
4428 MVDR,MVDI,MVDS,MVDG,MVDH,DSMM,LMVRC,LMVRR,TMP1,GUC,GUR, &
4429 RMcsq,RMrsq,RMcgq,RMrgq,RMchq,RMrhq,RMcsa,RMrsa,RMcga, &
4430 RMrga,RMcha,RMrha,VTQ0,VTQC,VTQR,VTQI,VTQS,VTQG,VTQH, &
4431 VTN0,VTNC,VTNR,VTNI,VTNS,VTNG,VTNH,VTAX,VTAC,VTAR,VTAI, &
4432 VTAS,VTAG,VTAH,VTV0,VTVI,VTVS,VTVG,VTF0,VTFI,VTI3M,VTQIC,&
4433 VTQSC,VTQGC,VTQHC,VTQRI,VTQRS,VTQRG,VTQRH,VTQIS,VTQIG, &
4434 VTQIH,VTQSG,VTQSH,VTNIC,VTNSC,VTNGC,VTNHC,VTNRI,VTNRS, &
4435 VTNRG,VTNRH,VTNIS,VTNIG,VTNIH,VTNSG,VTNSH,VTARI,VTARS, &
4436 VTARG,VTARH,VTAIC,VTASC,VTAGC,VTAHC,VTAIS,VTAIG,VTAIH, &
4437 VTASG,VTASH,VTVRI,VTVIC,VTVSC,VTVIS,VTVIG,VTVIH,VTVSG, &
4438 VTFRI,VTFIC,VTFIS,VTFIG,VTFIH,EIS,EIG,EIH,ESG,ESH,EII, &
4439 ESS,ECI,ECS,ECG,ECH,ERI,ERS,ERG,ERH,EII1,EII2,EIS1,EIS2, &
4440 ESS1,ESS2,SMLTQ,GMLTQ,HMLTQ,SMLTA,GMLTA,HMLTA,VENQS, &
4441 VENQG,VENQH,VENAS,VENAG,VENAH,STOKE,DSLL,NGTAL,MVDX,ABW, &
4442 FSQC,FSNC,FSQR,FSNR,FSQI,FSNI,FSQS,FSNS,FSQG,FSNG,FSQH, &
4443 FSNH,FSAC,FSAR,FSAI,FSAS,FSAG,FSAH,FSVI,FSVS,FSVG,FSFI
4444 REAL :: DMWDT,DMIDT,HIdqv,HSdqv,HGdqv,HHdqv,HCwqv,HRwqv,HSwqv, &
4445 HGwqv,HHwqv,HHdcd,HHdrm,HHdcl,HHdtt,HSwcd,HGwcd,HHwcd, &
4446 HSwrm,HGwrm,HHwrm,VDMAX,SBMAX,EVMAX,SUMDEP,SUMSUB,SUMEVP,&
4447 SUMCND,MLMAX,ESW0,ESI0,QVSW0,QVSI0,XXLF0,MLWM,MWT,MLWC, &
4448 DH9,MCORE,ICOR1,DIT,BEST,VENQI,QTMP0,QTMP1,QTMP2,QTMP3, &
4449 QTMP4,QTMP5,QTMP6,QTMP7,QTMP8,QTMP9,ATMP1,ATMP2,ATMP3, &
4450 ATMP4,NCLS2,BTMP,BSTMP,BGTMP,BHTMP,H2Z,H4Z,QRMC1,NRMC1, &
4451 FRMC1,IRMC1,ARMC1,QRMR1,NRMR1,ARMR1,QFZC1,NFZC1,QFZR1, &
4452 NFZR1,AFZR1,QCLI1,NCLI1,QCNI1,NCNI1,ACNI1,FCNI1,QCLG1, &
4453 NCLG1,ACLG1,ACLI1,FCLI1,QCLS1,NCLS1,ACLS1,LIM1,LIM2,LIMA,&
4454 LIMB,LIMC,LIMD,LIME,LIMF,DICC,DICA,DIAC,DIAA,DIC0,DIA0, &
4455 DIF0,DSS0,DSL0,DIC2,DIA2,DILSV,DSLSV,DGLSV,DILSF,DSLSF, &
4456 SMLR,GMLR,SMLF,GMLF,HMLF,AVWSG,BVWSG,CAPWS,WSAPR,RHOWS, &
4457 RHOWG,VENWS,VENWG,SSRW0,SSRI0,LLMI,LLMS,LLMG,LLMH,KDX, &
4458 RHOIW,RHOSW,RHOGW,RHOIG,RHOIH,RHOSG,RHOSH,RHOHW,KINV, &
4459 BEST0,C1X2,VTB1,VTA1,LIM3,LIM4,LIM5,LIM6,LIM7,LIM8
4460 REAL :: LAMC,LAMR,LAMS,LAMG,LAMH,LAMI,GC2,GC3,GC4,GC5,GC6,GC7, &
4461 GR2,GR3,GR4,GR5,GR6,GR7,GI1,GI2,GI2G1,GI2G2,GI2H1,GI3, &
4462 GI3H1,GIF1,GIF2,GIG1,GIG2,GIH1,GIH2,GIM1,GIM2,GI4,GI5, &
4463 GIM2H1,GI2H3,GI2HG1,GIH2G1,GIF3,GI2G3,GI3G1,GIZM2H1,GIG3,&
4464 GIM2G1,GIZM2G1,GIM3,GIMF1,GIZMF1,GIMG1,GIZMG1,GIMH1, &
4465 GIZMH1,GIZM1,GIZ1,GIZ2G1,GIZF1,GIZG1,GIZH1,GIH3,GS2,GS3, &
4466 GS4,GS5,GSM1,GSM2,GSM3,GG2,GG3,GG4,GG5,GGM1,GGM2,GGM3, &
4467 GH2,GH3,GH4,GH5,Z32G,Z32H,Z3BMI
4468 !-----------------------See CL04 Tables--------------------------------------
4469 REAL, PARAMETER :: AVTC = 8.8462E+02, BVTC = 9.7593E+07
4470 REAL, PARAMETER :: CVTC = -3.4249E+11, AVTR = 2.1454E+00
4471 REAL, PARAMETER :: BVTR = -2.2812E-04, CVTR = 2.9676E-09
4472 REAL, PARAMETER :: CQC1 = 2.0901E+01, CQC2 = 9.9111E-01
4473 REAL, PARAMETER :: CQC3 = 4.4182E+00, CNC1 = 1.8276E+01
4474 REAL, PARAMETER :: CNC2 = 1.0015E+00, CNC3 = 1.9838E+00
4475 REAL, PARAMETER :: CQR1 = 1.5943E+01, CQR2 = 1.1898E+00
4476 REAL, PARAMETER :: CQR3 = 4.0073E+00, CNR1 = 9.4791E+00
4477 REAL, PARAMETER :: CNR2 = 9.7607E-01, CNR3 = 1.0858E+00
4478 REAL, PARAMETER :: AQ1 = 6.6793E+0, BQ1 = 1.0090E+0
4479 REAL, PARAMETER :: CQ1 = 1.4095E+0, AQ2 = 9.9912E+0
4480 REAL, PARAMETER :: BQ2 = -4.7678E-1, CQ2 = -3.1388E-2
4481 REAL, PARAMETER :: AN3 = -4.3561E0, BN3 = 1.9934E0
4482 REAL, PARAMETER :: CN3 = 1.6465E-2, AN4 = -4.0731E1
4483 REAL, PARAMETER :: BN4 = 5.3720E5, CN4 = -2.0139E-5
4484 REAL, PARAMETER :: AQ4 = -2.1370E1, BQ4 = 1.9899E9
4485 REAL, PARAMETER :: AN5 = 1.5519E1, BN5 = 3.1491E-0
4486 REAL, PARAMETER :: CN5 = 4.3989E-1, AQ5 = 2.0090E1
4487 REAL, PARAMETER :: BQ5 = 2.9626E0, CQ5 = 3.2358E0
4488 REAL, PARAMETER :: AN6 = -1.8239E1, BN6 = 2.2956E0
4489 REAL, PARAMETER :: CN6 = -2.3261E-4, AN7 = -1.7431E2
4490 REAL, PARAMETER :: BN7 = 2.6031E5, CN7 = -9.3613E7
4491 REAL, PARAMETER :: AN8 = -1.6185E2, BN8 = 2.2786E5
4492 REAL, PARAMETER :: CN8 = -7.6988E7, AQ8 = -2.3531E1
4493 REAL, PARAMETER :: BQ8 = 9.8271E-1, CQ8 = -1.3202E-1
4494 !---------------------------------------------------------------------------
4495 REAL, PARAMETER :: DSHED = 1.E-3, XISP = 0.25 ! SHEDDING DIAMETER
4496 REAL, PARAMETER :: ISEPL = 0.6, ISEPS = 0.6 ! SEPARATION RATIO, See TC20
4497 REAL :: ZC1,ZC2,ZC3,ZC4,ZP1,ZP2,ZP3,ZP4 ! See CT16
4498 DATA ZC1,ZC2,ZC3,ZC4/0.69509913,-0.46685819,0.30490087,1.62148100/
4499 DATA ZP1,ZP2,ZP3,ZP4/0.36793126,1.82782890,0.63206874,-1.00164090/
4501 IF (INSPEC.EQ.1) THEN ! SOOT
4502 DC1 = -0.5411955; DC2 = 1.879918; DC3 = 1.607947 ! Chen et al. 2008 Table3
4503 INR0 = 0.4E-7; FANGLE = 33.2; FACTE = 13.8E-20
4504 DACTE = -20.E-20
4505 ELSEIF (INSPEC.EQ.2) THEN ! SAHARAN DUST
4506 DC1 = -0.3353619; DC2 = 1.990979; DC3 = 2.175539 ! Chen et al. 2008 Table3
4507 INR0 = 1.75E-7; FANGLE = 30.98; FACTE = 15.7E-20
4508 DACTE = 3.35E-20
4509 ELSEIF (INSPEC.EQ.3) THEN ! ASIAN DUST
4510 DC1 = -0.3598818; DC2 = 1.982032; DC3 = 2.025390 ! Chen et al. 2008 Table3
4511 INR0 = 2.E-7; FANGLE = 30.98; FACTE = 15.7E-20
4512 DACTE = 1.82E-20
4513 ELSEIF (INSPEC.EQ.4) THEN ! BACTERIA
4514 DC1 = -0.3541568; DC2 = 1.983928; DC3 = 2.019456 ! Chen et al. 2008 Table3
4515 INR0 = 5.E-7; FANGLE = 14.82; FACTE = 17.6E-20
4516 DACTE = 1.82E-20 ! DACTE NOT SURE
4517 ENDIF
4519 MVDC = 0.; MVDR = 0.; MVDI = 0.; MVDS = 0.; MVDG = 0.
4520 MVDH = 0.; MVRC = 0.; MVRR = 0.; SMLF = 0.; GMLF = 0.
4521 HMLF = 0.; FF = 0.; DMWDT = 0.; DMIDT = 0.; ACLss1 = 0.
4522 HIdqv = 0.; HSdqv = 0.; HGdqv = 0.; HHdqv = 0.; HCwqv = 0.
4523 HRwqv = 0.; HSwqv = 0.; HGwqv = 0.; HHwqv = 0.; HHdtt = 0.
4524 QHOci = 0.; QHOrg = 0.; QNMci = 0.; QNMrg = 0.; QNCci = 0.
4525 QFZci = 0.; QFZrg = 0.; QMLir = 0.; QMLic = 0.; QMLsr = 0.
4526 QMLgr = 0.; QMLhr = 0.; QIMii = 0.; QIMcsi = 0.; QIMrsi = 0.
4527 QIMcgi = 0.; QIMrgi = 0.; QBKrc = 0.; QINig = 0.; QINsg = 0.
4528 QCNcr = 0.; QCNis = 0.; QCNgh = 0.; QRMci = 0.; QRMcs = 0.
4529 QRMcg = 0.; QRMch = 0.; QRMri = 0.; QRMrs = 0.; QRMrg = 0.
4530 QRMrh = 0.; QCLcr = 0.; QCLir = 0.; QCLis = 0.; QCLig = 0.
4531 QCLih = 0.; QCLsr = 0.; QCLsg = 0.; QCLsh = 0.; QCLgr = 0.
4532 QCLirg = 0.; QCLsrg = 0.; QCLgrg = 0.; QHwsh = 0.; QHdrm = 0.
4533 QHwml = 0.; NHOci = 0.; NHOrg = 0.; NNMci = 0.; NNMrg = 0.
4534 NNCci = 0.; NFZci = 0.; NFZrg = 0.; NMLir = 0.; NMLic = 0.
4535 NMLsr = 0.; NMLgr = 0.; NMLhr = 0.; NIMii = 0.; NIMcsi = 0.
4536 NIMrsi = 0.; NIMcgi = 0.; NIMrgi = 0.; NBKrc = 0.; NBKrr = 0.
4537 NINig = 0.; NINsg = 0.; NCNcr = 0.; NiCNis = 0.; NgCNgh = 0.
4538 NRMci = 0.; NRMcs = 0.; NRMcg = 0.; NRMch = 0.; NRMri = 0.
4539 NRMrs = 0.; NRMrg = 0.; NRMrh = 0.; NCLcc = 0.; NCLcr = 0.
4540 NCLrr = 0.; NCLir = 0.; NCLis = 0.; NCLig = 0.; NCLih = 0.
4541 NCLsr = 0.; NCLss = 0.; NhCNgh = 0.; NCLsg = 0.; NCLsh = 0.
4542 NCLgr = 0.; NCLirg = 0.; NCLsrg = 0.; NCLgrg = 0.; NHwsh = 0.
4543 NsCNis = 0.; VCLss = 0.; ViCNis = 0.; VIMii = 0.; ViCLis = 0.
4544 VsCLis = 0.; ViCLig = 0.; VgCLig = 0.; VCLih = 0.; VCLsg = 0.
4545 VsCNis = 0.; ViINig = 0.; VgINig = 0.; VFZci = 0.; VFZrg = 0.
4546 VMLir = 0.; VMLic = 0.; VRMci = 0.; VCLir = 0.; VHOci = 0.
4547 VHOrg = 0.; VNMci = 0.; VNMrg = 0.; VNCci = 0.; VIMcsi = 0.
4548 VIMcgi = 0.; VIMrsi = 0.; VIMrgi = 0.; VCLsr = 0.; VsCLsg = 0.
4549 VgCLsg = 0.; VCLsh = 0.; VsINsg = 0.; VgINsg = 0.; VMLsr = 0.
4550 VRMcs = 0.; VMLgr = 0.; VRMcg = 0.; VCNgh = 0.; VCLgr = 0.
4551 VCLirg = 0.; VCLsrg = 0.; VCLgrg = 0.; VCLis = 0.; VCLig = 0.
4552 FIMcsi = 0.; FIMcgi = 0.; FIMrsi = 0.; FIMrgi = 0.; FCLss = 0.
4553 FIMii = 0.; FHOci = 0.; FNMci = 0.; FNCci = 0.; FFZci = 0.
4554 FMLir = 0.; FCLir = 0.; FiCLis = 0.; FCLig = 0.; FCLih = 0.
4555 FRMci = 0.; FiCNis = 0.; FINig = 0.; FMLic = 0.; FsCNis = 0.
4556 FsCLis = 0.; FCLsg = 0.; FCLsh = 0.; FINsg = 0.; FMLsr = 0.
4557 FRMcs = 0.; FCLsr = 0.; IINig = 0.; IIMcsi = 0.; IIMcgi = 0.
4558 IIMrsi = 0.; IIMrgi = 0.; IIMii = 0.; IHOci = 0.; INMci = 0.
4559 INCci = 0.; IFZci = 0.; IMLir = 0.; IMLic = 0.; ICLir = 0.
4560 ICLis = 0.; ICLig = 0.; ICLih = 0.; IRMci = 0.; ICNis = 0.
4561 ACLss = 0.; AIMcsi = 0.; AIMcgi = 0.; AIMrsi = 0.; AIMrgi = 0.
4562 AIMii = 0.; AHOci = 0.; ANMci = 0.; ANCci = 0.; AFZci = 0.
4563 AMLic = 0.; AMLir = 0.; ACLir = 0.; AiCLis = 0.; AiCLig = 0.
4564 AiCLih = 0.; ARMci = 0.; AiCNis = 0.; AiINig = 0.; AgINig = 0.
4565 AsINsg = 0.; AgINsg = 0.; AsCLis = 0.; AsCLsg = 0.; AsCLsh = 0.
4566 ARMcs = 0.; ACLsr = 0.; AMLsr = 0.; AgCLig = 0.; AgCLsg = 0.
4567 AMLgr = 0.; ARMcg = 0.; AgCNgh = 0.; ACLgr = 0.; ACLirg = 0.
4568 ACLsrg = 0.; ACLgrg = 0.; AHOrg = 0.; ANMrg = 0.; AFZrg = 0.
4569 AMLhr = 0.; AhCLih = 0.; AhCLsh = 0.; ARMch = 0.; ARMrg = 0.
4570 ARMrh = 0.; AHdrm = 0.; AHwml = 0.; AsCNis = 0.; AhCNgh = 0.
4572 iDT = 1./DT
4573 iRHO = 1./RHO
4574 TC1D = TK1D-TK0C
4575 IF (TK1D.GE.265..AND.TK1D.LT.268.) FF = (TC1D+8.)*THRD
4576 IF (TK1D.GE.268..AND.TK1D.LE.270.) FF = (-3.-TC1D)*0.5
4577 RHOAJ = (RHOSU/RHO)**0.54
4578 CPM = CP*(1.+0.887*QV1D)
4579 ESW = POLYSVP(TK1D,0)
4580 ESI = POLYSVP(TK1D,1)
4581 QVSW = 0.622*ESW/(P1D-ESW)
4582 QVSI = 0.622*ESI/(P1D-ESI)
4583 SSRW = QV1D/QVSW-1.
4584 SSRI = QV1D/QVSI-1.
4585 ESW0 = POLYSVP(TK0C,0)
4586 QVSW0 = 0.622*ESW0/(P1D-ESW0)
4587 ESI0 = POLYSVP(TK0C,1)
4588 QVSI0 = 0.622*ESI0/(P1D-ESI0)
4589 XXLV = 3.1484E6-2370.*TK1D
4590 XXLS = 3.15E6-2370.*TK1D+0.3337E6
4591 XXLF = 2836310.8-(3.1484E6-2370.*TK1D)
4592 XXLF0 = 2836310.8-(3.1484E6-2370.*TK0C)
4593 SSRW0 = QV1D/QVSW0-1.
4594 SSRI0 = QV1D/QVSI0-1.
4595 DV = 2.11E-5*(TK1D/TK0C)**1.94*(101325./P1D)
4596 KAP = 2.3971E-2+0.0078E-2*TC1D
4597 MUA = 1.72E-5*(393./(TK1D+120.))*(TK1D/TK0C)**1.5
4598 SCN = (MUA/(RHO*DV))**THRD
4599 ICED = 916.7-0.175*TC1D-5.E-4*TC1D**2. ! ICE DENSITY
4600 ABW = TK1D*RV/ESW/DV+XXLV*(XXLV/TK1D/RV-1.)/TK1D/KAP
4601 ABI = TK1D*RV/ESI/DV+XXLS*(XXLS/TK1D/RV-1.)/TK1D/KAP
4602 SFCTNV = (0.095*TC1D+104.6)*1.E-3 ! SURFACE TENSION OVER ICE/VAPOR
4603 SFCTNW = (28.+0.25*TC1D)*1.E-3
4604 COSM2 = LOG(1.-COS(FANGLE*PI/180.))
4605 ACTW = LOG(1.*ESW/ESI) ! WATER ACTIVITY NEED TO BE MODIFIED
4606 EIH = MIN(1.,0.01*EXP(0.1*TC1D)) ! FERRIER ET AL., 1995
4607 ESH = MIN(1.,0.01*EXP(0.1*TC1D)) ! FERRIER ET AL., 1995
4609 IF (QC1D.GE.QSMALL) THEN
4610 CALL SOLVE_AFAC(TK1D,QC1D,NC1D,LAMC,MVDC,AFAC)
4611 GC2 = EXP(GAMLN(AFAC+2.)-GAMLN(AFAC+1.)-LOG(LAMC))
4612 GC3 = EXP(GAMLN(AFAC+3.)-GAMLN(AFAC+1.)-2.*LOG(LAMC))
4613 GC4 = EXP(GAMLN(AFAC+4.)-GAMLN(AFAC+1.)-3.*LOG(LAMC))
4614 GC5 = EXP(GAMLN(AFAC+5.)-GAMLN(AFAC+1.)-4.*LOG(LAMC))
4615 GC6 = EXP(GAMLN(AFAC+6.)-GAMLN(AFAC+1.)-5.*LOG(LAMC))
4616 GC7 = EXP(GAMLN(AFAC+7.)-GAMLN(AFAC+1.)-6.*LOG(LAMC))
4617 MVRC = MIN(MAX((QC1D/NC1D/C4PI3W)**THRD,RCMIN),RCMAX)
4618 LMVRC = LOG(MVRC)
4619 GUC = EXP(EXP(AFU+BFU*LMVRC**3.+CFU*SQRT(RHO)**3.))
4620 IF (LIQ_VTC.EQ.0) THEN
4621 FSQC = EXP(GAMLN(BVC0+BMW+AFAC+1.)-GAMLN(BMW+AFAC+1.)-BVC0*&
4622 LOG(LAMC))
4623 FSNC = EXP(GAMLN(BVC0+AFAC+1.)-GAMLN(AFAC+1.)-BVC0* &
4624 LOG(LAMC))
4625 FSAC = EXP(GAMLN(BVC0+AFAC+3.)-GAMLN(AFAC+3.)-BVC0* &
4626 LOG(LAMC))
4627 VTQC = RHOAJ*FSQC*AVC0
4628 VTNC = RHOAJ*FSNC*AVC0
4629 VTAC = RHOAJ*FSAC*AVC0
4630 ELSEIF (LIQ_VTC.EQ.1) THEN
4631 VTQC = EXP(CQC1+CQC2*LOG(NC1D)+CQC3*LOG(MVRC))*GUC/QC1D
4632 VTNC = EXP(CNC1+CNC2*LOG(NC1D)+CNC3*LOG(MVRC))*GUC/NC1D
4633 VTAC = VTQC**(3./4.)*VTNC**(1./4.)
4634 ELSEIF (LIQ_VTC.EQ.2) THEN
4635 VTQC = MVRC*(AVTC+BVTC*MVRC+CVTC*MVRC**2.)*GUC
4636 VTNC = MVRC*(AVTC+BVTC*MVRC+CVTC*MVRC**2.)*GUC
4637 VTAC = VTQC**(3./4.)*VTNC**(1./4.)
4638 ENDIF
4639 VTQC = MIN(VTQC,VTCMAX)
4640 VTNC = MIN(VTNC,VTCMAX)
4641 VTAC = MIN(VTAC,VTCMAX)
4642 QRMC1 = PI*PI*RHOW*NC1D/24.
4643 NRMC1 = PI*NC1D/4.
4644 FRMC1 = PI*RHOW*NC1D
4645 IRMC1 = PI*RHOW*NC1D/4.
4646 ARMC1 = PI*NC1D/4.
4647 QFZC1 = PI*PI*RHOW*NC1D*GC7/36.
4648 NFZC1 = PI*NC1D*GC4/6.
4649 HCwqv = SSRW0*EXP(AQ1+BQ1*LOG(NC1D)+CQ1*LMVRC)/ABW
4650 ENDIF
4651 IF (QR1D.GE.QSMALL) THEN
4652 CALL SOLVE_AFAR(TK1D,QR1D,NR1D,LAMR,MVDR,AFAR)
4653 GR2 = EXP(GAMLN(AFAR+2.)-GAMLN(AFAR+1.)-LOG(LAMR))
4654 GR3 = EXP(GAMLN(AFAR+3.)-GAMLN(AFAR+1.)-2.*LOG(LAMR))
4655 GR4 = EXP(GAMLN(AFAR+4.)-GAMLN(AFAR+1.)-3.*LOG(LAMR))
4656 GR5 = EXP(GAMLN(AFAR+5.)-GAMLN(AFAR+1.)-4.*LOG(LAMR))
4657 GR6 = EXP(GAMLN(AFAR+6.)-GAMLN(AFAR+1.)-5.*LOG(LAMR))
4658 GR7 = EXP(GAMLN(AFAR+6.)-GAMLN(AFAR+1.)-6.*LOG(LAMR))
4659 MVRR = MIN(MAX((QR1D/NR1D/C4PI3W)**THRD,RRMIN),RRMAX)
4660 LMVRR = LOG(MVRR)
4661 GUR = EXP(EXP(AFU+BFU*LMVRR**3.+CFU*SQRT(RHO)**3.))
4662 IF (LIQ_VTR.EQ.0) THEN
4663 FSQR = EXP(GAMLN(BVR0+BMW+AFAR+1.)-GAMLN(BMW+AFAR+1.)-BVR0*&
4664 LOG(LAMR))
4665 FSNR = EXP(GAMLN(BVR0+AFAR+1.)-GAMLN(AFAR+1.)-BVR0* &
4666 LOG(LAMR))
4667 FSAR = EXP(GAMLN(BVR0+AFAR+3.)-GAMLN(AFAR+3.)-BVR0* &
4668 LOG(LAMR))
4669 VTQR = RHOAJ*FSQR*AVR0
4670 VTNR = RHOAJ*FSNR*AVR0
4671 VTAR = RHOAJ*FSAR*AVR0
4672 ELSEIF (LIQ_VTR.EQ.1) THEN
4673 VTQR = EXP(CQR1+CQR2*LOG(NR1D)+CQR3*LOG(MVRR))*GUR/QR1D
4674 VTNR = EXP(CNR1+CNR2*LOG(NR1D)+CNR3*LOG(MVRR))*GUR/NR1D
4675 VTAR = VTQR**(3./4.)*VTNR*(1./4.)
4676 ELSEIF (LIQ_VTR.EQ.2) THEN
4677 VTQR = EXP(AVTR+BVTR/MVRR+CVTR/(MVRR**2.))*GUR
4678 VTNR = EXP(AVTR+BVTR/MVRR+CVTR/(MVRR**2.))*GUR
4679 VTAR = VTQR**(3./4.)*VTNR*(1./4.)
4680 ENDIF
4681 VTQR = MIN(VTQR,VTRMAX)
4682 VTNR = MIN(VTNR,VTRMAX)
4683 VTAR = MIN(VTAR,VTRMAX)
4684 QRMR1 = PI*PI*RHOW*NR1D/24.
4685 NRMR1 = PI*NR1D/4.
4686 ARMR1 = PI*NR1D/4.
4687 QFZR1 = PI*PI*RHOW*NR1D*GR7/36.
4688 NFZR1 = PI*NR1D*GR4/6.
4689 AFZR1 = PI*NR1D*GR6/6.
4690 HRwqv = SSRW0*NR1D*EXP(AQ2+(BQ2+CQ2*LMVRR)*LMVRR**2.)/ABW
4691 ENDIF
4692 IF (QI1D.GE.QSMALL) THEN
4693 CALL SOLVE_AFAI(TK1D,P1D,RHO,QV1D,QI1D,NI1D,VI1D,FI1D,AI1D, &
4694 I3M1D,ADAGR,ZETA,LAMI,AFAI,MVDI,RHOI,AMI,BMI,AVI,BVI, &
4695 BEST)
4696 IPG = 3./(ADAGR+2.)
4697 IPH = 3.*ADAGR/(ADAGR+2.)
4698 IPF = 3.*(ADAGR+1.)/(ADAGR+2.)
4699 ZETA2 = 2.*(ADAGR-1.)/(ADAGR+2.)
4700 ZETA3 = 3.*(ADAGR-1.)/(ADAGR+2.)
4701 DI0Z1 = DI0**ZETA
4702 DI0Z2 = DI0**ZETA2
4703 DI0Z3 = DI0**ZETA3
4704 DI0Z4 = DI0**(4.*ZETA)
4705 iRHOI = 1./RHOI
4706 iAMI = 1./AMI
4707 QCLI1 = PI*AMI*NI1D/4.
4708 QCNI1 = PI*XISP*AMI*NI1D/6.
4709 NCLI1 = PI*NI1D/4.
4710 NCNI1 = PI*XISP*NI1D/6.
4711 ACLI1 = PI*NI1D/4.
4712 ACNI1 = PI*XISP*NI1D/6.
4713 FCLI1 = PI*NI1D/4./DI0Z3
4714 FCNI1 = AMI*XISP*iRHOI*NI1D
4715 Z32G = ZETA3+2.*IPG
4716 Z32H = ZETA3+2.*IPH
4717 Z3BMI = ZETA3+BMI
4718 LLMI = LOG(LAMI)
4719 GI1 = GAMLN(AFAI+1.)
4720 GI2 = EXP(GAMLN(AFAI+2.)-GI1-LLMI)
4721 GI3 = EXP(GAMLN(AFAI+3.)-GI1-2.*LLMI)
4722 GI4 = EXP(GAMLN(AFAI+4.)-GI1-3.*LLMI)
4723 GI5 = EXP(GAMLN(AFAI+5.)-GI1-4.*LLMI)
4724 GIM1 = EXP(GAMLN(AFAI+BMI+1.)-GI1-BMI*LLMI)
4725 GIM2 = EXP(GAMLN(AFAI+BMI+2.)-GI1-(BMI+1.)*LLMI)
4726 GIM3 = EXP(GAMLN(AFAI+BMI+3.)-GI1-(BMI+2.)*LLMI)
4727 GIF1 = EXP(GAMLN(AFAI+IPF+1.)-GI1-IPF*LLMI)
4728 GIF2 = EXP(GAMLN(AFAI+IPF+2.)-GI1-(IPF+1.)*LLMI)
4729 GIF3 = EXP(GAMLN(AFAI+IPF+3.)-GI1-(IPF+2.)*LLMI)
4730 GIG1 = EXP(GAMLN(AFAI+IPG+1.)-GI1-IPG*LLMI)
4731 GIG2 = EXP(GAMLN(AFAI+IPG+2.)-GI1-(IPG+1.)*LLMI)
4732 GIG3 = EXP(GAMLN(AFAI+IPG+3.)-GI1-(IPG+2.)*LLMI)
4733 GIH1 = EXP(GAMLN(AFAI+IPH+1.)-GI1-IPH*LLMI)
4734 GIH2 = EXP(GAMLN(AFAI+IPH+2.)-GI1-(IPH+1.)*LLMI)
4735 GIH3 = EXP(GAMLN(AFAI+IPH+3.)-GI1-(IPH+2.)*LLMI)
4736 GIZ1 = EXP(GAMLN(AFAI+ZETA3+1.)-GI1-ZETA3*LLMI)
4737 GI2G1 = EXP(GAMLN(AFAI+2.*IPG+1.)-GI1-2.*IPG*LLMI)
4738 GI2G2 = EXP(GAMLN(AFAI+2.*IPG+2.)-GI1-(2.*IPG+1.)*LLMI)
4739 GI2G3 = EXP(GAMLN(AFAI+2.*IPG+3.)-GI1-(2.*IPG+2.)*LLMI)
4740 GI3G1 = EXP(GAMLN(AFAI+3.*IPG+1.)-GI1-3.*IPG*LLMI)
4741 GI2H1 = EXP(GAMLN(AFAI+2.*IPH+1.)-GI1-2.*IPH*LLMI)
4742 GI2H3 = EXP(GAMLN(AFAI+2.*IPH+3.)-GI1-(2.*IPH+2.)*LLMI)
4743 GI3H1 = EXP(GAMLN(AFAI+3.*IPH+1.)-GI1-3.*IPH*LLMI)
4744 GIMF1 = EXP(GAMLN(AFAI+BMI+IPF+1.)-GI1-(BMI+IPF)*LLMI)
4745 GIMG1 = EXP(GAMLN(AFAI+BMI+IPG+1.)-GI1-(BMI+IPG)*LLMI)
4746 GIMH1 = EXP(GAMLN(AFAI+BMI+IPH+1.)-GI1-(BMI+IPH)*LLMI)
4747 GIZM1 = EXP(GAMLN(AFAI+ZETA3+BMI+1.)-GI1-(ZETA3+BMI)*LLMI)
4748 GIZF1 = EXP(GAMLN(AFAI+ZETA3+IPF+1.)-GI1-(ZETA3+IPF)*LLMI)
4749 GIZG1 = EXP(GAMLN(AFAI+ZETA3+IPG+1.)-GI1-(ZETA3+IPG)*LLMI)
4750 GIZH1 = EXP(GAMLN(AFAI+ZETA3+IPH+1.)-GI1-(ZETA3+IPH)*LLMI)
4751 GI2HG1 = EXP(GAMLN(AFAI+2.*IPH+IPG+1.)-GI1-(2.*IPH+IPG)*LLMI)
4752 GIH2G1 = EXP(GAMLN(AFAI+IPH+2.*IPG+1.)-GI1-(IPH+2.*IPG)*LLMI)
4753 GIM2G1 = EXP(GAMLN(AFAI+BMI+2.*IPG+1.)-GI1-(BMI+2.*IPG)*LLMI)
4754 GIM2H1 = EXP(GAMLN(AFAI+BMI+2.*IPH+1.)-GI1-(BMI+2.*IPH)*LLMI)
4755 GIZ2G1 = EXP(GAMLN(AFAI+Z32G+1.)-GI1-Z32G*LLMI)
4756 GIZMF1 = EXP(GAMLN(AFAI+Z3BMI+IPF+1.)-GI1-(Z3BMI+IPF)*LLMI)
4757 GIZMG1 = EXP(GAMLN(AFAI+Z3BMI+IPG+1.)-GI1-(Z3BMI+IPG)*LLMI)
4758 GIZMH1 = EXP(GAMLN(AFAI+Z3BMI+IPH+1.)-GI1-(Z3BMI+IPH)*LLMI)
4759 GIZM2G1 = EXP(GAMLN(AFAI+Z32G+BMI+1.)-GI1-(Z32G+BMI)*LLMI)
4760 GIZM2H1 = EXP(GAMLN(AFAI+Z32H+BMI+1.)-GI1-(Z32H+BMI)*LLMI)
4761 FSQI = EXP(GAMLN(BVI+BMI+AFAI+1.)-GAMLN(BMI+AFAI+1.)-BVI*LLMI)
4762 FSNI = EXP(GAMLN(BVI+AFAI+1.)-GI1-BVI*LLMI)
4763 FSVI = EXP(GAMLN(BVI+AFAI+4.)-GAMLN(AFAI+4.)-BVI*LLMI)
4764 VTQI = MIN(RHOAJ*FSQI*AVI,VTIMAX)
4765 VTNI = MIN(RHOAJ*FSNI*AVI,VTIMAX)
4766 VTVI = MIN(RHOAJ*FSVI*AVI,VTIMAX)
4767 IF (AI1D.GE.ASMALL) THEN
4768 FSAI = EXP(GAMLN(BVI+AFAI+3.)-GAMLN(AFAI+3.)-BVI*LLMI)
4769 VTAI = MIN(RHOAJ*FSAI*AVI,VTIMAX)
4770 ENDIF
4771 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
4772 FSFI = EXP(GAMLN(BVI+ZETA3+AFAI+4.)-GAMLN(ZETA3+AFAI+4.)- &
4773 BVI*LLMI)
4774 FSVI = EXP(GAMLN(BVI+AFAI+4.)-GAMLN(AFAI+4.)-BVI*LLMI)
4775 VTFI = MIN(RHOAJ*FSFI*AVI,VTIMAX)
4776 VTI3M = MIN(RHOAJ*FSVI*AVI,VTIMAX)
4777 ENDIF
4778 IF (ICE_VENT.EQ.3) THEN
4779 IF ((ADAGR-1.).GE.SLIMIT) THEN
4780 BTMP = SCN*SQRT(AVI*RHOAJ/MUA)
4781 H2Z = ZC2*ZETA
4782 H4Z = ZC4*ZETA
4783 QTMP0 = EXP(GAMLN(H2Z+AFAI+2.)-GI1-LLMI*(H2Z+1.))
4784 QTMP1 = EXP(GAMLN(H4Z+AFAI+2.)-GI1-LLMI*(H4Z+1.))
4785 QTMP2 = LLMI*(H2Z+BVI/2.+IPH/2.+1.)
4786 QTMP3 = LLMI*(H4Z+BVI/2.+IPH/2.+1.)
4787 QTMP4 = EXP(GAMLN(H2Z+BVI/2.+IPH/2.+AFAI+2.)-GI1-QTMP2)
4788 QTMP5 = EXP(GAMLN(H4Z+BVI/2.+IPH/2.+AFAI+2.)-GI1-QTMP3)
4789 QTMP6 = LLMI*(H2Z+BVI+IPH+1.)
4790 QTMP7 = LLMI*(H4Z+BVI+IPH+1.)
4791 QTMP8 = EXP(GAMLN(H2Z+BVI+IPH+AFAI+2.)-GI1-QTMP6)
4792 QTMP9 = EXP(GAMLN(H4Z+BVI+IPH+AFAI+2.)-GI1-QTMP7)
4793 VENQI = ZC1*QTMP0/DI0**H2Z+ZC3*QTMP1/DI0**H4Z+VENC1*ZC1* &
4794 BTMP*QTMP4/DI0**(H2Z+ZETA)+VENC1*ZC3*BTMP*QTMP5/ &
4795 DI0**(H4Z+ZETA)+VENC2*ZC1*BTMP**2.*QTMP8/DI0**(H2Z+&
4796 ZETA2)+VENC2*ZC3*BTMP**2.*QTMP9/DI0**(H4Z+ZETA2)
4797 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
4798 BTMP = SCN*SQRT(AVI*RHOAJ/MUA)
4799 H2Z = ZP2*ZETA
4800 H4Z = ZP4*ZETA
4801 QTMP0 = EXP(GAMLN(H2Z+AFAI+2.)-GI1-LLMI*(H2Z+1.))
4802 QTMP1 = EXP(GAMLN(H4Z+AFAI+2.)-GI1-LLMI*(H4Z+1.))
4803 QTMP2 = LLMI*(H2Z+BVI/2.+IPG/2.+1.)
4804 QTMP3 = LLMI*(H4Z+BVI/2.+IPG/2.+1.)
4805 QTMP4 = EXP(GAMLN(H2Z+BVI/2.+IPG/2.+AFAI+2.)-GI1-QTMP2)
4806 QTMP5 = EXP(GAMLN(H4Z+BVI/2.+IPG/2.+AFAI+2.)-GI1-QTMP3)
4807 QTMP6 = LLMI*(H2Z+BVI+IPG+1.)
4808 QTMP7 = LLMI*(H4Z+BVI+IPG+1.)
4809 QTMP8 = EXP(GAMLN(H2Z+BVI+IPG+AFAI+2.)-GI1-QTMP6)
4810 QTMP9 = EXP(GAMLN(H4Z+BVI+IPG+AFAI+2.)-GI1-QTMP7)
4811 VENQI = ZP1*QTMP0/DI0**H2Z+ZP3*QTMP1/DI0**H4Z+VENP1*ZP1* &
4812 BTMP*QTMP4/DI0**(H2Z-ZETA/2.)+VENP1*ZP3*BTMP*QTMP5/&
4813 DI0**(H4Z-ZETA/2.)+VENP2*ZP1*BTMP**2.*QTMP8/DI0** &
4814 (H2Z-ZETA)+VENP2*ZP3*BTMP**2.*QTMP9/DI0**(H4Z-ZETA)
4815 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
4816 BTMP = SCN*SQRT(AVI*RHOAJ/MUA)
4817 QTMP0 = EXP(GAMLN(AFAI+2.)-GI1-LOG(LAMI))
4818 QTMP1 = LLMI*(1.5+BVI/2.)
4819 QTMP2 = EXP(GAMLN(BVI/2.+AFAI+2.5)-GI1-QTMP1)
4820 VENQI = AVSG*QTMP0+BVSG*BTMP*QTMP2
4821 ENDIF
4822 ELSEIF (ICE_VENT.EQ.1.OR.ICE_VENT.EQ.2) THEN
4823 IF ((ADAGR-1.).GE.SLIMIT) THEN
4824 H2Z = ZC2*ZETA
4825 H4Z = ZC4*ZETA
4826 QTMP0 = EXP(GAMLN(H2Z+AFAI+2.)-GI1-LLMI*(H2Z+1.))
4827 QTMP1 = EXP(GAMLN(H4Z+AFAI+2.)-GI1-LLMI*(H4Z+1.))
4828 IF (BEST.LE.1.) THEN
4829 BTMP = SCN**2.*(AVI*RHOAJ/MUA)
4830 QTMP2 = LLMI*(H2Z+BVI+IPH+1.)
4831 QTMP3 = LLMI*(H4Z+BVI+IPH+1.)
4832 QTMP4 = EXP(GAMLN(H2Z+BVI+IPH+AFAI+2.)-GI1-QTMP2)
4833 QTMP5 = EXP(GAMLN(H4Z+BVI+IPH+AFAI+2.)-GI1-QTMP3)
4834 VENQI = AVIS*ZC1*QTMP0/DI0**H2Z+AVIS*ZC3*QTMP1/DI0**H4Z+&
4835 BVIS*ZC1*BTMP*QTMP4/DI0**(H2Z+ZETA2)+BVIS*ZC3* &
4836 BTMP*QTMP5/DI0**(H4Z+ZETA2)
4837 ELSEIF (BEST.GT.1.) THEN
4838 BTMP = SCN*SQRT(AVI*RHOAJ/MUA)
4839 QTMP2 = LLMI*(H2Z+BVI/2.+IPH/2.+1.)
4840 QTMP3 = LLMI*(H4Z+BVI/2.+IPH/2.+1.)
4841 QTMP4 = EXP(GAMLN(H2Z+BVI/2.+IPH/2.+AFAI+2.)-GI1-QTMP2)
4842 QTMP5 = EXP(GAMLN(H4Z+BVI/2.+IPH/2.+AFAI+2.)-GI1-QTMP3)
4843 VENQI = AVSG*ZC1*QTMP0/DI0**H2Z+AVSG*ZC3*QTMP1/DI0**H4Z+&
4844 BVSG*ZC1*BTMP*QTMP4/DI0**(H2Z+ZETA)+BVSG*ZC3* &
4845 BTMP*QTMP5/DI0**(H4Z+ZETA)
4846 ENDIF
4847 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
4848 H2Z = ZP2*ZETA
4849 H4Z = ZP4*ZETA
4850 QTMP0 = EXP(GAMLN(H2Z+AFAI+2.)-GI1-LLMI*(H2Z+1.))
4851 QTMP1 = EXP(GAMLN(H4Z+AFAI+2.)-GI1-LLMI*(H4Z+1.))
4852 IF (BEST.LE.1.) THEN
4853 BTMP = SCN**2.*(AVI*RHOAJ/MUA)
4854 QTMP2 = LLMI*(H2Z+BVI+IPG+1.)
4855 QTMP3 = LLMI*(H4Z+BVI+IPG+1.)
4856 QTMP4 = EXP(GAMLN(H2Z+BVI+IPG+AFAI+2.)-GI1-QTMP2)
4857 QTMP5 = EXP(GAMLN(H4Z+BVI+IPG+AFAI+2.)-GI1-QTMP3)
4858 VENQI = AVIS*ZP1*QTMP0/DI0**H2Z+AVIS*ZP3*QTMP1/DI0**H4Z+&
4859 BVIS*ZP1*BTMP*QTMP4/DI0**(H2Z-ZETA)+BVIS*ZP3* &
4860 BTMP*QTMP5/DI0**(H4Z-ZETA)
4861 ELSEIF (BEST.GT.1.) THEN
4862 BTMP = SCN*SQRT(AVI*RHOAJ/MUA)
4863 QTMP2 = LLMI*(H2Z+BVI/2.+IPG/2.+1.)
4864 QTMP3 = LLMI*(H4Z+BVI/2.+IPG/2.+1.)
4865 QTMP4 = EXP(GAMLN(H2Z+BVI/2.+IPG/2.+AFAI+2.)-GI1-QTMP2)
4866 QTMP5 = EXP(GAMLN(H4Z+BVI/2.+IPG/2.+AFAI+2.)-GI1-QTMP3)
4867 VENQI = AVSG*ZP1*QTMP0/DI0**H2Z+AVSG*ZP3*QTMP1/DI0**H4Z+&
4868 BVSG*ZP1*BTMP*QTMP4/DI0**(H2Z-ZETA/2.)+BVSG*ZP3*&
4869 BTMP*QTMP5/DI0**(H4Z-ZETA/2.)
4870 ENDIF
4871 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
4872 QTMP0 = EXP(GAMLN(AFAI+2.)-GI1-LOG(LAMI))
4873 IF (BEST.LE.1.) THEN
4874 BTMP = SCN**2.*(AVI*RHOAJ/MUA)
4875 QTMP1 = LLMI*(BVI+2.)
4876 QTMP2 = EXP(GAMLN(BVI+AFAI+3.)-GI1-QTMP1)
4877 VENQI = AVIS*QTMP0+BVIS*BTMP*QTMP2
4878 ELSEIF (BEST.GT.1.) THEN
4879 BTMP = SCN*SQRT(AVI*RHOAJ/MUA)
4880 QTMP1 = LLMI*(1.5+BVI/2.)
4881 QTMP2 = EXP(GAMLN(BVI/2.+AFAI+2.5)-GI1-QTMP1)
4882 VENQI = AVSG*QTMP0+BVSG*BTMP*QTMP2
4883 ENDIF
4884 ENDIF
4885 ELSEIF (ICE_VENT.EQ.0) THEN
4886 IF ((ADAGR-1.).GE.SLIMIT) THEN
4887 H2Z = ZC2*ZETA
4888 H4Z = ZC4*ZETA
4889 QTMP0 = EXP(GAMLN(H2Z+AFAI+2.)-GI1-LLMI*(H2Z+1.))
4890 QTMP1 = EXP(GAMLN(H4Z+AFAI+2.)-GI1-LLMI*(H4Z+1.))
4891 VENQI = ZC1*QTMP0/DI0**H2Z+ZC3*QTMP1/DI0**H4Z
4892 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
4893 H2Z = ZP2*ZETA
4894 H4Z = ZP4*ZETA
4895 QTMP0 = EXP(GAMLN(H2Z+AFAI+2.)-GI1-LLMI*(H2Z+1.))
4896 QTMP1 = EXP(GAMLN(H4Z+AFAI+2.)-GI1-LLMI*(H4Z+1.))
4897 VENQI = ZP1*QTMP0/DI0**H2Z+ZP3*QTMP1/DI0**H4Z
4898 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
4899 VENQI = EXP(GAMLN(AFAI+2.)-GI1-LOG(LAMI))
4900 ENDIF
4901 ENDIF ! ICE_VENT
4902 HIdqv = 2.*PI*NI1D*VENQI*XXLS*SSRI0/ABI
4903 ENDIF ! QI QSMALL
4904 IF (QS1D.GE.QSMALL) THEN
4905 CALL SOLVE_AFAS(TK1D,RHO,QS1D,QC1D,NS1D,VS1D,FS1D,AS1D,AFAS, &
4906 LAMS,MVDS,RHOS,SASPR,AMS,AVS,BVS)
4907 LLMS = LOG(LAMS)
4908 GS2 = EXP(GAMLN(AFAS+2.)-GAMLN(AFAS+1.)-LLMS)
4909 GS3 = EXP(GAMLN(AFAS+3.)-GAMLN(AFAS+1.)-2.*LLMS)
4910 GS4 = EXP(GAMLN(AFAS+4.)-GAMLN(AFAS+1.)-3.*LLMS)
4911 GS5 = EXP(GAMLN(AFAS+5.)-GAMLN(AFAS+1.)-4.*LLMS)
4912 GSM1 = EXP(GAMLN(AFAS+BMS+1.)-GAMLN(AFAS+1.)-BMS*LLMS)
4913 GSM2 = EXP(GAMLN(AFAS+BMS+2.)-GAMLN(AFAS+1.)-(BMS+1.)*LLMS)
4914 GSM3 = EXP(GAMLN(AFAS+BMS+3.)-GAMLN(AFAS+1.)-(BMS+2.)*LLMS)
4915 iRHOS = 1./RHOS
4916 FSQS = EXP(GAMLN(BVS+BMS+AFAS+1.)-GAMLN(BMS+AFAS+1.)-BVS*LLMS)
4917 FSNS = EXP(GAMLN(BVS+AFAS+1.)-GAMLN(AFAS+1.)-BVS*LLMS)
4918 FSVS = EXP(GAMLN(BVS+AFAS+4.)-GAMLN(AFAS+4.)-BVS*LOG(LAMS))
4919 VTQS = MIN(RHOAJ*FSQS*AVS,VTSMAX)
4920 VTNS = MIN(RHOAJ*FSNS*AVS,VTSMAX)
4921 VTVS = MIN(RHOAJ*FSVS*AVS,VTSMAX)
4922 IF (AS1D.GE.ASMALL) THEN
4923 FSAS = EXP(GAMLN(BVS+AFAS+3.)-GAMLN(AFAS+3.)-BVS*LLMS)
4924 VTAS = MIN(RHOAJ*FSAS*AVS,VTSMAX)
4925 ENDIF
4926 QCLS1 = PI*AMS*NS1D/4.
4927 NCLS1 = PI*NS1D/4.
4928 ACLS1 = PI*NS1D/4.
4929 BSTMP = SCN*SQRT(AVS*RHOAJ/MUA)
4930 QTMP1 = LLMS*(1.5+BVS/2.)
4931 QTMP2 = EXP(GAMLN(AFAS+2.)-GAMLN(AFAS+1.)-LLMS)
4932 QTMP3 = EXP(GAMLN(BVS/2.+AFAS+2.5)-GAMLN(AFAS+1.)-QTMP1)
4933 CAPS = ZP1*SASPR**(ZP2/3.)+ZP3*SASPR**(ZP4/3.)
4934 VENQS = AVSG*QTMP2*CAPS+BVSG*BSTMP*QTMP3*CAPS
4935 SASR1 = SASPR**(-1./3.)
4936 SASR2 = SASPR**(-2./3.)
4937 SASR3 = SASPR**(1./3.)
4938 SASR4 = SASPR**(2./3.)
4939 HSdqv = 2.*PI*NS1D*VENQS*XXLS*SSRI0/ABI
4940 HSwqv = 2.*PI*NS1D*VENQS*XXLV*SSRW0/ABW
4941 ENDIF
4942 IF (QG1D.GE.QSMALL) THEN
4943 CALL SOLVE_AFAG(TK1D,RHO,QG1D,QC1D,NG1D,VG1D,AG1D,LAMG,AFAG, &
4944 MVDG,RHOG,AMG,AVG,BVG)
4945 LLMG = LOG(LAMG)
4946 GG2 = EXP(GAMLN(AFAG+2.)-GAMLN(AFAG+1.)-LLMG)
4947 GG3 = EXP(GAMLN(AFAG+3.)-GAMLN(AFAG+1.)-2.*LLMG)
4948 GG4 = EXP(GAMLN(AFAG+4.)-GAMLN(AFAG+1.)-3.*LLMG)
4949 GG5 = EXP(GAMLN(AFAG+5.)-GAMLN(AFAG+1.)-4.*LLMG)
4950 GGM1 = EXP(GAMLN(AFAG+BMG+1.)-GAMLN(AFAG+1.)-BMG*LLMG)
4951 GGM2 = EXP(GAMLN(AFAG+BMG+2.)-GAMLN(AFAG+1.)-(BMG+1.)*LLMG)
4952 GGM3 = EXP(GAMLN(AFAG+BMG+3.)-GAMLN(AFAG+1.)-(BMG+2.)*LLMG)
4953 iAMG = 1./AMG
4954 iRHOG = 1./RHOG
4955 FSQG = EXP(GAMLN(BVG+BMG+AFAG+1.)-GAMLN(BMG+AFAG+1.)-BVG*LLMG)
4956 FSNG = EXP(GAMLN(BVG+AFAG+1.)-GAMLN(AFAG+1.)-BVG*LLMG)
4957 FSVG = EXP(GAMLN(BVG+AFAG+4.)-GAMLN(AFAG+4.)-BVG*LOG(LAMG))
4958 VTQG = MIN(RHOAJ*FSQG*AVG,VTGMAX)
4959 VTNG = MIN(RHOAJ*FSNG*AVG,VTGMAX)
4960 VTVG = MIN(RHOAJ*FSVG*AVG,VTGMAX)
4961 IF (AG1D.GE.ASMALL) THEN
4962 FSAG = EXP(GAMLN(BVG+AFAG+3.)-GAMLN(AFAG+3.)-BVG*LLMG)
4963 VTAG = MIN(RHOAJ*FSAG*AVG,VTGMAX)
4964 ENDIF
4965 QCLG1 = PI*AMG*NG1D/4.
4966 NCLG1 = PI*NG1D/4.
4967 ACLG1 = PI*NG1D/4.
4968 BGTMP = SCN*SQRT(AVG*RHOAJ/MUA)
4969 QTMP1 = LLMG*(1.5+BVG/2.)
4970 QTMP2 = EXP(GAMLN(AFAG+2.)-GAMLN(AFAG+1.)-LLMG)
4971 QTMP3 = EXP(GAMLN(BVG/2.+AFAG+2.5)-GAMLN(AFAG+1.)-QTMP1)
4972 VENQG = AVSG*QTMP2+BVSG*BGTMP*QTMP3
4973 HGdqv = 2.*PI*NG1D*VENQG*XXLS*SSRI0/ABI
4974 HGwqv = 2.*PI*NG1D*VENQG*XXLV*SSRW0/ABW
4975 ENDIF
4976 IF (QH1D.GE.QSMALL) THEN
4977 CALL SOLVE_AFAH(TK1D,RHO,QH1D,NH1D,AH1D,LAMH,AFAH,MVDH,AVH,BVH)
4978 LLMH = LOG(LAMH)
4979 GH2 = EXP(GAMLN(AFAH+2.)-GAMLN(AFAH+1.)-LLMH)
4980 GH3 = EXP(GAMLN(AFAH+3.)-GAMLN(AFAH+1.)-2.*LLMH)
4981 GH4 = EXP(GAMLN(AFAH+4.)-GAMLN(AFAH+1.)-3.*LLMH)
4982 GH5 = EXP(GAMLN(AFAH+5.)-GAMLN(AFAH+1.)-4.*LLMH)
4983 FSQH = EXP(GAMLN(BVH+BMH+AFAH+1.)-GAMLN(BMH+AFAH+1.)-BVH*LLMH)
4984 FSNH = EXP(GAMLN(BVH+AFAH+1.)-GAMLN(AFAH+1.)-BVH*LLMH)
4985 VTQH = MIN(RHOAJ*FSQH*AVH,VTHMAX)
4986 VTNH = MIN(RHOAJ*FSNH*AVH,VTHMAX)
4987 IF (AH1D.GE.ASMALL) THEN
4988 FSAH = EXP(GAMLN(BVH+AFAH+3.)-GAMLN(AFAH+3.)-BVH*LLMH)
4989 VTAH = MIN(RHOAJ*FSAH*AVH,VTHMAX)
4990 ENDIF
4991 BHTMP = SCN*SQRT(AVH*RHOAJ/MUA)
4992 IF (HAIL_VENT.EQ.0) THEN
4993 QTMP1 = LLMH*(1.5+BVH/2.)
4994 QTMP2 = EXP(GAMLN(AFAH+2.)-GAMLN(AFAH+1.)-LOG(LAMH))
4995 QTMP3 = EXP(GAMLN(BVH/2.+AFAH+2.5)-GAMLN(AFAH+1.)-QTMP1)
4996 ATMP1 = LLMH*(0.5+BVH/2.)
4997 ATMP2 = EXP(GAMLN(BVH/2.+AFAH+1.5)-GAMLN(AFAH+1.)-ATMP1)
4998 VENQH = AVRH*QTMP2+BVRH*BHTMP*QTMP3
4999 VENAH = AVRH+BVRH*BHTMP*ATMP2
5000 ELSEIF (HAIL_VENT.EQ.1) THEN
5001 QTMP1 = LLMH*(1.5+BVH/2.)
5002 QTMP2 = EXP(GAMLN(AFAH+2.)-GAMLN(AFAH+1.)-LOG(LAMH))
5003 QTMP3 = EXP(GAMLN(BVH/2.+AFAH+2.5)-GAMLN(AFAH+1.)-QTMP1)
5004 QTMP4 = LLMH*(2.+BVH)
5005 QTMP5 = EXP(GAMLN(BVH+AFAH+3.)-GAMLN(AFAH+1.)-QTMP4)
5006 ATMP1 = LLMH*(0.5+BVH/2.)
5007 ATMP2 = EXP(GAMLN(BVH/2.+AFAH+1.5)-GAMLN(AFAH+1.)-ATMP1)
5008 ATMP3 = LLMH*(1.+BVH)
5009 ATMP4 = EXP(GAMLN(BVH+AFAH+2.)-GAMLN(AFAH+1.)-ATMP3)
5010 VENQH = QTMP2+VENH1*BHTMP*QTMP3+VENH2*BHTMP**2.*QTMP5
5011 VENAH = 1.+VENH1*BHTMP*ATMP2+VENH2*BHTMP**2.*ATMP4
5012 ENDIF
5013 HHdqv = 2.*PI*NH1D*VENQH*XXLS*SSRI0/ABI
5014 HHwqv = 2.*PI*NH1D*VENQH*XXLV*SSRW0/ABW
5015 ENDIF
5016 !----------------- CHEN&LIU WARM CLOUD PROCESSES ----------------------
5017 IF (QC1D.GE.QSMALL) THEN
5018 NCLcc = EXP(AN3+BN3*LOG(NC1D)+CN3*LMVRC**3.)*GUC
5019 NCNcr = NC1D*NC1D*EXP(AN4+BN4*MVRC+CN4/MVRC)*GUC
5020 QCNcr = NCNcr*EXP(AQ4+BQ4*QC1D/NC1D)
5021 NCNcr = MIN(NCNcr,NC1D*iDT)
5022 QCNcr = MIN(QCNcr,QC1D*iDT)
5023 ENDIF
5024 IF (QR1D.GE.QSMALL) THEN
5025 NCLrr = MIN(EXP(AN6+BN6*LOG(NR1D)+CN6/MVRR)*GUR,NR1D*iDT)
5026 NBKrr = NCLrr*EXP(AN7+(BN7+CN7*MVRR)*MVRR)
5027 NBKrc = NCLrr*EXP(AN8+(BN8+CN8*MVRR)*MVRR)
5028 QBKrc = MIN(NBKrc**BQ8*EXP(AQ8+CQ8*LMVRR),QR1D*iDT)
5029 NBKrc = MIN(NBKrc,NR1D*iDT)
5030 ENDIF
5031 IF (QC1D.GE.QSMALL.AND.QR1D.GE.QSMALL) THEN
5032 NCLcr = NC1D*NR1D*GUR*EXP(AN5+BN5*LMVRR+CN5*LMVRC)
5033 QCLcr = NC1D*NR1D*GUR*EXP(AQ5+BQ5*LMVRR+CQ5*LMVRC)
5034 NCLcr = MIN(NCLcr,NC1D*iDT)
5035 QCLcr = MIN(QCLcr,QC1D*iDT)
5036 ENDIF
5037 IF (TK1D.LT.TK0C) THEN
5038 IF ((HIdqv+HSdqv+HGdqv+HHdqv).GE.QSMALL) THEN
5039 VDMAX = XXLS*(QV1D-QVSI0)/(1.+XXLS**2.*QV1D/(CPM*RV* &
5040 TK1D**2.))*iDT
5041 SUMDEP = HIdqv+HSdqv+HGdqv+HHdqv
5042 IF (SUMDEP.GT.VDMAX.AND.VDMAX.GE.QSMALL) THEN
5043 RATIO = MIN(1.,VDMAX/(SUMDEP+QSMALL))
5044 HIdqv = HIdqv*RATIO
5045 HSdqv = HSdqv*RATIO
5046 HGdqv = HGdqv*RATIO
5047 HHdqv = HHdqv*RATIO
5048 ENDIF
5049 ENDIF
5050 IF ((HIdqv+HSdqv+HGdqv+HHdqv).LT.0.) THEN
5051 SBMAX = XXLS*(QV1D-QVSI0)/(1.+XXLS**2.*QV1D/(CPM*RV* &
5052 TK1D**2.))*iDT
5053 SUMSUB = HIdqv+HSdqv+HGdqv+HHdqv
5054 IF (SBMAX.LT.0..AND.SUMSUB.LT.SBMAX*0.9999) THEN
5055 HIdqv = HIdqv*MIN(1.,0.9999*SBMAX/SUMSUB)
5056 HSdqv = HSdqv*MIN(1.,0.9999*SBMAX/SUMSUB)
5057 HGdqv = HGdqv*MIN(1.,0.9999*SBMAX/SUMSUB)
5058 HHdqv = HHdqv*MIN(1.,0.9999*SBMAX/SUMSUB)
5059 ENDIF
5060 ENDIF
5061 !---------- HOMO/HETER FREEZING OF DROPLETS AND RAIN DROPS ------------
5062 IF (QC1D.GE.QSMALL) THEN ! DeMott et al. (1994)
5063 TMP1 = TC1D*TC1D
5064 VOLMC = C4PI3*(MVRC*1.E6)**3.
5065 IJHOF = (10.**MAX(-20.,(-606.3952-52.6611*TC1D-1.7439*TMP1-&
5066 0.0265*TMP1*TC1D-1.536e-4*TMP1**2.)))
5067 RFZ = 1.-EXP(-IJHOF*VOLMC*DT)
5068 IF (TK1D.GT.243.15) RFZ = 0.
5069 IF (TK1D.LT.223.15) RFZ = 1.
5070 NHOci = RFZ*NC1D*iDT
5071 QHOci = RFZ*QC1D*iDT
5072 VHOci = QHOci*iRHOI0
5073 FHOci = QHOci*1.*iAMI0
5074 IHOci = QHOci*iAMI0
5075 AHOci = (KCIMIN*NHOci*IHOci**2.)**THRD
5076 ENDIF
5077 IF (TK1D.LT.269.15.AND.QC1D.GE.QSMALL) THEN
5078 QNMci = QFZC1*BIMM*EXP(AIMM*(TK0C-TK1D)-1.)
5079 NNMci = NFZC1*BIMM*EXP(AIMM*(TK0C-TK1D)-1.)
5080 QNMci = MIN(QNMci,QC1D*iDT)
5081 NNMci = MIN(NNMci,NC1D*iDT)
5082 VNMci = QNMci*iRHOI0
5083 FNMci = QNMci*1.*iAMI0 ! ISOMETRIC
5084 INMci = QNMci*iAMI0
5085 ANMci = (KCIMIN*NNMci*INMci**2.)**THRD
5086 ENDIF
5087 IF (QC1D.GE.QSMALL.AND.TK1D.LT.271.15) THEN ! Referred to MY2 scheme
5088 RGIMF = (2.*2.99E-26*SFCTNW)/(ICED*BOLTZ*TK1D*ACTW)
5089 GGCNT = C4PI3*SFCTNV*RGIMF**2.
5090 EPA = ESI*QV1D/QVSI
5091 GEOF2 = EXP(DC1+DC2*COSM2+DC3*RGIMF/INR0)
5092 NGCNT0 = EXP((-DACTE-GEOF2*GGCNT)/(BOLTZ*TK1D))
5093 NGCNT1 = EPA/(1.61E-11*TK1D**(0.5)) ! 1.61E-11 = vs*(2*PI*mw*k)**0.5
5094 ! NGCNT = MAX(4.*PI*INR0**2.*NGCNT0*NGCNT1,1.)*QNIN
5095 CNTGG0 = (XXLV**2.-XXLV*RV*TK1D)/(KAP*RV*TK1D**2.)
5096 CNTGG = (RV*TK1D/(ESW*DV)+CNTGG0)**(-1.)/RHOW
5097 KDIFF = 9.1018E-11*TK1D**2.+8.8197E-8*TK1D-1.0654E-5 ! AIR THERMAL DIFFUSIVITY (COTTON ET AL., 1986)
5098 TCC = TC1D+CNTGG*SSRW*XXLV/KDIFF ! DROPLETS TEMPERATURE
5099 NGCNT = EXP(4.11-0.262*TCC)
5100 CNTKN = 6.6E-8*TK1D*101325./(293.15*P1D*INR0) ! KNUDSEN NUMBER
5101 PSIA = -1.*BOLTZ*TCC*(1.+CNTKN)/(6.*PI*INR0*MUA) ! AEROSOL DIFFUSIVITY
5102 KAPA = 5.39E5 ! AEROSOL THERMAL CONDUCTIVITY
5103 CNTFT0 = 0.4*(1.+1.45*CNTKN+0.4*CNTKN*EXP(-1./CNTKN))
5104 CNTFT1 = (1.+3.*CNTKN)*(2.*KAP+5.*KAPA*CNTKN+KAPA)
5105 CNTFT = CNTFT0*(KAP+2.5*CNTKN*KAPA)/CNTFT1
5106 CNTF1 = 4.*PI*NGCNT*NC1D*MVRC
5107 CNTF2 = KAP*(TC1D-TCC)/P1D
5108 IJCNT1 = -1.*CNTF1*CNTF2*RV*TK1D/(XXLV*RHO) ! DIFFUSIOPHORESIS
5109 IJCNT2 = CNTF1*CNTF2*CNTFT*iRHO ! THERMEOPHORESIS
5110 IJCNT3 = CNTF1*PSIA ! BROWNIAN DIFFUSION
5111 ! NNCci = MIN(MAX(0.,IJCNT1+IJCNT2+IJCNT3),NC1D*iDT)
5112 ! QNCci = NNCci*QC1D/NC1D
5113 ! VNCci = QNCci*iRHOI0
5114 ! FNCci = QNCci*1.*iAMI0 ! ISOMETRIC
5115 ! INCci = QNCci*iAMI0
5116 ! ANCci = (KCIMIN*NNCci*INCci**2.)**THRD
5117 ENDIF
5118 IF (TK1D.LE.233.15.AND.QR1D.GE.QSMALL) THEN
5119 QHOrg = QR1D*iDT
5120 NHOrg = NR1D*iDT
5121 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
5122 VHOrg = QHOrg/RHOG0
5123 ENDIF
5124 AHOrg = (KCGMAX*NHOrg*(QHOrg*V2M3/RHOG0)**2.)**THRD
5125 ENDIF
5126 IF (TK1D.LT.269.15.AND.QR1D.GE.QSMALL) THEN
5127 QNMrg = QFZR1*BIMM*EXP(AIMM*(TK0C-TK1D)-1.)
5128 NNMrg = NFZR1*BIMM*EXP(AIMM*(TK0C-TK1D)-1.)
5129 QNMrg = MIN(QNMrg,QR1D*iDT)
5130 NNMrg = MIN(NNMrg,NR1D*iDT)
5131 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
5132 VNMrg = QNMrg/RHOG0
5133 ENDIF
5134 ANMrg = AFZR1*BIMM*EXP(AIMM*(TK0C-TK1D)-1.)
5135 ENDIF
5136 !------------------ AUTO-CONVERSION PROCESSES -------------------------
5137 IF (QI1D.GE.QSMALL.AND.MVDI.GE.1.E-5) THEN
5138 ! EII1 = 0.1*EXP(0.1*TC1D) ! STRAKA AND MANSELL (2005)
5139 EII1 = 10.**(3.5E-2*TC1D-0.7) ! BASEN ON COTTON ET AL. (1986)
5140 IF (ICE_RHOI.EQ.1) THEN
5141 EII2 = 1.-RHOI/RHOI0
5142 ELSE
5143 EII2 = 0.
5144 ENDIF
5145 EII = MIN(MAX(EII1,EII2,0.),1.)
5146 IF ((ADAGR-1.).GE.SLIMIT) THEN
5147 QCNis = QCNI1*VTQI*EII*NI1D*(GIM2H1/DI0Z4+2.*GIMF1/ &
5148 DI0Z1+DI0Z2*GIM2G1)
5149 NiCNis = NCNI1*VTNI*EII*NI1D*(GI2H1/DI0Z4+2.*GIF1/DI0Z1+&
5150 DI0Z2*GI2G1)
5151 IF (AI1D.GE.ASMALL) THEN
5152 AiCNis = ACNI1*VTAI*EII*NI1D*(GI2H3/DI0Z4+2.*GIF3/ &
5153 DI0Z1+DI0Z2*GI2G3)
5154 ENDIF
5155 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5156 FiCNis = FCNI1*VTFI*EII*NI1D/DI0Z3*(GIZM2H1/DI0Z4+2.*&
5157 GIZMF1/DI0Z1+DI0Z2*GIZM2G1)
5158 ICNis = FCNI1*VTI3M*EII*NI1D*(GIM2H1/DI0Z4+2.*GIMF1/ &
5159 DI0Z1+DI0Z2*GIM2G1)
5160 ENDIF
5161 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
5162 QCNis = QCNI1*VTQI*EII*NI1D*4.*DI0Z2*GIM2G1
5163 NiCNis = NCNI1*VTNI*EII*NI1D*4.*DI0Z2*GI2G1
5164 IF (AI1D.GE.ASMALL) THEN
5165 AiCNis = ACNI1*VTAI*EII*NI1D*4.*DI0Z2*GI2G3
5166 ENDIF
5167 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5168 FiCNis = FCNI1*VTFI*EII*NI1D*4.*DI0Z2*GIZM2G1/DI0Z3
5169 ICNis = FCNI1*VTI3M*EII*NI1D*4.*DI0Z2*GIM2G1
5170 ENDIF
5171 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
5172 QCNis = QCNI1*VTQI*EII*NI1D*4.*GIM3
5173 NiCNis = NCNI1*VTNI*EII*NI1D*4.*GI3
5174 IF (AI1D.GE.ASMALL) THEN
5175 AiCNis = ACNI1*VTAI*EII*NI1D*4.*GI5
5176 ENDIF
5177 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5178 FiCNis = FCNI1*VTFI*EII*NI1D*4.*GIM3
5179 ICNis = FCNI1*VTI3M*EII*NI1D*4.*GIM3
5180 ENDIF
5181 ENDIF
5182 QCNis = MIN(2.*QCNis,QI1D*iDT)
5183 NsCNis = MIN(NiCNis,NI1D*iDT)
5184 NiCNis = MIN(2.*NiCNis,NI1D*iDT)
5185 AiCNis = MIN(2.*AiCNis,AI1D*iDT)
5186 FiCNis = MIN(2.*FiCNis,FI1D*iDT)
5187 ICNis = MIN(2.*ICNis,I3M1D*iDT)
5188 ViCNis = MIN(QCNis*iRHOI,VI1D*iDT)
5189 IF (ICE_RHOS.EQ.1.OR.AGG_SHAPE.EQ.1) THEN
5190 LIM1 = 0.7*(1.-RHOI/RHOI0) ! CONTACT ANGLE = 45
5191 LIM2 = SQRT(1.-LIM1*LIM1)
5192 LIM3 = (1.+2.*ISEPS+ISEPS**2.+ISEPL+2.*ISEPS*ISEPL+ &
5193 ISEPS**2.*ISEPL)/8.
5194 LIM4 = 2.*LIM3*LIM2
5195 LIM5 = LIM3*LIM2**2.
5196 LIM6 = LIM3*LIM2
5197 LIM7 = 2.*LIM3*LIM2**2.
5198 LIM8 = LIM3*LIM2**3.
5199 LIMA = (1.+2.*ISEPL+ISEPL**2.+ISEPS+2.*ISEPL*ISEPS+ &
5200 ISEPL**2.*ISEPS)/8.
5201 LIMB = LIMA*LIM2
5202 LIMC = 2.*LIMA*LIM2
5203 LIMD = 2.*LIMA*LIM2**2.
5204 LIME = LIMA*LIM2**2.
5205 LIMF = LIMA*LIM2**3.
5206 DICC = DI0**(-6.*ZETA)*GI3H1
5207 DICA = GI2HG1/DI0Z3
5208 DIAC = GIH2G1
5209 DIAA = DI0Z3*GI3G1
5210 DIA0 = DI0Z1*GIG1
5211 DIC0 = GIH1/DI0Z2
5212 IF ((ADAGR-1.).GE.SLIMIT) THEN
5213 DILSV = (LIMA+LIMB+LIMC+LIMD+LIME+LIMF)*DICA
5214 DILSF = (LIM3+LIM4+LIM5+LIM6+LIM7+LIM8)*DIAC
5215 SASP1 = MIN((1.+LIM2+ISEPS+ISEPS*LIM2)*DIA0,(1.+ &
5216 LIM2+ISEPL+ISEPL*LIM2)*DIC0)/MAX((1.+LIM2+ &
5217 ISEPS+ISEPS*LIM2)*DIA0,(1.+LIM2+ISEPL+ISEPL* &
5218 LIM2)*DIC0)
5219 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
5220 DILSV = (LIMA+LIMB+LIMC+LIMD+LIME+LIMF)*DIAC
5221 DILSF = (LIM3+LIM4+LIM5+LIM6+LIM7+LIM8)*DICA
5222 SASP1 = MIN((1.+LIM2+ISEPS+ISEPS*LIM2)*DIC0,(1.+ &
5223 LIM2+ISEPL+ISEPL*LIM2)*DIA0)/MAX((1.+LIM2+ &
5224 ISEPS+ISEPS*LIM2)*DIC0,(1.+LIM2+ISEPL+ISEPL* &
5225 LIM2)*DIA0)
5226 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
5227 DILSV = (LIMA+LIMB+LIMC+LIMD+LIME+LIMF)*GI4
5228 DILSF = (LIM3+LIM4+LIM5+LIM6+LIM7+LIM8)*GI4
5229 SASP1 = MIN(1.+LIM2+ISEPS+ISEPS*LIM2,1.+LIM2+ISEPL+ &
5230 ISEPL*LIM2)/MAX(1.+LIM2+ISEPS+ISEPS*LIM2,1.+ &
5231 LIM2+ISEPL+ISEPL*LIM2)
5232 ENDIF
5233 DNIAG = 2.*AMI*GIM1*V2M3/DILSV
5234 VsCNis = NiCNis*DILSV/V2M3
5235 FsCNis = NiCNis*DILSF
5236 RATIO = (RHOI/DNIAG)**THRD
5237 ELSE
5238 RATIO = 1.
5239 ENDIF
5240 IF ((ADAGR-1.).GE.SLIMIT) THEN
5241 AsCNis = ACNI1*VTAI*EII*NI1D*(GI2H3/DI0Z4+2.*GIF3/DI0Z1+&
5242 DI0Z2*GI2G3)*1.5874*RATIO**2.
5243 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
5244 AsCNis = ACNI1*VTAI*EII*NI1D*4.*DI0Z2*GI2G3*1.5874* &
5245 RATIO**2.
5246 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
5247 AsCNis = ACNI1*VTAI*EII*NI1D*4.*GI5*1.5874*RATIO**2.
5248 ENDIF
5249 ENDIF
5250 IF (QG1D.GE.QSMALL) THEN
5251 DSLL = 2.*1.E-2*(EXP(MIN(20.,-TC1D/(1.1E4*(QC1D+QR1D)- &
5252 1.3E3*QG1D+1.)))-1.)
5253 DSLL = MIN(1.,MAX(1.E-4,DSLL))
5254 IF (AFAG.LE.20.) THEN
5255 RATIO = MIN(1.,MAX(0.,ABS(GAMMP(AFAG+1.,DSLL*LAMG))))
5256 NGTAL = NG1D*(1.-RATIO)
5257 IF (NGTAL.GE.NSMALL) THEN
5258 QCNgh = MIN((1.-RATIO)*QG1D*iDT,QG1D*iDT)
5259 NgCNgh = MIN((1.-RATIO)*NG1D*iDT,NG1D*iDT)
5260 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
5261 VCNgh = MIN((1.-RATIO)*VG1D*iDT,VG1D*iDT)
5262 ENDIF
5263 IF (AG1D.GE.ASMALL) THEN
5264 AgCNgh = MIN((1.-RATIO)*AG1D*iDT,AG1D*iDT)
5265 ENDIF
5266 ENDIF
5267 ELSE
5268 IF (MVDG.GE.DSLL) THEN
5269 QCNgh = QG1D*iDT
5270 NgCNgh = NG1D*iDT
5271 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
5272 VCNgh = VG1D*iDT
5273 ENDIF
5274 IF (AG1D.GE.ASMALL) THEN
5275 AgCNgh = AG1D*iDT
5276 ENDIF
5277 ENDIF
5278 ENDIF
5279 NhCNgh = QCNgh/(AMH*DHMIN**BMH)
5280 AhCNgh = (KCHMIN*NhCNgh*(QCNgh*iAMH)**2.)**THRD
5281 ENDIF
5282 !----------------- RIMING OF CLOUD DROPLETS ----------------------------
5283 IF (QI1D.GE.QSMALL.AND.QC1D.GE.QSMALL) THEN
5284 VTQ0 = VTQI-VTQC
5285 VTN0 = VTNI-VTNC
5286 VTAX = VTAI-VTAC
5287 VTV0 = VTVI-VTQC
5288 VTF0 = VTFI-VTQC
5289 VTQIC = SQRT(VTQ0*VTQ0+0.04*VTQI*VTQC)
5290 VTNIC = SQRT(VTN0*VTN0+0.04*VTNI*VTNC)
5291 VTAIC = SQRT(VTAX*VTAX+0.04*VTAI*VTAC)
5292 VTVIC = SQRT(VTV0*VTV0+0.04*VTVI*VTQC)
5293 VTFIC = SQRT(VTF0*VTF0+0.04*VTFI*VTQC)
5294 IF (ICE_RHOG.EQ.0) THEN
5295 DNIRM = RHOG1
5296 ELSEIF (ICE_RHOG.EQ.1) THEN
5297 DNRI = MIN(MAX(-5.E5*MVDC*VTQIC/TC1D,0.),6.)
5298 DNIRM = 1.E3*(0.078+0.184*DNRI-0.015*DNRI**2.)
5299 ELSEIF (ICE_RHOG.EQ.2) THEN
5300 DNIRM = 3.E2*(-5.E5*MVDC*0.6*VTQIC/TC1D)**0.44
5301 ENDIF
5302 DNIRM = MIN(MAX(DNIRM,RHOIMIN),RHOG0)
5303 RHOIW = (QI1D+QC1D)/(QI1D/RHOI+QC1D/RHOW+ISMALL)
5304 RATIO = (RHOIW/RHOI)**THRD
5305 MVDX = MAX((MVDC**3.+MVDI**3.)**THRD*RATIO,MVDI)
5306 IF ((ADAGR-1.).GE.SLIMIT.AND.MVDI.GE.1.E-4) THEN
5307 WBIN = MIN(MAX(NINT(MVDC*1.E6/10.),0),20)
5308 CNRE = VTQI*DI0**(-2.*ZETA)*MVDI**IPH*RHO/MUA
5309 IF (CNRE.LT.0.4) CBIN = 0
5310 IF (CNRE.GE.0.4.AND.CNRE.LT.0.6) CBIN = 1
5311 IF (CNRE.GE.0.6.AND.CNRE.LT.0.9) CBIN = 2
5312 IF (CNRE.GE.0.9.AND.CNRE.LT.1.5) CBIN = 3
5313 IF (CNRE.GE.1.5.AND.CNRE.LT.3.5) CBIN = 4
5314 IF (CNRE.GE.3.5.AND.CNRE.LT.7.5) CBIN = 5
5315 IF (CNRE.GE.7.5.AND.CNRE.LT.15.) CBIN = 6
5316 IF (CNRE.GE.15.) CBIN = 7
5317 CBIN = MIN(MAX(CBIN,0),7)
5318 ECI = MAX(0.,IECC(CBIN*21+WBIN))
5319 QRMci = QRMC1*ECI*VTQIC*NI1D*(GIF1*GC4/DI0Z1+GIG1*GC5* &
5320 DI0Z1+GIH1*GC5/DI0Z2+GC6)
5321 NRMci = NRMC1*ECI*VTNIC*NI1D*(GIF1/DI0Z1+GIG1*GC2*DI0Z1+&
5322 GIH1*GC2/DI0Z2+GC3)
5323 IF (AI1D.GE.ASMALL) THEN
5324 ARMci = (MVDX**2.-MVDI**2.)*NRMC1*ECI*VTAIC*NI1D*( &
5325 GIF1/DI0Z1+GIG1*GC2*DI0Z1+GIH1*GC2/DI0Z2+GC3)
5326 ENDIF
5327 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5328 FRMci = FRMC1*ECI*VTFIC*NI1D/DNIRM/8./DI0Z3*(GIZF1* &
5329 GC4/DI0Z1+GIZG1*GC5*DI0Z1+GIZH1*GC5/DI0Z2+ &
5330 GIZ1*GC6)
5331 IRMci = IRMC1*ECI*VTVIC*NI1D/DNIRM*(GIF1*GC4/DI0Z1+ &
5332 GIG1*GC5*DI0Z1+GIH1*GC5/DI0Z2+GC6)
5333 ENDIF
5334 ELSEIF ((1.-ADAGR).GE.SLIMIT.AND.MVDI.GE.1.5E-4) THEN
5335 WBIN = MIN(MAX(NINT(MVDC*1.E6/10.),0),20)
5336 PNRE = VTQI*DI0**ZETA*MVDI**IPG*RHO/MUA
5337 IF (PNRE.LT.1.5) PBIN = 0
5338 IF (PNRE.GE.1.5.AND.PNRE.LT.6.0) PBIN = 1
5339 IF (PNRE.GE.6.0.AND.PNRE.LT.15.) PBIN = 2
5340 IF (PNRE.GE.15..AND.PNRE.LT.28.) PBIN = 3
5341 IF (PNRE.GE.28..AND.PNRE.LT.43.) PBIN = 4
5342 IF (PNRE.GE.43..AND.PNRE.LT.70.) PBIN = 5
5343 IF (PNRE.GE.70..AND.PNRE.LT.105.) PBIN = 6
5344 IF (PNRE.GE.105.) PBIN = 7
5345 PBIN = MIN(MAX(PBIN,0),7)
5346 ECI = MAX(0.,IEPC(PBIN*21+WBIN))
5347 QRMci = QRMC1*ECI*VTQIC*NI1D*(GI2G1*GC4*DI0Z2+2.*GIG1* &
5348 GC5*DI0Z1+GC6)
5349 NRMci = NRMC1*ECI*VTNIC*NI1D*(GI2G1*DI0Z2+2.*GIG1*GC2* &
5350 DI0Z1+GC3)
5351 IF (AI1D.GE.ASMALL) THEN
5352 ARMci = (MVDX**2.-MVDI**2.)*NRMC1*ECI*VTAIC*NI1D*( &
5353 GI2G1*DI0Z2+2.*GIG1*GC2*DI0Z1+GC3)
5354 ENDIF
5355 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5356 FRMci = FRMC1*ECI*VTFIC*NI1D/DNIRM/2./DI0Z3*(GIZ2G1* &
5357 GC4*DI0Z2+2.*GIZG1*GC5*DI0Z1+GIZ1*GC6)
5358 IRMci = IRMC1*ECI*VTVIC*NI1D/DNIRM*(GI2G1*GC4*DI0Z2+ &
5359 2.*GIG1*GC5*DI0Z1+GC6)
5360 ENDIF
5361 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT.AND.MVDI.GE.2.E-4) THEN
5362 ECI = 0.5
5363 QRMci = QRMC1*ECI*VTQIC*NI1D*(GI3*GC4+2.*GI2*GC5+GC6)
5364 NRMci = NRMC1*ECI*VTNIC*NI1D*(GI3+2.*GI2*GC2+GC3)
5365 IF (AI1D.GE.ASMALL) THEN
5366 ARMci = (MVDX**2.-MVDI**2.)*NRMC1*ECI*VTAIC*NI1D*( &
5367 GI3+2.*GI2*GC2+GC3)
5368 ENDIF
5369 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5370 FRMci = FRMC1*ECI*VTFIC*NI1D/DNIRM/4.*(GI3*GC4+2.* &
5371 GI2*GC5+GC6)
5372 IRMci = IRMC1*ECI*VTVIC*NI1D/DNIRM*(GI3*GC4+2.*GI2* &
5373 GC5+GC6)
5374 ENDIF
5375 ENDIF
5376 QRMci = MIN(QRMci,QC1D*iDT)
5377 NRMci = MIN(NRMci,NC1D*iDT)
5378 VRMci = QRMci/DNIRM
5379 FRMci = MIN(FRMci,QC1D*iDT/AMW)
5380 IRMci = MIN(IRMci,QC1D*iDT/AMW)
5381 ARMci = MAX(0.,MIN(ARMci,QC1D*iDT*iAPW/MVDC))
5382 IF (QRMci.GT.0.) THEN
5383 QINig = MIN(2.*QRMci,QI1D*iDT)
5384 NINig = MIN(QINig*NI1D/QI1D,NI1D*iDT)
5385 ViINig = MIN(VRMci+QRMci*VI1D/QI1D,VI1D*iDT)
5386 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
5387 VgINig = 2.*VRMci
5388 ENDIF
5389 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5390 FINig = MIN(FRMci+QRMci*FI1D/QI1D,FI1D*iDT)
5391 IINig = MIN(IRMci+QRMci*I3M1D/QI1D,I3M1D*iDT)
5392 ENDIF
5393 IF (AI1D.GE.ASMALL) THEN
5394 AiINig = MIN(ARMci+QRMci*AI1D/QI1D,AI1D*iDT)
5395 AgINig = (KCGMAX*NINig*(QINig*V2M3/DNIRM)**2.)**THRD
5396 ENDIF
5397 ENDIF
5398 ENDIF
5399 IF (QS1D.GE.QSMALL.AND.QC1D.GE.QSMALL.AND.MVDS.GE.1.5E-4) THEN
5400 ECS = MIN(MVDC,3.E-5)*3.333E4*SQRT(MIN(MVDS,1.E-3)*1.E3) ! Pruppacher&Klett(1997) Fig.14-11
5401 VTQ0 = VTQS-VTQC
5402 VTN0 = VTNS-VTNC
5403 VTAX = VTAS-VTAC
5404 VTV0 = VTVS-VTQC
5405 VTQSC = SQRT(VTQ0*VTQ0+0.04*VTQS*VTQC)
5406 VTNSC = SQRT(VTN0*VTN0+0.04*VTNS*VTNC)
5407 VTASC = SQRT(VTAX*VTAX+0.04*VTAS*VTAC)
5408 VTVSC = SQRT(VTV0*VTV0+0.04*VTVS*VTQC)
5409 IF (ICE_RHOG.EQ.0) THEN
5410 DNSRM = RHOG1
5411 ELSEIF (ICE_RHOG.EQ.1) THEN
5412 DNRI = MIN(MAX(-5.E5*MVDC*VTQSC/TC1D,0.),6.)
5413 DNSRM = 1.E3*(0.078+0.184*DNRI-0.015*DNRI**2.)
5414 ELSEIF (ICE_RHOG.EQ.2) THEN
5415 DNSRM = 3.E2*(-5.E5*MVDC*0.6*VTQSC/TC1D)**0.44
5416 ENDIF
5417 DNSRM = MIN(MAX(DNSRM,RHOIMIN),RHOG0)
5418 RHOSW = (QS1D+QC1D)/(QS1D/RHOS+QC1D/RHOW+ISMALL)
5419 RATIO = (RHOSW/RHOS)**THRD
5420 MVDX = MAX((MVDC**3.+MVDS**3.)**THRD*RATIO,MVDS)
5421 QRMcs = QRMC1*ECS*VTQSC*NS1D*(SASR2*GS3*GC4+SASR1*2.*GS2* &
5422 GC5+GC6)
5423 NRMcs = NRMC1*ECS*VTNSC*NS1D*(SASR2*GS3+SASR1*2.*GS2*GC2+ &
5424 GC3)
5425 QRMcs = MIN(QRMcs,QC1D*iDT)
5426 NRMcs = MIN(NRMcs,NC1D*iDT)
5427 IF (ICE_RHOS.EQ.1) THEN
5428 VRMcs = QRMcs/DNSRM
5429 ENDIF
5430 IF (AGG_SHAPE.EQ.1) THEN
5431 FRMcs = FRMC1*ECS*VTVSC*NS1D*SASPR/DNSRM/2.*(SASR2*GS3* &
5432 GC4+SASR1*2.*GS2*GC5+GC6)
5433 FRMcs = MIN(FRMcs,QC1D*iDT/AMW)
5434 ENDIF
5435 IF (AS1D.GE.ASMALL) THEN
5436 ARMcs = (MVDX**2.-MVDS**2.)*NRMC1*ECS*VTASC*NS1D*(SASR2*&
5437 GS3+SASR1*2.*GS2*GC2+GC3)
5438 ARMcs = MAX(0.,MIN(ARMcs,QC1D*iDT*iAPW/MVDC))
5439 ENDIF
5440 IF (QRMcs.GT.0.) THEN
5441 NIMcsi = 3.5E8*QRMcs*FF
5442 QIMcsi = MIN(NIMcsi*MI0,QRMcs)
5443 VIMcsi = QIMcsi*iRHOI0
5444 FIMcsi = QIMcsi*1.*iAMI0
5445 IIMcsi = QIMcsi*iAMI0
5446 AIMcsi = (KCIMIN*NIMcsi*IIMcsi**2.)**THRD
5447 QINsg = MIN(2.*QRMcs,QS1D*iDT)
5448 NINsg = MIN(QINsg*NS1D/QS1D,NS1D*iDT)
5449 IF (ICE_RHOS.EQ.1) THEN
5450 VsINsg = MIN(VRMcs+QRMcs*VS1D/QS1D,VS1D*iDT)
5451 ENDIF
5452 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
5453 VgINsg = 2.*VRMcs
5454 ENDIF
5455 IF (AGG_SHAPE.EQ.1) THEN
5456 FINsg = MIN(FRMcs+QRMcs*FS1D/QS1D,FS1D*iDT)
5457 ENDIF
5458 IF (AS1D.GE.ASMALL) THEN
5459 AsINsg = MIN(ARMcs+QRMcs*AS1D/QS1D,AS1D*iDT)
5460 AgINsg = (KCGMAX*NINsg*(QINsg*V2M3/DNSRM)**2.)**THRD
5461 ENDIF
5462 ENDIF
5463 ENDIF
5464 IF (QG1D.GE.QSMALL.AND.QC1D.GE.QSMALL.AND.MVDG.GE.2.E-4) THEN
5465 STOKE = (RHOW*VTQG*MVDC**2.)/(9.*MUA*MVDG)
5466 STOKE = MAX(1.5,MIN(10.,STOKE))
5467 ECG = 5.5E-1*LOG10(2.51*STOKE) ! parameterization based on Cober and List,1993 [JAS]
5468 VTQ0 = VTQG-VTQC
5469 VTN0 = VTNG-VTNC
5470 VTAX = VTAG-VTAC
5471 VTQGC = SQRT(VTQ0*VTQ0+0.04*VTQG*VTQC)
5472 VTNGC = SQRT(VTN0*VTN0+0.04*VTNG*VTNC)
5473 VTAGC = SQRT(VTAX*VTAX+0.04*VTAG*VTAC)
5474 IF (ICE_RHOG.EQ.0) THEN
5475 DNGRM = RHOG1
5476 ELSEIF (ICE_RHOG.EQ.1) THEN
5477 DNRI = MIN(MAX(-5.E5*MVDC*VTQGC/TC1D,0.),6.)
5478 DNGRM = 1.E3*(0.078+0.184*DNRI-0.015*DNRI**2.)
5479 ELSEIF (ICE_RHOG.EQ.2) THEN
5480 DNGRM = 3.E2*(-5.E5*MVDC*0.6*VTQGC/TC1D)**0.44
5481 ENDIF
5482 DNGRM = MIN(MAX(DNGRM,RHOIMIN),RHOG0)
5483 RHOGW = (QG1D+QC1D)/(QG1D/RHOG+QC1D/RHOW+ISMALL)
5484 RATIO = (RHOGW/RHOG)**THRD
5485 MVDX = MAX((MVDC**3.+MVDG**3.)**THRD*RATIO,MVDG)
5486 QRMcg = QRMC1*ECG*VTQGC*NG1D*(GG3*GC4+2.*GG2*GC5+GC6)
5487 NRMcg = NRMC1*ECG*VTNGC*NG1D*(GG3+2.*GG2*GC2+GC3)
5488 QRMcg = MIN(QRMcg,QC1D*iDT)
5489 NRMcg = MIN(NRMcg,NC1D*iDT)
5490 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
5491 VRMcg = QRMcg/DNGRM
5492 ENDIF
5493 IF (AG1D.GE.ASMALL) THEN
5494 ARMcg = (MVDX**2.-MVDG**2.)*NRMC1*ECG*VTAGC*NG1D*(GG3+ &
5495 2.*GG2*GC2+GC3)
5496 ARMcg = MAX(0.,MIN(ARMcg,QC1D*iDT*iAPW/MVDC))
5497 ENDIF
5498 IF (QRMcg.GT.0.) THEN
5499 NIMcgi = 3.5E8*QRMcg*FF
5500 QIMcgi = MIN(NIMcgi*MI0,QRMcg)
5501 VIMcgi = QIMcgi*iRHOI0
5502 FIMcgi = QIMcgi*1.*iAMI0
5503 IIMcgi = QIMcgi*iAMI0
5504 AIMcgi = (KCIMIN*NIMcgi*IIMcgi**2.)**THRD
5505 ENDIF
5506 ENDIF
5507 IF (QH1D.GE.QSMALL.AND.QC1D.GE.QSMALL) THEN
5508 ECH = EXP(-8.68E-7*MVDC**(-1.6)*MVDH) ! Ziegler (1985) A24
5509 VTQ0 = VTQH-VTQC
5510 VTN0 = VTNH-VTNC
5511 VTAX = VTAH-VTAC
5512 VTQHC = SQRT(VTQ0*VTQ0+0.04*VTQH*VTQC)
5513 VTNHC = SQRT(VTN0*VTN0+0.04*VTNH*VTNC)
5514 VTAHC = SQRT(VTAX*VTAX+0.04*VTAH*VTAC)
5515 RHOHW = (QH1D+QC1D)/(QH1D/RHOH+QC1D/RHOW+ISMALL)
5516 RATIO = (RHOHW/RHOH)**THRD
5517 MVDX = MAX((MVDC**3.+MVDH**3.)**THRD*RATIO,MVDH)
5518 QRMch = QRMC1*ECH*VTQHC*NH1D*(GH3*GC4+2.*GH2*GC5+GC6)
5519 NRMch = NRMC1*ECH*VTNHC*NH1D*(GH3+2.*GH2*GC2+GC3)
5520 QRMch = MIN(QRMch,QC1D*iDT)
5521 NRMch = MIN(NRMch,NC1D*iDT)
5522 IF (AH1D.GE.ASMALL) THEN
5523 ARMch = (MVDX**2.-MVDH**2.)*NRMC1*ECH*VTAHC*NH1D*(GH3+ &
5524 2.*GH2*GC2+GC3)
5525 ARMch = MAX(0.,MIN(ARMch,QC1D*iDT*iAPW/MVDC))
5526 ENDIF
5527 ENDIF
5528 !----------------- RIMING/COLLECTION OF RAIN DROPS ---------------------
5529 IF (QR1D.GE.QSMALL.AND.QI1D.GE.QSMALL) THEN
5530 ERI = 1.
5531 VTQ0 = VTQR-VTQI
5532 VTN0 = VTNR-VTNI
5533 VTAX = VTAR-VTAI
5534 VTV0 = VTQR-VTVI
5535 VTF0 = VTQR-VTFI
5536 VTQRI = SQRT(VTQ0*VTQ0+0.04*VTQR*VTQI)
5537 VTNRI = SQRT(VTN0*VTN0+0.04*VTNR*VTNI)
5538 VTARI = SQRT(VTAX*VTAX+0.04*VTAR*VTAI)
5539 VTVRI = SQRT(VTV0*VTV0+0.04*VTQR*VTVI)
5540 VTFRI = SQRT(VTF0*VTF0+0.04*VTQR*VTFI)
5541 IF ((ADAGR-1.).GE.SLIMIT.AND.MVDR.GE.MVDI) THEN
5542 QCLir = QCLI1*ERI*VTQRI*NR1D*(GIMF1/DI0Z1+GIMG1*GR2* &
5543 DI0Z1+GIMH1*GR2/DI0Z2+GIM1*GR3)
5544 NCLir = NCLI1*ERI*VTNRI*NR1D*(GIF1/DI0Z1+GIG1*GR2*DI0Z1+&
5545 GIH1*GR2/DI0Z2+GR3)
5546 IF (AI1D.GE.ASMALL) THEN
5547 ACLir = ACLI1*ERI*VTARI*NR1D*(GIF3/DI0Z1+GIG3*GR2* &
5548 DI0Z1+GIH3*GR2/DI0Z2+GI3*GR3)
5549 ENDIF
5550 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5551 FCLir = FCLI1*ERI*VTFRI*NR1D*(GIZMF1/DI0Z1+GIZMG1* &
5552 GR2*DI0Z1+GIZMH1*GR2/DI0Z2+GIZM1*GR3)
5553 ICLir = NCLI1*ERI*VTVRI*NR1D*(GIMF1/DI0Z1+GIMG1*GR2* &
5554 DI0Z1+GIMH1*GR2/DI0Z2+GIM1*GR3)
5555 ENDIF
5556 ELSEIF ((1.-ADAGR).GE.SLIMIT.AND.MVDR.GE.MVDI) THEN
5557 QCLir = QCLI1*ERI*VTQRI*NR1D*(GIM2G1*DI0Z2+2.*GIMG1*GR2*&
5558 DI0Z1+GIM1*GR3)
5559 NCLir = NCLI1*ERI*VTNRI*NR1D*(GI2G1*DI0Z2+2.*GIG1*GR2* &
5560 DI0Z1+GR3)
5561 IF (AI1D.GE.ASMALL) THEN
5562 ACLir = ACLI1*ERI*VTARI*NR1D*(GI2G3*DI0Z2+2.*GIG3* &
5563 GR2*DI0Z1+GI3*GR3)
5564 ENDIF
5565 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5566 FCLir = FCLI1*ERI*VTFRI*NR1D*(GIZM2G1*DI0Z2+2.* &
5567 GIZMG1*GR2*DI0Z1+GIZM1*GR3)
5568 ICLir = NCLI1*ERI*VTVRI*NR1D*(GIM2G1*DI0Z2+2.*GIMG1* &
5569 GR2*DI0Z1+GIM1*GR3)
5570 ENDIF
5571 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT.AND.MVDR.GE.MVDI) THEN
5572 QCLir = QCLI1*ERI*VTQRI*NR1D*(GIM3+2.*GIM2*GR2+GIM1*GR3)
5573 NCLir = NCLI1*ERI*VTNRI*NR1D*(GI3+2.*GI2*GR2+GR3)
5574 IF (AI1D.GE.ASMALL) THEN
5575 ACLir = ACLI1*ERI*VTARI*NR1D*(GI5+2.*GI4*GR2+GI3*GR3)
5576 ENDIF
5577 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5578 FCLir = NCLI1*ERI*VTFRI*NR1D*(GIM3+2.*GIM2*GR2+GIM1* &
5579 GR3)
5580 ICLir = NCLI1*ERI*VTVRI*NR1D*(GIM3+2.*GIM2*GR2+GIM1* &
5581 GR3)
5582 ENDIF
5583 ENDIF
5584 QCLir = MIN(QCLir,QI1D*iDT)
5585 NCLir = MIN(NCLir,NI1D*iDT)
5586 VCLir = MIN(QCLir*iRHOI,VI1D*iDT)
5587 ACLir = MIN(ACLir,AI1D*iDT)
5588 FCLir = MIN(FCLir,FI1D*iDT)
5589 ICLir = MIN(ICLir,I3M1D*iDT)
5590 IF (ICE_RHOG.EQ.0) THEN
5591 DNIRM = RHOG1
5592 ELSEIF (ICE_RHOG.EQ.1) THEN
5593 DNRI = MIN(MAX(-5.E5*MVDR*VTQRI/TC1D,0.),6.)
5594 DNIRM = 1.E3*(0.078+0.184*DNRI-0.015*DNRI**2.)
5595 ELSEIF (ICE_RHOG.EQ.2) THEN
5596 DNIRM = 3.E2*(-5.E5*MVDR*0.6*VTQRI/TC1D)**0.44
5597 ENDIF
5598 DNIRM = MIN(MAX(DNIRM,RHOIMIN),RHOG0)
5599 RHOIW = (QI1D+QR1D)/(QI1D/RHOI+QR1D/RHOW+ISMALL)
5600 RATIO = (RHOIW/DNIRM)**THRD
5601 IF (MVDI.GE.MVDR) THEN
5602 IF ((ADAGR-1.).GE.SLIMIT.AND.MVDI.GE.1.E-4) THEN
5603 QRMri = QRMR1*ERI*VTQRI*NI1D*(GIF1*GR4/DI0Z1+GIG1*GR5* &
5604 DI0Z1+GIH1*GR5/DI0Z2+GR6)
5605 NRMri = NRMR1*ERI*VTNRI*NI1D*(GIF1/DI0Z1+GIG1*GR2*DI0Z1+&
5606 GIH1*GR2/DI0Z2+GR3)
5607 ELSEIF ((1.-ADAGR).GE.SLIMIT.AND.MVDI.GE.1.5E-4) THEN
5608 QRMri = QRMR1*ERI*VTQRI*NI1D*(GI2G1*GR4*DI0Z2+2.*GIG1* &
5609 GR5*DI0Z1+GR6)
5610 NRMri = NRMR1*ERI*VTNRI*NI1D*(GI2G1*DI0Z2+2.*GIG1*GR2* &
5611 DI0Z1+GR3)
5612 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT.AND.MVDI.GE.2.E-4) THEN
5613 QRMri = QRMR1*ERI*VTQRI*NI1D*(GI3*GR4+2.*GI2*GR5+GR6)
5614 NRMri = NRMR1*ERI*VTNRI*NI1D*(GI3+2.*GI2*GR2+GR3)
5615 ENDIF
5616 QRMri = MIN(QRMri,QR1D*iDT)
5617 NRMri = MIN(NRMri,NR1D*iDT)
5618 ENDIF
5619 MVDX = MAX((MVDR**3.+MVDI**3.)**THRD*RATIO,MVDI,MVDR)
5620 QCLirg = QRMri+QCLir
5621 NCLirg = QCLirg*V2M3/(DNIRM*(RATIO*MVDX)**3.)
5622 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
5623 VCLirg = QCLirg/DNIRM
5624 ENDIF
5625 ACLirg = (KCIMIN*NCLirg*(QCLirg*V2M3/DNIRM)**2.)**THRD
5626 ENDIF
5627 IF (QR1D.GE.QSMALL.AND.QS1D.GE.QSMALL) THEN
5628 ERS = 1.
5629 VTQ0 = VTQR-VTQS
5630 VTN0 = VTNR-VTNS
5631 VTAX = VTAR-VTAS
5632 VTQRS = SQRT(VTQ0*VTQ0+0.04*VTQR*VTQS)
5633 VTNRS = SQRT(VTN0*VTN0+0.04*VTNR*VTNS)
5634 VTARS = SQRT(VTAX*VTAX+0.04*VTAR*VTAS)
5635 IF (ICE_RHOG.EQ.0) THEN
5636 DNSRM = RHOG1
5637 ELSEIF (ICE_RHOG.EQ.1) THEN
5638 DNRI = MIN(MAX(-5.E5*MVDR*VTQRS/TC1D,0.),6.)
5639 DNSRM = 1.E3*(0.078+0.184*DNRI-0.015*DNRI**2.)
5640 ELSEIF (ICE_RHOG.EQ.2) THEN
5641 DNSRM = 3.E2*(-5.E5*MVDR*0.6*VTQRS/TC1D)**0.44
5642 ENDIF
5643 DNSRM = MIN(MAX(DNSRM,RHOIMIN),RHOG0)
5644 RHOSW = (QS1D+QR1D)/(QS1D/RHOS+QR1D/RHOW+ISMALL)
5645 RATIO = (RHOSW/DNSRM)**THRD
5646 IF (MVDS.GE.2.E-4.AND.MVDS.GE.MVDR) THEN
5647 QRMrs = QRMR1*ERS*VTQRS*NS1D*(SASR2*GS3*GR4+SASR1*2.* &
5648 GS2*GR5+GR6)
5649 NRMrs = NRMR1*ERS*VTNRS*NS1D*(SASR2*GS3+SASR1*2.*GS2* &
5650 GR2+GR3)
5651 QRMrs = MIN(QRMrs,QR1D*iDT)
5652 NRMrs = MIN(NRMrs,NR1D*iDT)
5653 ENDIF
5654 IF (MVDR.GE.MVDS) THEN
5655 QCLsr = QCLS1*ERS*VTQRS*NR1D*(SASR2*GSM3+SASR1*2.*GR2* &
5656 GSM2+GR3*GSM1)
5657 NCLsr = NCLS1*ERS*VTNRS*NR1D*(SASR2*GS3+SASR1*2.*GR2* &
5658 GS2+GR3)
5659 QCLsr = MIN(QCLsr,QS1D*iDT)
5660 NCLsr = MIN(NCLsr,NS1D*iDT)
5661 IF (ICE_RHOS.EQ.1) THEN
5662 VCLsr = MIN(QCLsr*iRHOS,VS1D*iDT)
5663 ENDIF
5664 IF (AGG_SHAPE.EQ.1) THEN
5665 FCLsr = MIN(QCLsr*iRHOS*SASPR*V2M3,FS1D*iDT)
5666 ENDIF
5667 IF (AS1D.GE.ASMALL) THEN
5668 ACLsr = ACLS1*ERS*VTARS*NR1D*(SASR2*GS5+SASR1*2.*GR2*&
5669 GS4+GR3*GS3)
5670 ACLsr = MIN(ACLsr,AS1D*iDT)
5671 ENDIF
5672 ENDIF
5673 IF (QRMrs.GT.0.) THEN
5674 NIMrsi = 3.5E8*QRMrs*FF
5675 QIMrsi = MIN(NIMrsi*MI0,QRMrs)
5676 VIMrsi = QIMrsi*iRHOI0
5677 FIMrsi = QIMrsi*1.*iAMI0
5678 IIMrsi = QIMrsi*iAMI0
5679 AIMrsi = (KCIMIN*NIMrsi*IIMrsi**2.)**THRD
5680 ENDIF
5681 MVDX = MAX((MVDR**3.+MVDS**3.)**THRD*RATIO,MVDR,MVDS)
5682 QCLsrg = QRMrs+QCLsr
5683 NCLsrg = QCLsrg*V2M3/(DNSRM*(RATIO*MVDX)**3.)
5684 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
5685 VCLsrg = QCLsrg/DNSRM
5686 ENDIF
5687 ACLsrg = (KCIMIN*NCLsrg*(QCLsrg*V2M3/DNSRM)**2.)**THRD
5688 ENDIF
5689 IF (QR1D.GE.QSMALL.AND.QG1D.GE.QSMALL) THEN
5690 VTQ0 = VTQR-VTQG
5691 VTN0 = VTNR-VTNG
5692 VTAX = VTAR-VTAG
5693 VTQRG = SQRT(VTQ0*VTQ0+0.04*VTQR*VTQG)
5694 VTNRG = SQRT(VTN0*VTN0+0.04*VTNR*VTNG)
5695 VTARG = SQRT(VTAX*VTAX+0.04*VTAR*VTAG)
5696 RHOGW = (QG1D+QR1D)/(QG1D/RHOG+QR1D/RHOW+ISMALL)
5697 RATIO = (RHOGW/DNGRM)**THRD
5698 STOKE = (RHOW*ABS(VTQ0)*MVDR**2.)/(9.*MUA*MVDG)
5699 STOKE = MAX(1.5,MIN(10.,STOKE))
5700 ERG = 5.5E-1*LOG10(2.51*STOKE) ! parameterization based on Cober and List, 1993 [JAS]
5701 IF (ICE_RHOG.EQ.0) THEN
5702 DNGRM = RHOG1
5703 ELSEIF (ICE_RHOG.EQ.1) THEN
5704 DNRI = MIN(MAX(-5.E5*MVDR*VTQRG/TC1D,0.),6.)
5705 DNGRM = 1.E3*(0.078+0.184*DNRI-0.015*DNRI**2.)
5706 ELSEIF (ICE_RHOG.EQ.2) THEN
5707 DNGRM = 3.E2*(-5.E5*MVDR*0.6*VTQRG/TC1D)**0.44
5708 ENDIF
5709 DNGRM = MIN(MAX(DNGRM,RHOIMIN),RHOG0)
5710 IF (MVDG.GE.2.E-4.AND.MVDG.GE.MVDR) THEN
5711 QRMrg = QRMR1*ERG*VTQRG*NG1D*(GG3*GR4+2.*GG2*GR5+GR6)
5712 NRMrg = NRMR1*ERG*VTNRG*NG1D*(GG3+2.*GG2*GR2+GR3)
5713 QRMrg = MIN(QRMrg,QR1D*iDT)
5714 NRMrg = MIN(NRMrg,NR1D*iDT)
5715 IF (AG1D.GE.ASMALL) THEN
5716 MVDX = MAX((MVDR**3.+MVDG**3.)**THRD*RATIO,MVDG)
5717 ARMrg = (MVDX**2.-MVDG**2.)*NRMR1*ERG*VTARG*NG1D*( &
5718 GG3+2.*GG2*GR2+GR3)
5719 ARMrg = MIN(ARMrg,QR1D*iDT*iAPW/MVDR)
5720 ENDIF
5721 ENDIF
5722 IF (MVDR.GE.MVDG) THEN
5723 QCLgr = QCLG1*ERG*VTQRG*NR1D*(GGM3+2.*GR2*GGM2+GR3*GGM1)
5724 NCLgr = NCLG1*ERG*VTNRG*NR1D*(GG3+2.*GR2*GG2+GR3)
5725 QCLgr = MIN(QCLgr,QG1D*iDT)
5726 NCLgr = MIN(NCLgr,NG1D*iDT)
5727 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
5728 VCLgr = MIN(QCLgr*iRHOG,VG1D*iDT)
5729 ENDIF
5730 IF (AG1D.GE.ASMALL) THEN
5731 ACLgr = ACLG1*ERG*VTARG*NR1D*(GG5+2.*GR2*GG4+GR3*GG3)
5732 ACLgr = MIN(ACLgr,AG1D*iDT)
5733 ENDIF
5734 ENDIF
5735 IF (QRMrg.GT.0.) THEN
5736 NIMrgi = 3.5E8*QRMrg*FF
5737 QIMrgi = MIN(NIMrgi*MI0,QRMrg)
5738 VIMrgi = QIMrgi*iRHOI0
5739 FIMrgi = QIMrgi*1.*iAMI0
5740 IIMrgi = QIMrgi*iAMI0
5741 AIMrgi = (KCIMIN*NIMrgi*IIMrgi**2.)**THRD
5742 ENDIF
5743 MVDX = MAX((MVDR**3.+MVDG**3.)**THRD*RATIO,MVDR,MVDG)
5744 QCLgrg = QRMrg+QCLgr
5745 NCLgrg = QCLgrg*V2M3/(DNGRM*(RATIO*MVDX)**3.)
5746 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
5747 VCLgrg = QCLgrg/DNGRM
5748 ENDIF
5749 ! ACLgrg = (KCIMIN*NCLgrg*(QCLgrg*V2M3/DNGRM)**2.)**THRD
5750 ACLgrg = ARMrg+ACLgr
5751 ENDIF
5752 IF (QH1D.GE.QSMALL.AND.QR1D.GE.QSMALL.AND.MVDH.GE.MVDR) THEN
5753 ERH = 1.
5754 VTQ0 = VTQR-VTQH
5755 VTN0 = VTNR-VTNH
5756 VTAX = VTAR-VTAH
5757 VTQRH = SQRT(VTQ0*VTQ0+0.04*VTQR*VTQH)
5758 VTNRH = SQRT(VTN0*VTN0+0.04*VTNR*VTNH)
5759 VTARH = SQRT(VTAX*VTAX+0.04*VTAR*VTAH)
5760 RHOHW = (QH1D+QR1D)/(QH1D/RHOH+QR1D/RHOW+ISMALL)
5761 RATIO = (RHOHW/RHOH)**THRD
5762 MVDX = MAX((MVDR**3.+MVDH**3.)**THRD*RATIO,MVDH)
5763 QRMrh = QRMR1*ERH*VTQRH*NH1D*(GH3*GR4+2.*GH2*GR5+GR6)
5764 NRMrh = NRMR1*ERH*VTNRH*NH1D*(GH3+2.*GH2*GR2+GR3)
5765 QRMrh = MIN(QRMrh,QR1D*iDT)
5766 NRMrh = MIN(NRMrh,NR1D*iDT)
5767 IF (AH1D.GE.ASMALL) THEN
5768 ARMrh = (MVDX**2.-MVDH**2.)*NRMR1*ERH*VTARH*NH1D*(GH3+ &
5769 2.*GH2*GR2+GR3)
5770 ARMrh = MIN(ARMrh,QR1D*iDT*iAPW/MVDR)
5771 ENDIF
5772 ENDIF
5773 !----------------- ICE-PHASE COLLECTION&CONVERSION*INITILIZATION -------
5774 IF (QS1D.GE.QSMALL.AND.QI1D.GE.QSMALL.AND.MVDS.GE.MVDI) THEN
5775 ! EIS1 = MIN(1.,0.05*EXP(0.1*TC1D)) ! FERRIER ET AL., 1995
5776 EIS1 = 10.**(3.5E-2*TC1D-0.7)
5777 RHOIS = (QI1D+QS1D)/(QI1D/RHOI+QS1D/RHOS+ISMALL)
5778 IF (ICE_RHOI.NE.2.AND.ICE_RHOS.NE.0) THEN
5779 EIS2 = 1.-RHOIS/RHOI0
5780 ELSE
5781 EIS2 = 0.
5782 ENDIF
5783 EIS = MIN(MAX(EIS1,EIS2,0.),1.)
5784 RATIO = (RHOIS/RHOS)**THRD
5785 MVDX = MAX((MVDI**3.+MVDS**3.)**THRD*RATIO,MVDS)
5786 VTQ0 = VTQS-VTQI
5787 VTN0 = VTNS-VTNI
5788 VTV0 = VTVS-VTVI
5789 VTF0 = VTVS-VTFI
5790 VTQIS = SQRT(VTQ0*VTQ0+0.04*VTQI*VTQS)
5791 VTNIS = SQRT(VTN0*VTN0+0.04*VTNI*VTNS)
5792 VTVIS = SQRT(VTV0*VTV0+0.04*VTVI*VTVS)
5793 VTFIS = SQRT(VTF0*VTF0+0.04*VTFI*VTVS)
5794 IF (AS1D.GE.ASMALL.OR.AI1D.GE.ASMALL) THEN
5795 VTAX = VTAS-VTAI
5796 VTAIS = SQRT(VTAX*VTAX+0.04*VTAI*VTAS)
5797 ENDIF
5798 IF ((ADAGR-1.).GE.SLIMIT) THEN
5799 QCLis = QCLI1*EIS*VTQIS*NS1D*(GIMF1/DI0Z1+SASR1*GIMG1* &
5800 GS2*DI0Z1+SASR1*GIMH1*GS2/DI0Z2+SASR2*GIM1*GS3)
5801 NCLis = NCLI1*EIS*VTNIS*NS1D*(GIF1/DI0Z1+SASR1*GIG1*GS2*&
5802 DI0Z1+SASR1*GIH1*GS2/DI0Z2+SASR2*GS3)
5803 IF (AI1D.GE.ASMALL) THEN
5804 AiCLis = ACLI1*EIS*VTAIS*NS1D*(GIF3/DI0Z1+SASR1*GIG3*&
5805 GS2*DI0Z1+SASR1*GIH3*GS2/DI0Z2+SASR2*GI3*GS3)
5806 ENDIF
5807 IF (AS1D.GE.ASMALL) THEN
5808 AsCLis = (MVDX**2.-MVDS**2.)*NCLI1*EIS*VTAIS*NS1D*( &
5809 GIF1/DI0Z1+SASR1*GIG1*GS2*DI0Z1+SASR1*GIH1* &
5810 GS2/DI0Z2+SASR2*GS3)
5811 ENDIF
5812 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5813 FiCLis = FCLI1*EIS*VTFIS*NS1D*(GIZMF1/DI0Z1+SASR1* &
5814 GIZMG1*GS2*DI0Z1+SASR1*GIZMH1*GS2/DI0Z2+ &
5815 SASR2*GIZM1*GS3)
5816 ICLis = NCLI1*EIS*VTVIS*NS1D*(GIMF1/DI0Z1+SASR1* &
5817 GIMG1*GS2*DI0Z1+SASR1*GIMH1*GS2/DI0Z2+SASR2* &
5818 GIM1*GS3)
5819 ENDIF
5820 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
5821 QCLis = QCLI1*EIS*VTQIS*NS1D*(GIM2G1*DI0Z2+SASR1*2.* &
5822 GIMG1*GS2*DI0Z1+SASR2*GIM1*GS3)
5823 NCLis = NCLI1*EIS*VTNIS*NS1D*(GI2G1*DI0Z2+SASR1*2.*GIG1*&
5824 GS2*DI0Z1+SASR2*GS3)
5825 IF (AI1D.GE.ASMALL) THEN
5826 AiCLis = ACLI1*EIS*VTAIS*NS1D*(GI2G3*DI0Z2+SASR1*2.* &
5827 GIG3*GS2*DI0Z1+SASR2*GI3*GS3)
5828 ENDIF
5829 IF (AS1D.GE.ASMALL) THEN
5830 AsCLis = (MVDX**2.-MVDS**2.)*NCLI1*EIS*VTAIS*NS1D*( &
5831 GI2G1*DI0Z2+SASR1*2.*GIG1*GS2*DI0Z1+SASR2* &
5832 GS3)
5833 ENDIF
5834 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5835 FiCLis = FCLI1*EIS*VTFIS*NS1D*(GIZM2G1*DI0Z2+SASR1* &
5836 2.*GIZMG1*GS2*DI0Z1+SASR2*GIZM1*GS3)
5837 ICLis = NCLI1*EIS*VTVIS*NS1D*(GIM2G1*DI0Z2+SASR1*2.* &
5838 GIMG1*GS2*DI0Z1+SASR2*GIM1*GS3)
5839 ENDIF
5840 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
5841 QCLis = QCLI1*EIS*VTQIS*NS1D*(GIM3+SASR1*2.*GIM2*GS2+ &
5842 SASR2*GIM1*GS3)
5843 NCLis = NCLI1*EIS*VTNIS*NS1D*(GI3+SASR1*2.*GI2*GS2+ &
5844 SASR2*GS3)
5845 IF (AI1D.GE.ASMALL) THEN
5846 AiCLis = ACLI1*EIS*VTAIS*NS1D*(GI5+SASR1*2.*GI4*GS2+ &
5847 SASR2*GI3*GS3)
5848 ENDIF
5849 IF (AS1D.GE.ASMALL) THEN
5850 AsCLis = (MVDX**2.-MVDS**2.)*NCLI1*EIS*VTAIS*NS1D*( &
5851 GI3+SASR1*2.*GI2*GS2+SASR2*GS3)
5852 ENDIF
5853 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5854 FiCLis = NCLI1*EIS*VTFIS*NS1D*(GIM3+SASR1*2.*GIM2* &
5855 GS2+SASR2*GIM1*GS3)
5856 ICLis = NCLI1*EIS*VTVIS*NS1D*(GIM3+SASR1*2.*GIM2*GS2+&
5857 SASR2*GIM1*GS3)
5858 ENDIF
5859 ENDIF
5860 QCLis = MIN(QCLis,QI1D*iDT)
5861 NCLis = MIN(NCLis,NI1D*iDT)
5862 AiCLis = MIN(AiCLis,AI1D*iDT)
5863 ViCLis = MIN(QCLis*iRHOI,VI1D*iDT)
5864 FiCLis = MIN(FiCLis,FI1D*iDT)
5865 ICLis = MIN(ICLis,I3M1D*iDT)
5866 IF (ICE_RHOS.EQ.1.OR.AGG_SHAPE.EQ.1) THEN
5867 LIM1 = 0.7*(1.-RHOI/RHOI0)
5868 LIM2 = SQRT(1.-LIM1*LIM1)
5869 LIM3 = (1.+2.*ISEPS+ISEPS**2.+ISEPL+2.*ISEPS*ISEPL+ &
5870 ISEPS**2.*ISEPL)/8.
5871 LIM4 = 2.*LIM3*LIM2
5872 LIM5 = LIM3*LIM2**2.
5873 LIM6 = LIM3*LIM2
5874 LIM7 = 2.*LIM3*LIM2**2.
5875 LIM8 = LIM3*LIM2**3.
5876 LIMA = (1.+2.*ISEPL+ISEPL**2.+ISEPS+2.*ISEPL*ISEPS+ &
5877 ISEPL**2.*ISEPS)/8.
5878 LIMB = LIMA*LIM2
5879 LIMC = 2.*LIMA*LIM2
5880 LIMD = 2.*LIMA*LIM2**2.
5881 LIME = LIMA*LIM2**2.
5882 LIMF = LIMA*LIM2**3.
5883 DSS0 = SASR4*GS2
5884 DSL0 = SASR1*GS2
5885 DICC = DI0**(-6.*ZETA)*GI3H1
5886 DICA = GI2HG1/DI0Z3
5887 DIAC = GIH2G1
5888 DIAA = DI0Z3*GI3G1
5889 DIA0 = DI0Z1*GIG1
5890 DIC0 = GIH1/DI0Z2
5891 DIF0 = GIF1/DI0Z1
5892 DIC2 = GI2H1/DI0Z4
5893 DIA2 = DI0Z2*GI2G1
5894 IF ((ADAGR-1.).GE.SLIMIT) THEN
5895 DSLSV = LIMA*GS4+LIMB*DIA0*GS3*SASR2+LIMC*DIC0*GS3* &
5896 SASR3+LIMD*DIF0*GS2*SASR1+LIME*DIC2*GS2* &
5897 SASR4+LIMF*DICA
5898 DSLSF = LIM3*GS4*SASPR+LIM4*DIA0*GS3*SASR3+LIM5*DIA2*&
5899 GS2*SASR1+LIM6*DIC0*GS3*SASR4*SASR4+LIM7* &
5900 DIF0*GS2*SASR4+LIM8*DIAC
5901 VCLis = NCLI1*EIS*VTVIS*NS1D*(GIF1/DI0Z1*GSM1+SASR1* &
5902 GIG1*GSM2*DI0Z1+SASR1*GIH1*GSM2/DI0Z2+SASR2* &
5903 GSM3)/V2M3
5904 SASP2 = MIN(1.,((1.+ISEPS)*(DSS0+LIM2*DIA0))/((1.+ &
5905 ISEPL)*(DSL0+LIM2*DIC0)))
5906 DSLSF = MAX(DSLSF,MAX(DSLSV,GS4)*SASP2)
5907 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
5908 DSLSV = LIMA*GS4+LIMB*GS3*SASR2*DIC0+LIMC*DIA0*GS3* &
5909 SASR3+LIMD*DIF0*GS2*SASR1+LIME*DIA2*GS2* &
5910 SASR4+LIMF*DIAC
5911 DSLSF = LIM3*GS4*SASPR+LIM4*DIC0*GS3*SASR3+LIM5*DIC2*&
5912 GS2*SASR1+LIM6*DIA0*GS3*SASR4*SASR4+LIM7* &
5913 DIF0*GS2*SASR4+LIM8*DICA
5914 VCLis = NCLI1*EIS*VTVIS*NS1D*(GI2G1*DI0Z2*GSM1+SASR1*&
5915 2.*GIG1*GSM2*DI0Z1+SASR2*GSM3)/V2M3
5916 SASP2 = MIN(1.,((1.+ISEPS)*(DSS0+LIM2*DIC0))/((1.+ &
5917 ISEPL)*(DSL0+LIM2*DIA0)))
5918 DSLSF = MAX(DSLSF,MAX(DSLSV,GS4)*SASP2)
5919 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
5920 DSLSV = LIMA*GS4+LIMB*GS3*SASR2*GI2+LIMC*GI2*GS3* &
5921 SASR3+LIMD*GI3*GS2*SASR1+LIME*GI3*GS2*SASR4+ &
5922 LIMF*GI4
5923 DSLSF = LIM3*GS4*SASPR+LIM4*GI2*GS3*SASR3+LIM5*GI3* &
5924 GS2*SASR1+LIM6*GI2*GS3*SASR4*SASR4+LIM7*GI3* &
5925 GS2*SASR4+LIM8*GI4
5926 VCLis = NCLI1*EIS*VTVIS*NS1D*(GI3*GSM1+SASR1*2.*GI2* &
5927 GSM2+SASR2*GSM3)/V2M3
5928 SASP2 = MIN(1.,((1.+ISEPS)*(DSS0+LIM2*GI2))/((1.+ &
5929 ISEPL)*(DSL0+LIM2*GI2)))
5930 DSLSF = MAX(DSLSF,MAX(DSLSV,GS4)*SASP2)
5931 ENDIF
5932 DNSAC = (AMI*GIM1*V2M3+RHOS*GSM1)/MAX(DSLSV,GS4)
5933 DNSAC = MIN(DNSAC,RHOIS)
5934 VsCLis = NCLis*MAX(DSLSV-GS4,0.)/V2M3
5935 FsCLis = NCLis*(DSLSF-GS4*SASPR)
5936 ENDIF
5937 ENDIF
5938 IF (QG1D.GE.QSMALL.AND.QI1D.GE.QSMALL) THEN
5939 ! EIG = MIN(1.,0.01*EXP(0.1*TC1D)) ! FERRIER ET AL., 1995
5940 EIG = 0.
5941 RHOIG = (QI1D+QG1D)/(QI1D/RHOI+QG1D/RHOG+ISMALL)
5942 RATIO = (RHOIG/RHOG)**THRD
5943 MVDX = MAX((MVDI**3.+MVDG**3.)**THRD*RATIO,MVDG)
5944 VTQ0 = VTQG-VTQI
5945 VTN0 = VTNG-VTNI
5946 VTV0 = VTVG-VTVI
5947 VTF0 = VTVG-VTFI
5948 VTQIG = SQRT(VTQ0*VTQ0+0.04*VTQI*VTQG)
5949 VTNIG = SQRT(VTN0*VTN0+0.04*VTNI*VTNG)
5950 VTVIG = SQRT(VTV0*VTV0+0.04*VTVI*VTVG)
5951 VTFIG = SQRT(VTF0*VTF0+0.04*VTFI*VTVG)
5952 IF (AG1D.GE.ASMALL.OR.AI1D.GE.ASMALL) THEN
5953 VTAX = VTAG-VTAI
5954 VTAIG = SQRT(VTAX*VTAX+0.04*VTAI*VTAG)
5955 ENDIF
5956 IF ((ADAGR-1.).GE.SLIMIT) THEN
5957 QCLig = QCLI1*EIG*VTQIG*NG1D*(GIMF1/DI0Z1+GIMG1*GG2* &
5958 DI0Z1+GIMH1*GG2/DI0Z2+GIM1*GG3)
5959 NCLig = NCLI1*EIG*VTNIG*NG1D*(GIF1/DI0Z1+GIG1*GG2*DI0Z1+&
5960 GIH1*GG2/DI0Z2+GG3)
5961 IF (AI1D.GE.ASMALL) THEN
5962 AiCLig = ACLI1*EIG*VTAIG*NG1D*(GIF3/DI0Z1+GIG3*GG2* &
5963 DI0Z1+GIH3*GG2/DI0Z2+GI3*GG3)
5964 ENDIF
5965 IF (AG1D.GE.ASMALL) THEN
5966 AgCLig = (MVDX**2.-MVDG**2.)*NCLI1*EIG*VTAIG*NG1D*( &
5967 GIF1/DI0Z1+GIG1*GG2*DI0Z1+GIH1*GG2/DI0Z2+GG3)
5968 ENDIF
5969 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5970 FCLig = FCLI1*EIG*VTFIG*NG1D*(GIZMF1/DI0Z1+GIZMG1* &
5971 GG2*DI0Z1+GIZMH1*GG2/DI0Z2+GIZM1*GG3)
5972 ICLig = NCLI1*EIG*VTVIG*NG1D*(GIMF1/DI0Z1+GIMG1*GG2* &
5973 DI0Z1+GIMH1*GG2/DI0Z2+GIM1*GG3)
5974 ENDIF
5975 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
5976 QCLig = QCLI1*EIG*VTQIG*NG1D*(GIM2G1*DI0Z2+2.*GIMG1*GG2*&
5977 DI0Z1+GIM1*GG3)
5978 NCLig = NCLI1*EIG*VTNIG*NG1D*(GI2G1*DI0Z2+2.*GIG1*GG2* &
5979 DI0Z1+GG3)
5980 IF (AI1D.GE.ASMALL) THEN
5981 AiCLig = ACLI1*EIG*VTAIG*NG1D*(GI2G3*DI0Z2+2.*GIG3* &
5982 GG2*DI0Z1+GI3*GG3)
5983 ENDIF
5984 IF (AG1D.GE.ASMALL) THEN
5985 AgCLig = (MVDX**2.-MVDG**2.)*NCLI1*EIG*VTAIG*NG1D*( &
5986 GI2G1*DI0Z2+2.*GIG1*GG2*DI0Z1+GG3)
5987 ENDIF
5988 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
5989 FCLig = FCLI1*EIG*VTFIG*NG1D*(GIZM2G1*DI0Z2+2.* &
5990 GIZMG1*GG2*DI0Z1+GIZM1*GG3)
5991 ICLig = NCLI1*EIG*VTVIG*NG1D*(GIM2G1*DI0Z2+2.*GIMG1* &
5992 GG2*DI0Z1+GIM1*GG3)
5993 ENDIF
5994 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
5995 QCLig = QCLI1*EIG*VTQIG*NG1D*(GIM3+2.*GIM2*GG2+GIM1*GG3)
5996 NCLig = NCLI1*EIG*VTNIG*NG1D*(GI3+2.*GI2*GG2+GG3)
5997 IF (AI1D.GE.ASMALL) THEN
5998 AiCLig = ACLI1*EIG*VTAIG*NG1D*(GI5+2.*GI4*GG2+GI3*GG3)
5999 ENDIF
6000 IF (AG1D.GE.ASMALL) THEN
6001 AgCLig = (MVDX**2.-MVDG**2.)*NCLI1*EIG*VTAIG*NG1D*( &
6002 GI3+2.*GI2*GG2+GG3)
6003 ENDIF
6004 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
6005 FCLig = NCLI1*EIG*VTFIG*NG1D*(GIM3+2.*GIM2*GG2+GIM1* &
6006 GG3)
6007 ICLig = NCLI1*EIG*VTVIG*NG1D*(GIM3+2.*GIM2*GG2+GIM1* &
6008 GG3)
6009 ENDIF
6010 ENDIF
6011 QCLig = MIN(QCLig,QI1D*iDT)
6012 NCLig = MIN(NCLig,NI1D*iDT)
6013 AiCLig = MIN(AiCLig,AI1D*iDT)
6014 AgCLig = MIN(AgCLig,AI1D*iDT)
6015 ViCLig = MIN(QCLig*iRHOI,VI1D*iDT)
6016 FCLig = MIN(FCLig,FI1D*iDT)
6017 ICLig = MIN(ICLig,I3M1D*iDT)
6018 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
6019 LIM1 = 0.7*(1.-RHOI/RHOI0)
6020 LIM2 = SQRT(1.-LIM1*LIM1)
6021 LIMA = (1.+2.*ISEPL+ISEPL**2.+ISEPS+2.*ISEPL*ISEPS+ &
6022 ISEPL**2.*ISEPS)/8.
6023 LIMB = LIMA*LIM2
6024 LIMC = 2.*LIMA*LIM2
6025 LIMD = 2.*LIMA*LIM2**2.
6026 LIME = LIMA*LIM2**2.
6027 LIMF = LIMA*LIM2**3.
6028 DICC = DI0**(-6.*ZETA)*GI3H1
6029 DICA = GI2HG1/DI0Z3
6030 DIAC = GIH2G1
6031 DIAA = DI0Z3*GI3G1
6032 DIA0 = DI0Z1*GIG1
6033 DIC0 = GIH1/DI0Z2
6034 DIF0 = GIF1/DI0Z1
6035 DIC2 = GI2H1/DI0Z4
6036 DIA2 = DI0Z2*GI2G1
6037 IF ((ADAGR-1.).GE.SLIMIT) THEN
6038 DGLSV = LIMA*GG4+LIMB*DIA0*GG3+LIMC*DIC0*GG3+LIMD* &
6039 DIF0*GG2+LIME*DIC2*GG2+LIMF*DICA
6040 VCLig = NCLI1*EIG*VTVIG*NG1D*(GIF1/DI0Z1*GGM1+GIG1* &
6041 GGM2*DI0Z1+GIH1*GGM2/DI0Z2+GGM3)/V2M3
6042 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
6043 DGLSV = LIMA*GG4+LIMB*DIC0*GG3+LIMC*DIA0*GG3+LIMD* &
6044 DIF0*GG2+LIME*DIA2*GG2+LIMF*DIAC
6045 VCLig = NCLI1*EIG*VTVIG*NG1D*(GI2G1*DI0Z2*GGM1+2.* &
6046 GIG1*GGM2*DI0Z1+GGM3)/V2M3
6047 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
6048 DGLSV = LIMA*GG4+LIMB*GI2*GG3+LIMC*GI2*GG3+LIMD*GI3* &
6049 GG2+LIME*GI3*GG2+LIMF*GI4
6050 VCLig = NCLI1*EIG*VTVIG*NG1D*(GI3*GGM1+2.*GI2*GGM2+ &
6051 GGM3)/V2M3
6052 ENDIF
6053 DNGAC = (AMI*GIM1*V2M3+RHOG*GG4)/MAX(DGLSV,GG4)
6054 DNGAC = MAX(MIN(DNGAC,RHOIG),RHOIMIN)
6055 VgCLig = MAX(0.,QCLig/DNGAC+(RHOG/DNGAC-1.)*VCLig)
6056 ENDIF
6057 ENDIF
6058 IF (QH1D.GE.QSMALL.AND.QI1D.GE.QSMALL) THEN
6059 RHOIH = (QI1D+QH1D)/(QI1D/RHOI+QH1D/RHOH+ISMALL)
6060 RATIO = (RHOIH/RHOH)**THRD
6061 MVDX = MAX((MVDI**3.+MVDH**3.)**THRD*RATIO,MVDH)
6062 VTQ0 = VTQH-VTQI
6063 VTN0 = VTNH-VTNI
6064 VTV0 = VTQH-VTVI
6065 VTF0 = VTQH-VTFI
6066 VTQIH = SQRT(VTQ0*VTQ0+0.04*VTQI*VTQH)
6067 VTNIH = SQRT(VTN0*VTN0+0.04*VTNI*VTNH)
6068 VTVIH = SQRT(VTV0*VTV0+0.04*VTVI*VTQH)
6069 VTFIH = SQRT(VTF0*VTF0+0.04*VTFI*VTQH)
6070 IF (AH1D.GE.ASMALL.OR.AI1D.GE.ASMALL) THEN
6071 VTAX = VTAH-VTAI
6072 VTAIH = SQRT(VTAX*VTAX+0.04*VTAI*VTAH)
6073 ENDIF
6074 IF ((ADAGR-1.).GE.SLIMIT) THEN
6075 QCLih = QCLI1*EIH*VTQIH*NH1D*(GIMF1/DI0Z1+GIMG1*GH2* &
6076 DI0Z1+GIMH1*GH2/DI0Z2+GIM1*GH3)
6077 NCLih = NCLI1*EIH*VTNIH*NH1D*(GIF1/DI0Z1+GIG1*GH2*DI0Z1+&
6078 GIH1*GH2/DI0Z2+GH3)
6079 IF (AI1D.GE.ASMALL) THEN
6080 AiCLih = ACLI1*EIH*VTAIH*NH1D*(GIF3/DI0Z1+GIG3*GH2* &
6081 DI0Z1+GIH3*GH2/DI0Z2+GI3*GH3)
6082 ENDIF
6083 IF (AH1D.GE.ASMALL) THEN
6084 AhCLih = (MVDX**2.-MVDH**2.)*NCLI1*EIH*VTAIH*NH1D*( &
6085 GIF1/DI0Z1+GIG1*GH2*DI0Z1+GIH1*GH2/DI0Z2+GH3)
6086 ENDIF
6087 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
6088 FCLih = FCLI1*EIH*VTFIH*NH1D*(GIZMF1/DI0Z1+GIZMG1* &
6089 GH2*DI0Z1+GIZMH1*GH2/DI0Z2+GIZM1*GH3)
6090 ICLih = NCLI1*EIH*VTVIH*NH1D*(GIMF1/DI0Z1+GIMG1*GH2* &
6091 DI0Z1+GIMH1*GH2/DI0Z2+GIM1*GH3)
6092 ENDIF
6093 ELSEIF ((1.-ADAGR).GE.SLIMIT) THEN
6094 QCLih = QCLI1*EIH*VTQIH*NH1D*(GIM2G1*DI0Z2+2.*GIMG1*GH2*&
6095 DI0Z1+GIM1*GH3)
6096 NCLih = NCLI1*EIH*VTNIH*NH1D*(GI2G1*DI0Z2+2.*GIG1*GH2* &
6097 DI0Z1+GH3)
6098 IF (AI1D.GE.ASMALL) THEN
6099 AiCLih = ACLI1*EIH*VTAIH*NH1D*(GI2G3*DI0Z2+2.*GIG3* &
6100 GH2*DI0Z1+GI3*GH3)
6101 ENDIF
6102 IF (AH1D.GE.ASMALL) THEN
6103 AhCLih = (MVDX**2.-MVDH**2.)*NCLI1*EIH*VTAIH*NH1D*( &
6104 GI2G1*DI0Z2+2.*GIG1*GH2*DI0Z1+GH3)
6105 ENDIF
6106 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
6107 FCLih = FCLI1*EIH*VTFIH*NH1D*(GIZM2G1*DI0Z2+2.* &
6108 GIZMG1*GH2*DI0Z1+GIZM1*GH3)
6109 ICLih = NCLI1*EIH*VTVIH*NH1D*(GIM2G1*DI0Z2+2.*GIMG1* &
6110 GH2*DI0Z1+GIM1*GH3)
6111 ENDIF
6112 ELSEIF (ABS(ADAGR-1.).LT.SLIMIT) THEN
6113 QCLih = QCLI1*EIH*VTQIH*NH1D*(GIM3+2.*GIM2*GH2+GIM1*GH3)
6114 NCLih = NCLI1*EIH*VTNIH*NH1D*(GI3+2.*GI2*GH2+GH3)
6115 IF (AI1D.GE.ASMALL) THEN
6116 AiCLih = ACLI1*EIH*VTAIH*NH1D*(GI5+2.*GI4*GH2+GI3*GH3)
6117 ENDIF
6118 IF (AH1D.GE.ASMALL) THEN
6119 AhCLih = (MVDX**2.-MVDH**2.)*NCLI1*EIH*VTAIH*NH1D*( &
6120 GI3+2.*GI2*GH2+GH3)
6121 ENDIF
6122 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
6123 FCLih = NCLI1*EIH*VTFIH*NH1D*(GIM3+2.*GIM2*GH2+GIM1* &
6124 GH3)
6125 ICLih = NCLI1*EIH*VTVIH*NH1D*(GIM3+2.*GIM2*GH2+GIM1* &
6126 GH3)
6127 ENDIF
6128 ENDIF
6129 QCLih = MIN(QCLih,QI1D*iDT)
6130 NCLih = MIN(NCLih,NI1D*iDT)
6131 VCLih = MIN(QCLih*iRHOI,VI1D*iDT)
6132 AiCLih = MIN(AiCLih,AI1D*iDT)
6133 AhCLih = MIN(AhCLih,AI1D*iDT)
6134 FCLih = MIN(FCLih,FI1D*iDT)
6135 ICLih = MIN(ICLih,I3M1D*iDT)
6136 ENDIF
6137 IF (QS1D.GE.QSMALL.AND.QG1D.GE.QSMALL) THEN
6138 ! ESG = MIN(1.,0.01*EXP(0.1*TC1D)) ! FERRIER ET AL., 1995
6139 ESG = 0.
6140 RHOSG = (QS1D+QG1D)/(QS1D/RHOS+QG1D/RHOG+ISMALL)
6141 RATIO = (RHOSG/RHOG)**THRD
6142 MVDX = MAX((MVDS**3.+MVDG**3.)**THRD*RATIO,MVDG)
6143 VTQ0 = VTQG-VTQS
6144 VTN0 = VTNG-VTNS
6145 VTV0 = VTVG-VTVS
6146 VTQSG = SQRT(VTQ0*VTQ0+0.04*VTQS*VTQG)
6147 VTNSG = SQRT(VTN0*VTN0+0.04*VTNS*VTNG)
6148 VTVSG = SQRT(VTV0*VTV0+0.04*VTVS*VTVG)
6149 IF (AS1D.GE.ASMALL.OR.AG1D.GE.ASMALL) THEN
6150 VTAX = VTAG-VTAS
6151 VTASG = SQRT(VTAX*VTAX+0.04*VTAS*VTAG)
6152 ENDIF
6153 QCLsg = QCLS1*ESG*VTQSG*NG1D*(SASR2*GSM3+SASR1*2.*GG2*GSM2+&
6154 GSM1*GG3)
6155 NCLsg = NCLS1*ESG*VTNSG*NG1D*(SASR2*GS3+SASR1*2.*GS2*GG2+ &
6156 GG3)
6157 QCLsg = MIN(QCLsg,QS1D*iDT)
6158 NCLsg = MIN(NCLsg,NS1D*iDT)
6159 IF (ICE_RHOS.EQ.1) THEN
6160 VsCLsg = MIN(QCLsg*iRHOS,VS1D*iDT)
6161 ENDIF
6162 IF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
6163 LIM1 = 0.7*(1.-RHOS/RHOI0)
6164 LIM2 = SQRT(1.-LIM1*LIM1)
6165 LIMA = (1.+2.*ISEPL+ISEPL**2.+ISEPS+2.*ISEPL*ISEPS+ &
6166 ISEPL**2.*ISEPS)/8.
6167 LIMB = LIMA*LIM2
6168 LIMC = 2.*LIMA*LIM2
6169 LIMD = 2.*LIMA*LIM2**2.
6170 LIME = LIMA*LIM2**2.
6171 LIMF = LIMA*LIM2**3.
6172 DGLSV = LIMA*GG4+(LIMB+LIMC)*GG3*GS2+(LIMD+LIME)*GG2* &
6173 GS3+LIMF*GS4
6174 DNGAC = (AMS*GSM1+AMG*GGM1)*V2M3/MAX(DGLSV,GG4)
6175 DNGAC = MAX(MIN(DNGAC,RHOSG),RHOIMIN)
6176 VCLsg = NCLS1*ESG*VTVSG*NG1D*(SASR2*GS3*GGM1+SASR1*2.* &
6177 GS2*GGM2+GGM3)
6178 VgCLsg = MAX(0.,QCLsg/DNGAC+(RHOG/DNGAC-1.)*VCLsg)
6179 ENDIF
6180 IF (AGG_SHAPE.EQ.1) THEN
6181 FCLsg = MIN(QCLsg*iRHOS*SASPR*V2M3,FS1D*iDT)
6182 ENDIF
6183 IF (AS1D.GE.ASMALL) THEN
6184 AsCLsg = ACLS1*ESG*VTASG*NG1D*(SASR2*GS5+SASR1*2.*GG2* &
6185 GS4+GG3*GS3)
6186 AsCLsg = MIN(AsCLsg,AS1D*iDT)
6187 ENDIF
6188 IF (AG1D.GE.ASMALL) THEN
6189 AgCLsg = (MVDX**2.-MVDG**2.)*NCLS1*ESG*VTASG*NG1D*( &
6190 SASR2*GS3+SASR1*2.*GS2*GG2+GG3)
6191 ENDIF
6192 ENDIF
6193 IF (QH1D.GE.QSMALL.AND.QS1D.GE.QSMALL) THEN
6194 RHOSH = (QS1D+QH1D)/(QS1D/RHOS+QH1D/RHOH+ISMALL)
6195 RATIO = (RHOSH/RHOH)**THRD
6196 MVDX = MAX((MVDS**3.+MVDH**3.)**THRD*RATIO,MVDH)
6197 VTQ0 = VTQH-VTQS
6198 VTN0 = VTNH-VTNS
6199 VTQSH = SQRT(VTQ0*VTQ0+0.04*VTQS*VTQH)
6200 VTNSH = SQRT(VTN0*VTN0+0.04*VTNS*VTNH)
6201 IF (AH1D.GE.ASMALL.OR.AS1D.GE.ASMALL) THEN
6202 VTAX = VTAH-VTAS
6203 VTASH = SQRT(VTAX*VTAX+0.04*VTAS*VTAH)
6204 ENDIF
6205 QCLsh = QCLS1*ESH*VTQSH*NH1D*(SASR2*GSM3+SASR1*2.*GH2*GSM2+&
6206 GH3*GSM1)
6207 NCLsh = NCLS1*ESH*VTNSH*NH1D*(SASR2*GS3 +SASR1*2.*GH2*GS2+ &
6208 GH3)
6209 QCLsh = MIN(QCLsh,QS1D*iDT)
6210 NCLsh = MIN(NCLsh,NS1D*iDT)
6211 IF (ICE_RHOS.EQ.1) THEN
6212 VCLsh = MIN(QCLsh*iRHOS,VS1D*iDT)
6213 ENDIF
6214 IF (AGG_SHAPE.EQ.1) THEN
6215 FCLsh = MIN(QCLsh*iRHOS*SASPR*V2M3,FS1D*iDT)
6216 ENDIF
6217 IF (AS1D.GE.ASMALL) THEN
6218 AsCLsh = ACLS1*ESH*VTASH*NH1D*(SASR2*GS5+SASR1*2.*GH2* &
6219 GS4+GH3*GS3)
6220 AsCLsh = MIN(AsCLsh,AS1D*iDT)
6221 ENDIF
6222 IF (AH1D.GE.ASMALL) THEN
6223 AhCLsh = (MVDX**2.-MVDH**2.)*NCLS1*ESH*VTASH*NH1D*( &
6224 SASR2*GS3 +SASR1*2.*GH2*GS2+GH3)
6225 ENDIF
6226 ENDIF
6227 IF (QS1D.GE.QSMALL.AND.MVDS.GE.2.E-4) THEN
6228 ESS1 = 0.1*MIN(1.,0.05*EXP(0.1*TC1D)) ! FERRIER ET AL., 1995
6229 IF (ICE_RHOS.NE.0) THEN
6230 ESS2 = 1.-RHOS/RHOI0
6231 ELSE
6232 ESS2 = 0.
6233 ENDIF
6234 ! ESS = MIN(MAX(ESS1,ESS2,0.),1.)
6235 ESS = ESS1
6236 QCLss = 2.*PI*XISP*VTQS*ESS*SASR2/3.*NS1D**2.*GSM3*AMS
6237 NCLss = -2.*PI*XISP*VTNS*ESS*SASR2/3.*NS1D**2.*GS3
6238 IF (ICE_RHOS.EQ.1.OR.AGG_SHAPE.EQ.1) THEN
6239 LIM1 = 0.7*(1.-RHOS/RHOI0)
6240 LIM2 = SQRT(1.-LIM1*LIM1)
6241 LIM3 = (1.+2.*ISEPS+ISEPS**2.+ISEPL+2.*ISEPS*ISEPL+ &
6242 ISEPS**2.*ISEPL)/8.
6243 LIM4 = 2.*LIM3*LIM2
6244 LIM5 = LIM3*LIM2**2.
6245 LIM6 = LIM3*LIM2
6246 LIM7 = 2.*LIM3*LIM2**2.
6247 LIM8 = LIM3*LIM2**3.
6248 LIMA = (1.+2.*ISEPL+ISEPL**2.+ISEPS+2.*ISEPL*ISEPS+ &
6249 ISEPL**2.*ISEPS)/8.
6250 LIMB = LIMA*LIM2
6251 LIMC = 2.*LIMA*LIM2
6252 LIMD = 2.*LIMA*LIM2**2.
6253 LIME = LIMA*LIM2**2.
6254 LIMF = LIMA*LIM2**3.
6255 DSLSV = (LIMA+LIMB+LIMC+LIMD+LIME+LIMF)*GS4
6256 DSLSF = (LIM3+LIM4+LIM5+LIM6+LIM7+LIM8)*GS4*SASPR
6257 SASP3 = MIN((1.+LIM2+ISEPS+ISEPS*LIM2)*SASR4,(1.+LIM2+ &
6258 ISEPL+ISEPL*LIM2)*SASR1)/MAX((1.+LIM2+ISEPS+ &
6259 ISEPS*LIM2)*SASR4,(1.+LIM2+ISEPL+ISEPL*LIM2)* &
6260 SASR1)
6261 DNSAG = MAX(RHOIMIN,2.*RHOS*GSM1/DSLSV)
6262 VCLss = 2.*QCLss*MAX(1./DNSAG-iRHOS,0.)
6263 FCLss = 2.*QCLss*V2M3*MAX(SASP3/DNSAG-SASPR*iRHOS,0.)
6264 RATIO = (RHOS/DNSAG)**THRD
6265 ELSE
6266 RATIO = 1.
6267 ENDIF
6268 IF (AS1D.GE.ASMALL) THEN
6269 ACLss = 2.*PI*XISP*VTAS*ESS*SASR2/3.*NS1D**2.*GS5*( &
6270 1.5874*RATIO**2.-2.)
6271 IF (ACLss.LT.0.) THEN
6272 ACLss1 = MIN(ACLss,0.)
6273 ACLss1 = MAX(ACLss1,-1.*AS1D*iDT)
6274 ACLss = 0.
6275 ENDIF
6276 ENDIF
6277 ENDIF
6278 ELSE ! WARM CLOUD START
6279 IF ((HCwqv+HRwqv+HSwqv+HGwqv+HHwqv).GE.QSMALL) THEN
6280 VDMAX = XXLV*(QV1D-QVSW0)/(1.+XXLV**2.*QV1D/(CPM*RV*TK1D** &
6281 2.))*iDT
6282 SUMCND = HCwqv+HRwqv+HSwqv+HGwqv+HHwqv
6283 IF (SUMCND.GT.VDMAX.AND.VDMAX.GE.QSMALL) THEN
6284 RATIO = MIN(1.,VDMAX/(SUMCND+QSMALL))
6285 HCwqv = HCwqv*RATIO
6286 HRwqv = HRwqv*RATIO
6287 HSwqv = HSwqv*RATIO
6288 HGwqv = HGwqv*RATIO
6289 HHwqv = HHwqv*RATIO
6290 ENDIF
6291 ENDIF
6292 IF ((HCwqv+HRwqv+HSwqv+HGwqv+HHwqv).LT.0.) THEN
6293 EVMAX = XXLV*(QV1D-QVSW0)/(1.+XXLV**2.*QV1D/(CPM*RV*TK1D** &
6294 2.))*iDT
6295 SUMEVP = HCwqv+HRwqv+HSwqv+HGwqv+HHwqv
6296 IF (EVMAX.LT.0..AND.SUMEVP.LT.EVMAX*0.9999) THEN
6297 HCwqv = HCwqv*MIN(1.,0.9999*EVMAX/SUMEVP)
6298 HRwqv = HRwqv*MIN(1.,0.9999*EVMAX/SUMEVP)
6299 HSwqv = HSwqv*MIN(1.,0.9999*EVMAX/SUMEVP)
6300 HGwqv = HGwqv*MIN(1.,0.9999*EVMAX/SUMEVP)
6301 HHwqv = HHwqv*MIN(1.,0.9999*EVMAX/SUMEVP)
6302 ENDIF
6303 ENDIF
6304 !----------------- MELTING PROXESSES -----------------------------------
6305 IF (QI1D.GE.QSMALL) THEN
6306 IF (MVDI.GT.DCR) THEN
6307 QMLir = -1.*QI1D*iDT
6308 VMLir = -1.*VI1D*iDT
6309 IF (AI1D.GE.ASMALL) THEN
6310 AMLir = -1.*AI1D*iDT
6311 ENDIF
6312 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
6313 FMLir = -1.*FI1D*iDT
6314 IMLir = -1.*I3M1D*iDT
6315 ENDIF
6316 ELSE
6317 QMLic = -1.*QI1D*iDT
6318 VMLic = -1.*VI1D*iDT
6319 IF (AI1D.GE.ASMALL) THEN
6320 AMLic = -1.*AI1D*iDT
6321 ENDIF
6322 IF (I3M1D.GE.ISMALL.AND.FI1D.GE.ISMALL) THEN
6323 FMLic = -1.*FI1D*iDT
6324 IMLic = -1.*I3M1D*iDT
6325 ENDIF
6326 ENDIF
6327 NMLir = MIN(QMLir*NI1D/QI1D,0.)
6328 NMLic = MIN(QMLic*NI1D/QI1D,0.)
6329 ENDIF
6330 IF (QS1D.GE.QSMALL) THEN
6331 RMcsq = 0.
6332 RMrsq = 0.
6333 RMcsa = 0.
6334 RMrsa = 0.
6335 IF (QC1D.GE.QSMALL) THEN
6336 ECS = 1.
6337 VTQ0 = VTQS-VTQC
6338 VTQSC = SQRT(VTQ0*VTQ0+4.E-2*VTQS*VTQC)
6339 RMcsq = QRMC1*ECS*VTQSC*NS1D*(GS3*GC4+2.*GS2*GC5+GC6)
6340 RMcsq = MIN(RMcsq,QC1D*iDT)
6341 IF (AS1D.GE.ASMALL) THEN
6342 MVDX = MAX((MVDC**3.+MVDS**3.)**THRD,MVDS)
6343 RMcsa = (MVDX**2.-MVDS**2.)*NRMC1*VTQSC*NS1D*(GS3+ &
6344 2.*GS2*GC2+GC3)
6345 RMcsa = MAX(0.,MIN(RMcsa,QC1D*iDT*iAPW/MVDC))
6346 ENDIF
6347 ENDIF
6348 IF (QR1D.GE.QSMALL) THEN
6349 ERS = 1.
6350 VTQ0 = VTQR-VTQS
6351 VTQRS = SQRT(VTQ0*VTQ0+4.E-2*VTQR*VTQS)
6352 RMrsq = QRMR1*ERS*VTQRS*NS1D*(GS3*GR4+2.*GS2*GR5+GR6)
6353 RMrsq = MIN(RMrsq,QR1D*iDT)
6354 IF (AS1D.GE.ASMALL) THEN
6355 MVDX = MAX((MVDR**3.+MVDS**3.)**THRD,MVDS)
6356 RMrsa = (MVDX**2.-MVDS**2.)*NRMR1*VTQRS*NS1D*(GS3+ &
6357 2.*GS2*GR2+GR3)
6358 RMrsa = MAX(0.,MIN(RMrsa,QR1D*iDT*iAPW/MVDR))
6359 ENDIF
6360 ENDIF
6361 MLMAX = 1.-MIN(1.,RHOS/RHOIMAX)
6362 HSwcd = 2.*PI*NS1D*KAP*VENQS*(TK0C-TK1D)
6363 HSwrm = CPW*(TK0C-TK1D)*(RMrsq+RMcsq)
6364 SMLF = MAX(0.,-1.*(HSwcd+HSwqv+HSwrm)*DT/XXLF0)/QS1D
6365 IF (SMLF.LT.MLIMIT) THEN
6366 SMLF = 0.
6367 SMLR = 0.
6368 ELSE
6369 SMLF = MIN(MLMAX,MAX(0.,SMLF))
6370 SMLR = 0.01195*EXP(4.411*SMLF)
6371 ENDIF
6372 AVWSG = SMLR*AVRH+(1.-SMLR)*AVSG
6373 BVWSG = SMLR*BVRH+(1.-SMLR)*BVSG
6374 RHOWS = SMLF*RHOW+(1.-SMLF)*RHOS
6375 IF (ICE_VTS.EQ.1.OR.ICE_VTS.EQ.2) THEN
6376 IF (SMLF.GE.MLIMIT) THEN
6377 KINV = (1.72E-5*(393./(TK1D+120.))*(TK1D/TK0C)** &
6378 1.5)/RHO
6379 BEST0 = 2.*G*NS1D/(KINV**2.)
6380 BEST = 2.*BEST0*RHOWS*EXP(GAMLN(BMS+AFAS+1.)-GAMLN( &
6381 AFAS+1.)-BMS*LOG(LAMS))/3.
6382 C1X2 = VTC1*BEST**5.E-1
6383 VTB1 = C1X2/(1.+C1X2)**5.E-1/((1.+C1X2)**5.E-1-1.)/2.
6384 VTA1 = VTC2*((1+C1X2)**5.E-1-1.)**2./BEST**VTB1
6385 AVS = VTA1*KINV**(1.-2.*VTB1)*(4.*RHOWS*G/3.)**VTB1
6386 BVS = VTB1*BMS-1.
6387 ELSE
6388 AVS = AVS
6389 BVS = BVS
6390 ENDIF
6391 ENDIF
6392 BSTMP = SCN*SQRT(AVS*RHOAJ/MUA)
6393 QTMP1 = LLMS*(1.5+BVS/2.)
6394 QTMP2 = EXP(GAMLN(AFAS+2.)-GAMLN(AFAS+1.)-LLMS)
6395 QTMP3 = EXP(GAMLN(BVS/2.+AFAS+2.5)-GAMLN(AFAS+1.)-QTMP1)
6396 IF (AGG_SHAPE.EQ.0) THEN
6397 WSAPR = 1.
6398 ELSEIF (AGG_SHAPE.EQ.1) THEN
6399 DSMM = MVDS*1.E3
6400 WSAPR = SMLF*(0.9951+2.51E-2*DSMM-3.644E-2*DSMM**2.+5.303E-3*&
6401 DSMM**3.-2.492E-4*DSMM**4.)+(1.-SMLF)*SASPR
6402 ENDIF
6403 CAPWS = ZP1*WSAPR**(ZP2/3.)+ZP3*WSAPR**(ZP4/3.)
6404 VENWS = AVWSG*QTMP2*CAPWS+BVWSG*BSTMP*QTMP3*CAPWS
6405 SMLTQ = CPW/XXLF*(TK0C-TK1D)*(RMcsq+RMrsq)
6406 QMLsr = 2.*PI*NS1D*KAP*(TK0C-TK1D)/XXLF*VENWS+SMLTQ ! NEGATIVE
6407 QMLsr = MAX(MIN(QMLsr,0.),-1.*QS1D*iDT)
6408 NMLsr = MIN(QMLsr*NS1D/QS1D,0.)
6409 IF (ICE_RHOS.EQ.1) THEN
6410 VMLsr = ((QS1D+QMLsr*DT)/RHOWS-VS1D)*iDT
6411 VMLsr = MAX(VMLsr,-1.*VS1D*iDT)
6412 ENDIF
6413 IF (AGG_SHAPE.EQ.1) THEN
6414 FMLsr = MAX((-1.*FS1D+WSAPR*(QS1D/RHOWS*V2M3+QMLsr/ &
6415 RHOWS*V2M3*DT))*iDT,-1.*FS1D*iDT)
6416 ENDIF
6417 IF (AS1D.GE.ASMALL) THEN
6418 ATMP1 = LOG(LAMS)*(0.5+BVS/2.)
6419 ATMP2 = EXP(GAMLN(BVS/2.+AFAS+1.5)-GAMLN(AFAS+1.)-ATMP1)
6420 VENAS = AVWSG*CAPWS+BVWSG*BSTMP*ATMP2*CAPWS
6421 SMLTA = CPW/XXLF*(TK0C-TK1D)*(RMcsa+RMrsa)
6422 AMLsr = 8.*NS1D*KAP*(TK0C-TK1D)/XXLF/RHOWS*VENAS+SMLTA
6423 AMLsr = MAX(MIN(AMLsr,0.),-1.*AS1D*iDT)
6424 ENDIF
6425 ENDIF
6426 IF (QG1D.GE.QSMALL) THEN
6427 RMcgq = 0.
6428 RMrgq = 0.
6429 RMcga = 0.
6430 RMrga = 0.
6431 IF (QC1D.GE.QSMALL) THEN
6432 ECG = 1.
6433 VTQ0 = VTQG-VTQC
6434 VTQGC = SQRT(VTQ0*VTQ0+0.04*VTQG*VTQC)
6435 RMcgq = QRMC1*ECG*VTQGC*NG1D*(GG3*GC4+2.*GG2*GC5+GC6)
6436 RMcgq = MIN(RMcgq,QC1D*iDT)
6437 IF (AG1D.GE.ASMALL) THEN
6438 MVDX = MAX((MVDC**3.+MVDG**3.)**THRD,MVDG)
6439 RMcga = (MVDX**2.-MVDG**2.)*NRMC1*VTQGC*NG1D*(GG3+ &
6440 2.*GG2*GR2+GR3)
6441 RMcga = MAX(0.,MIN(RMcga,QC1D*iDT*iAPW/MVDC))
6442 ENDIF
6443 ENDIF
6444 IF (QR1D.GE.QSMALL) THEN
6445 ERG = 1.
6446 VTQ0 = VTQR-VTQG
6447 VTQRG = SQRT(VTQ0*VTQ0+0.04*VTQR*VTQG)
6448 RMrgq = QRMR1*ERG*VTQRG*NG1D*(GG3*GR4+2.*GG2*GR5+GR6)
6449 RMrgq = MIN(RMrgq,QR1D*iDT)
6450 IF (AG1D.GE.ASMALL) THEN
6451 MVDX = MAX((MVDR**3.+MVDG**3.)**THRD,MVDG)
6452 RMrga = (MVDX**2.-MVDG**2.)*NRMR1*VTQRG*NG1D*(GG3+ &
6453 2.*GG2*GR2+GR3)
6454 RMrga = MAX(0.,MIN(RMrga,QR1D*iDT*iAPW/MVDR))
6455 ENDIF
6456 ENDIF
6457 MLMAX = 1.-MIN(1.,RHOG/RHOIMAX)
6458 HGwcd = 2.*PI*NG1D*KAP*VENQG*(TK0C-TK1D)
6459 HGwrm = CPW*(TK0C-TK1D)*(RMrgq+RMcgq)
6460 GMLF = MAX(0.,-1.*(HGwcd+HGwqv+HGwrm)*DT/XXLF0)/QG1D
6461 IF (GMLF.LT.MLIMIT) THEN
6462 GMLF = 0.
6463 GMLR = 0.
6464 ELSE
6465 GMLF = MIN(MLMAX,MAX(0.,GMLF))
6466 GMLR = 0.01195*EXP(4.411*GMLF)
6467 ENDIF
6468 AVWSG = GMLR*AVRH+(1.-GMLR)*AVSG
6469 BVWSG = GMLR*BVRH+(1.-GMLR)*BVSG
6470 RHOWG = GMLF*RHOW+(1.-GMLF)*RHOG
6471 IF (ICE_VTG.EQ.1) THEN
6472 KINV = (1.72E-5*(393./(TK1D+120.))*(TK1D/TK0C)**1.5)/RHO
6473 BEST0 = 2.*G*NG1D/(KINV**2.)
6474 BEST = 2.*BEST0*RHOWG*EXP(GAMLN(BMG+AFAG+1.)-GAMLN( &
6475 AFAG+1.)-BMG*LOG(LAMG))/3.
6476 C1X2 = VTC1*BEST**5.E-1
6477 VTB1 = C1X2/(1.+C1X2)**5.E-1/((1.+C1X2)**5.E-1-1.)/2.
6478 VTA1 = VTC2*((1+C1X2)**5.E-1-1.)**2./BEST**VTB1
6479 AVG = VTA1*KINV**(1.-2.*VTB1)*(4.*RHOWG*G/3.)**VTB1
6480 BVG = VTB1*BMG-1.
6481 ENDIF
6482 BGTMP = SCN*SQRT(AVG*RHOAJ/MUA)
6483 QTMP1 = LLMG*(1.5+BVG/2.)
6484 QTMP2 = EXP(GAMLN(AFAG+2.)-GAMLN(AFAG+1.)-LLMG)
6485 QTMP3 = EXP(GAMLN(BVG/2.+AFAG+2.5)-GAMLN(AFAG+1.)-QTMP1)
6486 VENWG = AVWSG*QTMP2+BVWSG*BGTMP*QTMP3
6487 GMLTQ = CPW/XXLF*(TK0C-TK1D)*(RMcgq+RMrgq)
6488 QMLgr = 2.*PI*NG1D*KAP*(TK0C-TK1D)/XXLF*VENWG+GMLTQ ! NEGATIVE
6489 QMLgr = MAX(MIN(QMLgr,0.),-1.*QG1D*iDT)
6490 NMLgr = MIN(QMLgr*NG1D/QG1D,0.)
6491 VMLgr = MAX(((QG1D+QMLgr*DT)/RHOWG-VG1D)*iDT,-1.*VG1D*iDT)
6492 IF (AG1D.GE.ASMALL) THEN
6493 ATMP1 = LOG(LAMG)*(0.5+BVG/2.)
6494 ATMP2 = EXP(GAMLN(BVG/2.+AFAG+1.5)-GAMLN(AFAG+1.)-ATMP1)
6495 VENAG = AVWSG+BVWSG*BGTMP*ATMP2
6496 GMLTA = CPW/XXLF*(TK0C-TK1D)*(RMcga+RMrga)
6497 AMLgr = 8.*NG1D*KAP*(TK0C-TK1D)/XXLF/RHOWG*VENAG+GMLTA ! NEGATIVE
6498 AMLgr = MAX(MIN(AMLgr,0.),-1.*AG1D*iDT)
6499 ENDIF
6500 ENDIF
6501 IF (QH1D.GE.QSMALL) THEN
6502 RMchq = 0.
6503 RMrhq = 0.
6504 RMcha = 0.
6505 RMrha = 0.
6506 IF (QC1D.GE.QSMALL) THEN
6507 ECH = 1.
6508 VTQ0 = VTQH-VTQC
6509 VTQHC = SQRT(VTQ0*VTQ0+0.04*VTQH*VTQC)
6510 RMchq = QRMC1*ECH*VTQHC*NH1D*(GH3*GC4+2.*GH2*GC5+GC6)
6511 RMchq = MIN(RMchq,QC1D*iDT)
6512 IF (AH1D.GE.ASMALL) THEN
6513 MVDX = MAX((MVDC**3.+MVDH**3.)**THRD,MVDH)
6514 RMcha = (MVDX**2.-MVDH**2.)*NRMC1*VTQHC*NH1D*(GH3+ &
6515 2.*GH2*GR2+GR3)
6516 RMcha = MAX(0.,MIN(RMcha,QC1D*iDT*iAPW/MVDC))
6517 ENDIF
6518 ENDIF
6519 IF (QR1D.GE.QSMALL) THEN
6520 ERH = 1.
6521 VTQ0 = VTQH-VTQR
6522 VTQRH = SQRT(VTQ0*VTQ0+0.04*VTQH*VTQR)
6523 RMrhq = QRMR1*ERH*VTQRH*NH1D*(GH3*GR4+2.*GH2*GR5+GR6)
6524 RMrhq = MIN(RMrhq,QR1D*iDT)
6525 IF (AH1D.GE.ASMALL) THEN
6526 MVDX = MAX((MVDR**3.+MVDH**3.)**THRD,MVDH)
6527 RMrha = (MVDX**2.-MVDH**2.)*NRMR1*VTQRH*NH1D*(GH3+ &
6528 2.*GH2*GR2+GR3)
6529 RMrha = MAX(0.,MIN(RMrha,QR1D*iDT*iAPW/MVDR))
6530 ENDIF
6531 ENDIF
6532 HMLTQ = CPW/XXLF*(TK0C-TK1D)*(RMrhq+RMchq)
6533 QMLhr = 2.*PI*NH1D*KAP*(TK0C-TK1D)/XXLF*VENQH+HMLTQ ! NEGATIVE
6534 QMLhr = MAX(MIN(QMLhr,0.),-1.*QH1D*iDT)
6535 NMLhr = MIN(QMLhr*NH1D/QH1D,0.)
6536 IF (AH1D.GE.ASMALL) THEN
6537 HMLTA = CPW/XXLF*(TK0C-TK1D)*(RMrha+RMcha)
6538 AMLhr = 8.*NH1D*KAP*(TK0C-TK1D)/XXLF/RHOH*VENAH+HMLTA ! NEGATIVE
6539 AMLhr = MAX(MIN(AMLhr,0.),-1.*AH1D*iDT)
6540 ENDIF
6541 ENDIF
6542 ENDIF ! TEMPERATURE LOOPS
6543 !----------------- HAILSTONE GROWTH HEATBALANCE ------------------------
6544 IF (HWET_MODE.EQ.1) THEN
6545 DMWDT = QRMch+QRMrh
6546 DMIDT = QCLih+QCLsh
6547 IF (QH1D.GE.QLIMIT.AND.DMWDT.GE.QSMALL) THEN
6548 HHdcd = 2.*PI*NH1D*KAP*VENQH*(TK1D-TK0C)
6549 HHdrm = DMWDT*(XXLF+CPW*(TK1D-TK0C))
6550 HHdcl = DMIDT*CPI*(TK1D-TK0C)
6551 HHdtt = HHdcd+HHdqv+HHdrm+HHdcl
6552 IF (HHdtt.GT.0.) THEN ! WET-GROWTH MODE
6553 QCLih = QCLih/EIH; NCLih = NCLih/EIH; VCLih = VCLih/EIH
6554 FCLih = FCLih/EIH; ICLih = ICLih/EIH
6555 QCLsh = QCLsh/ESH; NCLsh = NCLsh/ESH; VCLsh = VCLsh/ESH
6556 AiCLih = AiCLih/EIH; AhCLih = AhCLih/EIH
6557 AsCLsh = AsCLsh/ESH; AhCLsh = AhCLsh/ESH
6558 MCORE = (QH1D*iDT+QCLih+QCLsh)
6559 HHwcd = 2.*PI*NH1D*KAP*VENQH*(TK0C-TK1D)
6560 HHwrm = CPW*(TK0C-TK1D)*DMWDT
6561 MLWM = MAX(0.,-1.*(HHwcd+HHwqv+HHwrm)*DT/XXLF0)
6562 HMLF = MIN(0.9,MAX(0.,MLWM/QH1D))
6563 IF (MLWM.GT.DMWDT) THEN
6564 QHwml = MAX(-1.*MCORE,DMWDT-MLWM)
6565 AHwml = QHwml*4.*iRHOH/PI/MVDH
6566 ENDIF
6567 MLWC = 0.268+0.1389*MCORE*1.E3
6568 IF ((MLWM*1.E3).GT.MLWC) THEN
6569 DH9 = MVDH*1.E2-9.E-1
6570 MWT = (QH1D*iDT+QCLih+QCLsh+DMWDT)*1.E3
6571 ICOR1 = MWT/(1.+10.67*DH9-10.81*DH9**2.+10.26*DH9**3.)
6572 QHwsh = MAX(0.,MLWM-MAX(0.,ICOR1*1.E-3))
6573 NHwsh = QHwsh/(AMW*DSHED**BMW)
6574 ENDIF
6575 ELSE ! DRY-GROWTH MODE
6576 QHdrm = DMWDT
6577 AHdrm = ARMch+ARMrh
6578 ENDIF
6579 ENDIF
6580 ELSEIF (HWET_MODE.EQ.0) THEN
6581 QHdrm = QRMch+QRMrh
6582 AHdrm = ARMch+ARMrh
6583 ENDIF ! HAILSTONE WET GROWTH MODE OPTION
6584 !----------------- CONSERVATION OF HYDROMETEORS ------------------------
6585 QCSOUR = QC1D+(QBKrc-QMLic)*DT
6586 QCSINK = (QHOci+QNMci+QNCci+QRMci+QRMcs+QRMcg+QRMch+QCLcr+QCNcr+ &
6587 QIMcsi+QIMcgi)*DT
6588 IF (QCSINK.GT.QCSOUR.AND.QCSOUR.GE.QSMALL) THEN
6589 RATIO = MIN(1.,QCSOUR/(QCSINK+QSMALL))
6590 QHOci = QHOci*RATIO; QNMci = QNMci*RATIO; QNCci = QNCci*RATIO
6591 QRMci = QRMci*RATIO; QRMcs = QRMcs*RATIO; QRMcg = QRMcg*RATIO
6592 QRMch = QRMch*RATIO; QCLcr = QCLcr*RATIO; QCNcr = QCNcr*RATIO
6593 QIMcsi = QIMcsi*RATIO; QIMcgi = QIMcgi*RATIO
6594 ENDIF
6595 NCSOUR = NC1D+(NBKrc-NMLic)*DT
6596 NCSINK = (NHOci+NNMci+NNCci+NRMci+NRMcs+NRMcg+NRMch+NCLcr+NCLcc+ &
6597 NCNcr+NIMcsi+NIMcgi)*DT
6598 IF (NCSINK.GT.NCSOUR.AND.NCSOUR.GE.NSMALL) THEN
6599 RATIO = MIN(1.,NCSOUR/(NCSINK+NSMALL))
6600 NHOci = NHOci*RATIO; NNMci = NNMci*RATIO; NNCci = NNCci*RATIO
6601 NRMci = NRMci*RATIO; NRMcs = NRMcs*RATIO; NRMcg = NRMcg*RATIO
6602 NRMch = NRMch*RATIO; NCLcr = NCLcr*RATIO; NCLcc = NCLcc*RATIO
6603 NCNcr = NCNcr*RATIO; NIMcsi = NIMcsi*RATIO
6604 NIMcgi = NIMcgi*RATIO
6605 ENDIF
6606 QRSOUR = QR1D+(QCLcr+QCNcr-QMLir-QMLsr-QMLgr-QMLhr+QHwsh-QHwml)*DT
6607 QRSINK = (QHOrg+QNMrg+QRMri+QRMrs+QRMrg+QRMrh+QBKrc+QIMrsi+ &
6608 QIMrgi)*DT
6609 IF (QRSINK.GT.QRSOUR.AND.QRSOUR.GE.QSMALL) THEN
6610 RATIO = MIN(1.,QRSOUR/(QRSINK+QSMALL))
6611 QHOrg = QHOrg*RATIO; QNMrg = QNMrg*RATIO; QRMri = QRMri*RATIO
6612 QRMrs = QRMrs*RATIO; QRMrg = QRMrg*RATIO; QRMrh = QRMrh*RATIO
6613 QBKrc = QBKrc*RATIO; QIMrsi = QIMrsi*RATIO
6614 QIMrgi = QIMrgi*RATIO
6615 ENDIF
6616 NRSOUR = NR1D+(NCNcr+NBKrr-NMLir-NMLsr-NMLgr-NMLhr+NCLcr+NHwsh)*DT
6617 NRSINK = (NHOrg+NNMrg+NRMri+NRMrs+NRMrg+NRMrh+NCLrr+NBKrc+NIMrsi+&
6618 NIMrgi)*DT
6619 IF (NRSINK.GT.NRSOUR.AND.NRSOUR.GE.NSMALL) THEN
6620 RATIO = MIN(1.,NRSOUR/(NRSINK+NSMALL))
6621 NHOrg = NHOrg*RATIO; NNMrg = NNMrg*RATIO; NRMri = NRMri*RATIO
6622 NRMrs = NRMrs*RATIO; NRMrg = NRMrg*RATIO; NRMrh = NRMrh*RATIO
6623 NCLrr = NCLrr*RATIO; NBKrc = NBKrc*RATIO; NIMrsi = NIMrsi*RATIO
6624 NIMrgi = NIMrgi*RATIO
6625 ENDIF
6626 QISOUR = QI1D+(QIMcsi+QIMcgi+QIMrsi+QIMrgi+QHOci+QNMci+QNCci+ &
6627 QRMci)*DT
6628 QISINK = (-QMLir-QMLic+QCLir+QCLis+QCLig+QCLih+QINig+QCNis)*DT
6629 IF (QISINK.GT.QISOUR.AND.QISOUR.GE.QSMALL) THEN
6630 RATIO = MIN(1.,QISOUR/(QISINK+QSMALL))
6631 QMLir = QMLir*RATIO; QMLic = QMLic*RATIO; QCLir = QCLir*RATIO
6632 QCLis = QCLis*RATIO; QCLig = QCLig*RATIO; QCLih = QCLih*RATIO
6633 QINig = QINig*RATIO; QCNis = QCNis*RATIO
6634 ENDIF
6635 NISOUR = NI1D+(NIMcsi+NIMcgi+NIMrsi+NIMrgi+NHOci+NNMci+NNCci)*DT
6636 NISINK = (-NMLir-NMLic+NCLir+NCLis+NCLig+NCLih+NINig+NiCNis)*DT
6637 IF (NISINK.GT.NISOUR.AND.NISOUR.GE.NSMALL) THEN
6638 RATIO = MIN(1.,NISOUR/(NISINK+NSMALL))
6639 NCLis = NCLis*RATIO; NCLig = NCLig*RATIO; NCLih = NCLih*RATIO
6640 NINig = NINig*RATIO; NMLir = NMLir*RATIO; NMLic = NMLic*RATIO
6641 NCLir = NCLir*RATIO; NiCNis = NiCNis*RATIO
6642 ENDIF
6643 VISOUR = VI1D+(VIMcsi+VIMcgi+VIMrsi+VIMrgi+VHOci+VNMci+VNCci+ &
6644 VRMci)*DT
6645 VISINK = (-VMLir-VMLic+VCLir+ViCLis+ViCLig+VCLih+ViINig+ViCNis)*DT
6646 IF (VISINK.GT.VISOUR.AND.VISOUR.GE.ISMALL) THEN
6647 RATIO = MIN(1.,VISOUR/(VISINK+ISMALL))
6648 VMLir = VMLir*RATIO; VMLic = VMLic*RATIO; VCLir = VCLir*RATIO
6649 ViCLis = ViCLis*RATIO; ViCLig = ViCLig*RATIO
6650 VCLih = VCLih*RATIO; ViINig = ViINig*RATIO
6651 ViCNis = ViCNis*RATIO
6652 ENDIF
6653 FISOUR = FI1D+(FIMcsi+FIMcgi+FIMrsi+FIMrgi+FHOci+FNMci+FNCci+ &
6654 FRMci)*DT
6655 FISINK = (-FMLir-FMLic+FCLir+FiCLis+FCLig+FCLih+FINig+FiCNis)*DT
6656 IF (FISINK.GT.FISOUR.AND.FISOUR.GE.ISMALL) THEN
6657 RATIO = MIN(1.,FISOUR/(FISINK+ISMALL))
6658 FMLir = FMLir*RATIO; FMLic = FMLic*RATIO; FCLir = FCLir*RATIO
6659 FiCLis = FiCLis*RATIO; FCLig = FCLig*RATIO; FCLih = FCLih*RATIO
6660 FINig = FINig*RATIO; FiCNis = FiCNis*RATIO
6661 ENDIF
6662 AISOUR = AI1D+(AIMcsi+AIMcgi+AIMrsi+AIMrgi+AHOci+ANMci+ANCci+ &
6663 ARMci)*DT
6664 AISINK = (ACLir-AMLir-AMLic+AiCLis+AiCLig+AiCLih+AiINig+AiCNis)*DT
6665 IF (AISINK.GT.AISOUR.AND.AISOUR.GE.ASMALL) THEN
6666 RATIO = MIN(1.,AISOUR/(AISINK+ASMALL))
6667 AMLir = AMLir*RATIO; AMLic = AMLic*RATIO
6668 ACLir = ACLir*RATIO; AiCLis = AiCLis*RATIO
6669 AiCLig = AiCLig*RATIO; AiCLih = AiCLih*RATIO
6670 AiINig = AiINig*RATIO; AiCNis = AiCNis*RATIO
6671 ENDIF
6672 IISOUR = I3M1D+(IIMcsi+IIMcgi+IIMrsi+IIMrgi+IHOci+INMci+INCci+ &
6673 IRMci)*DT
6674 IISINK = (-IMLir-IMLic+ICLir+ICLis+ICLig+ICLih+IINig+ICNis)*DT
6675 IF (IISINK.GT.IISOUR.AND.IISOUR.GE.ISMALL) THEN
6676 RATIO = MIN(1.,IISOUR/(IISINK+ISMALL))
6677 IMLir = IMLir*RATIO; IMLic = IMLic*RATIO; ICLir = ICLir*RATIO
6678 ICLis = ICLis*RATIO; ICLig = ICLig*RATIO; ICLih = ICLih*RATIO
6679 IINig = IINig*RATIO; ICNis = ICNis*RATIO
6680 ENDIF
6681 QSSOUR = QS1D+(QCNis+QCLis+QRMcs)*DT
6682 QSSINK = (-QMLsr+QCLsr+QCLsg+QCLsh+QINsg)*DT
6683 IF (QSSINK.GT.QSSOUR.AND.QSSOUR.GE.QSMALL) THEN
6684 RATIO = MIN(1.,QSSOUR/(QSSINK+QSMALL))
6685 QMLsr = QMLsr*RATIO; QCLsg = QCLsg*RATIO; QCLsh = QCLsh*RATIO
6686 QINsg = QINsg*RATIO; QCLsr = QCLsr*RATIO
6687 ENDIF
6688 NSSOUR = NS1D+NsCNis*DT
6689 NSSINK = (-NMLsr+NCLsr+NCLsg+NCLsh-NCLss+NINsg)*DT
6690 IF (NSSINK.GT.NSSOUR.AND.NSSOUR.GE.NSMALL) THEN
6691 RATIO = MIN(1.,NSSOUR/(NSSINK+NSMALL))
6692 NMLsr = NMLsr*RATIO; NCLsg = NCLsg*RATIO; NCLsh = NCLsh*RATIO
6693 NCLss = NCLss*RATIO; NINsg = NINsg*RATIO; NCLsr = NCLsr*RATIO
6694 ENDIF
6695 VSSOUR = VS1D+(VsCNis+VsCLis+VRMcs+VCLss)*DT
6696 VSSINK = (-VMLsr+VCLsr+VsCLsg+VCLsh+VsINsg)*DT
6697 IF (VSSINK.GT.VSSOUR.AND.VSSOUR.GE.ISMALL) THEN
6698 RATIO = MIN(1.,VSSOUR/(VSSINK+ISMALL))
6699 VMLsr = VMLsr*RATIO; VsCLsg = VsCLsg*RATIO; VCLsh = VCLsh*RATIO
6700 VsINsg = VsINsg*RATIO; VCLsr = VCLsr*RATIO
6701 ENDIF
6702 FSSOUR = FS1D+(FsCNis+FsCLis+FRMcs+FCLss)*DT
6703 FSSINK = (-FMLsr+FCLsr+FCLsg+FCLsh+FINsg)*DT
6704 IF (FSSINK.GT.FSSOUR.AND.FSSOUR.GE.QSMALL) THEN
6705 RATIO = MIN(1.,FSSOUR/(FSSINK+QSMALL))
6706 FMLsr = FMLsr*RATIO; FCLsg = FCLsg*RATIO; FCLsh = FCLsh*RATIO
6707 FINsg = FINsg*RATIO; FCLsr = FCLsr*RATIO
6708 ENDIF
6709 ASSOUR = AS1D+(AsCNis+AsCLis+ARMcs+ACLss)*DT
6710 ASSINK = (-AMLsr+ACLsr+AsCLsg+AsCLsh+AsINsg-ACLss1)*DT
6711 IF (ASSINK.GT.ASSOUR.AND.ASSOUR.GE.ASMALL) THEN
6712 RATIO = MIN(1.,ASSOUR/(ASSINK+ASMALL))
6713 AMLsr = AMLsr*RATIO; AsINsg = AsINsg*RATIO; ACLsr = ACLsr*RATIO
6714 AsCLsg = AsCLsg*RATIO; AsCLsh = AsCLsh*RATIO
6715 ACLss1 = ACLss1*RATIO
6716 ENDIF
6717 QGSOUR = QG1D+(QHOrg+QNMrg+QCLig+QCLsg+QINig+QINsg+QRMcg+QCLirg+ &
6718 QCLsrg+QCLgrg)*DT
6719 QGSINK = (-QMLgr+QCNgh+QCLgr)*DT
6720 IF (QGSINK.GT.QGSOUR.AND.QGSOUR.GE.QSMALL) THEN
6721 RATIO = MIN(1.,QGSOUR/(QGSINK+QSMALL))
6722 QMLgr = QMLgr*RATIO; QCNgh = QCNgh*RATIO; QCLgr = QCLgr*RATIO
6723 ENDIF
6724 NGSOUR = NG1D+(NHOrg+NNMrg+NINig+NINsg+NCLirg+NCLsrg+NCLgrg)*DT
6725 NGSINK = (-NMLgr+NgCNgh+NCLgr)*DT
6726 IF (NGSINK.GT.NGSOUR.AND.NGSOUR.GE.NSMALL) THEN
6727 RATIO = MIN(1.,NGSOUR/(NGSINK+NSMALL))
6728 NMLgr = NMLgr*RATIO; NgCNgh = NgCNgh*RATIO; NCLgr = NCLgr*RATIO
6729 ENDIF
6730 VGSOUR = VG1D+(VHOrg+VNMrg+VgCLig+VgCLsg+VgINig+VgINsg+VRMcg+ &
6731 VCLirg+VCLsrg+VCLgrg)*DT
6732 VGSINK = (-VMLgr+VCNgh+VCLgr)*DT
6733 IF (VGSINK.GT.VGSOUR.AND.VGSOUR.GE.ISMALL) THEN
6734 RATIO = MIN(1.,VGSOUR/(VGSINK+ISMALL))
6735 VMLgr = VMLgr*RATIO; VCNgh = VCNgh*RATIO; VCLgr = VCLgr*RATIO
6736 ENDIF
6737 AGSOUR = AG1D+(AHOrg+ANMrg+AgCLig+AgCLsg+AgINig+AgINsg+ARMcg+ &
6738 ACLirg+ACLsrg+ACLgrg)*DT
6739 AGSINK = (-AMLgr+AgCNgh+ACLgr)*DT
6740 IF (AGSINK.GT.AGSOUR.AND.AGSOUR.GE.ASMALL) THEN
6741 RATIO = MIN(1.,AGSOUR/(AGSINK+ASMALL))
6742 AMLgr = AMLgr*RATIO; AgCNgh = AgCNgh*RATIO; ACLgr = ACLgr*RATIO
6743 ENDIF
6744 QHSOUR = QH1D+(QCNgh+QCLih+QCLsh+QHdrm)*DT
6745 QHSINK = (-QMLhr-QHwml)*DT
6746 IF (QHSINK.GT.QHSOUR.AND.QHSOUR.GE.QSMALL) THEN
6747 RATIO = MIN(1.,QHSOUR/(QHSINK+QSMALL))
6748 QMLhr = QMLhr*RATIO; QHwml = QHwml*RATIO
6749 ENDIF
6750 NHSOUR = NH1D+(NhCNgh)*DT
6751 NHSINK = (-NMLhr)*DT
6752 IF (NHSINK.GT.NHSOUR.AND.NHSOUR.GE.NSMALL) THEN
6753 RATIO = MIN(1.,NHSOUR/(NHSINK+NSMALL))
6754 NMLhr = NMLhr*RATIO
6755 ENDIF
6756 AHSOUR = AH1D+(AhCNgh+AhCLih+AhCLsh+AHdrm)*DT
6757 AHSINK = (-AMLhr-AHwml)*DT
6758 IF (AHSINK.GT.AHSOUR.AND.AHSOUR.GE.ASMALL) THEN
6759 RATIO = MIN(1.,AHSOUR/(AHSINK+ASMALL))
6760 AMLhr = AMLhr*RATIO; AHwml = AHwml*RATIO
6761 ENDIF
6763 QFZci = QHOci+QNMci+QNCci
6764 NFZci = NHOci+NNMci+NNCci
6765 VFZci = VHOci+VNMci+VNCci
6766 FFZci = FHOci+FNMci+FNCci
6767 AFZci = AHOci+ANMci+ANCci
6768 IFZci = IHOci+INMci+INCci
6769 QFZrg = QHOrg+QNMrg
6770 NFZrg = NHOrg+NNMrg
6771 VFZrg = VHOrg+VNMrg
6772 AFZrg = AHOrg+ANMrg
6773 QIMii = QIMcsi+QIMcgi+QIMrsi+QIMrgi
6774 NIMii = NIMcsi+NIMcgi+NIMrsi+NIMrgi
6775 VIMii = VIMcsi+VIMcgi+VIMrsi+VIMrgi
6776 AIMii = AIMcsi+AIMcgi+AIMrsi+AIMrgi
6777 FIMii = FIMcsi+FIMcgi+FIMrsi+FIMrgi
6778 IIMii = IIMcsi+IIMcgi+IIMrsi+IIMrgi
6779 GQCTR = (QRMcs+QRMcg+QRMch+QCLir+QCLcr+QCLis+QCLig+QCLih+QCNcr+ &
6780 QCNis+QINig-QBKrc-QIMcsi-QIMcgi-QMLir)*DT
6781 !----------------- UPDATE VARIABLES ------------------------------------
6782 QC1D = MAX(0.,QC1D+(QBKrc-QCLcr-QCNcr-QFZci-QMLic-QRMci-QRMcs- &
6783 QRMcg-QRMch-QIMcsi-QIMcgi)*DT)
6784 QR1D = MAX(0.,QR1D+(QCLcr+QCNcr-QBKrc-QFZrg-QIMrsi-QIMrgi-QMLir- &
6785 QMLsr-QMLgr-QMLhr-QRMri-QRMrs-QRMrg-QRMrh+QHwsh-QHwml)*DT)
6786 QI1D = MAX(0.,QI1D+(QIMii-QCNis-QCLis-QCLig-QCLih-QINig+QFZci+ &
6787 QMLir+QMLic+QRMci-QCLir)*DT)
6788 QS1D = MAX(0.,QS1D+(QCNis+QCLis-QCLsg-QCLsh-QINsg+QMLsr+QRMcs- &
6789 QCLsr)*DT)
6790 QG1D = MAX(0.,QG1D+(QFZrg+QCLig+QCLsg+QINig+QINsg+QMLgr+QRMcg- &
6791 QCNgh-QCLgr+QCLirg+QCLsrg+QCLgrg)*DT)
6792 QH1D = MAX(0.,QH1D+(QMLhr+QCNgh+QHdrm+QCLih+QCLsh+QHwml)*DT)
6793 NC1D = MAX(0.,NC1D+(NBKrc-NCLcr-NCLcc-NCNcr-NFZci-NRMci-NRMcs- &
6794 NRMcg-NRMch-NMLic-NIMcsi-NIMcgi)*DT)
6795 NR1D = MAX(0.,NR1D+(NCNcr+NBKrr-NBKrc-NCLrr-NIMrsi-NIMrgi-NFZrg- &
6796 NMLir-NMLsr-NMLgr-NMLhr-NRMri-NRMrs-NRMrg-NRMrh+NHwsh)*DT)
6797 NI1D = MAX(0.,NI1D+(NIMii-NiCNis-NCLis-NCLig-NCLih-NINig+NFZci+ &
6798 NMLir+NMLic-NCLir)*DT)
6799 NS1D = MAX(0.,NS1D+(NsCNis-NCLsg-NCLsh+NCLss-NINsg+NMLsr-NCLsr)* &
6800 DT)
6801 NG1D = MAX(0.,NG1D+(NFZrg+NINig+NINsg+NMLgr-NgCNgh-NCLgr+NCLirg+ &
6802 NCLsrg+NCLgrg)*DT)
6803 NH1D = MAX(0.,NH1D+(NMLhr+NhCNgh)*DT)
6804 IF (ICE_RHOI.EQ.0.OR.ICE_RHOI.EQ.2) THEN
6805 VI1D = 0.
6806 ELSEIF (ICE_RHOI.EQ.1) THEN
6807 VI1D = MAX(0.,VI1D+(VIMii-ViCNis-ViCLis-ViCLig-VCLih-ViINig+ &
6808 VFZci+VMLir+VMLic+VRMci-VCLir)*DT)
6809 ENDIF
6810 IF (ICE_RHOS.EQ.0.OR.ICE_RHOS.EQ.2) THEN
6811 VS1D = 0.
6812 ELSEIF (ICE_RHOS.EQ.1) THEN
6813 VS1D = MAX(0.,VS1D+(VsCNis+VsCLis-VsCLsg-VCLsh-VsINsg+VMLsr+ &
6814 VRMcs-VCLsr+VCLss)*DT)
6815 ENDIF
6816 IF (ICE_RHOG.EQ.0) THEN
6817 VG1D = 0.
6818 ELSEIF (ICE_RHOG.EQ.1.OR.ICE_RHOG.EQ.2) THEN
6819 VG1D = MAX(0.,VG1D+(VFZrg+VgCLig+VgCLsg+VgINig+VgINsg+VMLgr+ &
6820 VRMcg-VCNgh-VCLgr+VCLirg+VCLsrg+VCLgrg)*DT)
6821 ENDIF
6822 FI1D = MAX(0.,FI1D+(FIMii-FiCNis-FiCLis-FCLig-FCLih-FINig+FFZci+ &
6823 FMLir+FMLic+FRMci-FCLir)*DT)
6824 IF (AGG_SHAPE.EQ.0) THEN
6825 FS1D = 0.
6826 ELSEIF (AGG_SHAPE.EQ.1) THEN
6827 FS1D = MAX(0.,FS1D+(FsCNis+FsCLis-FCLsg-FCLsh-FINsg+FMLsr+ &
6828 FRMcs-FCLsr+FCLss)*DT)
6829 ENDIF
6830 I3M1D = MAX(0.,I3M1D+(IIMii-ICNis-ICLis-ICLig-ICLih-IINig+IFZci+ &
6831 IMLir+IMLic+IRMci-ICLir)*DT)
6832 IF (AFAI_3M.EQ.0.OR.AFAI_3M.EQ.2) THEN
6833 AI1D = 0.
6834 ELSEIF (AFAI_3M.EQ.1) THEN
6835 AI1D = MAX(0.,AI1D+(AIMii-AiCNis-AiCLis-AiCLig-AiCLih-AiINig+ &
6836 AFZci+AMLir+AMLic+ARMci-ACLir)*DT)
6837 ENDIF
6838 IF (AFAS_3M.EQ.0.OR.AFAS_3M.EQ.2) THEN
6839 AS1D = 0.
6840 ELSEIF (AFAS_3M.EQ.1) THEN
6841 AS1D = MAX(0.,AS1D+(AsCNis+AsCLis-AsCLsg-AsCLsh-AsINsg+AMLsr+ &
6842 ARMcs-ACLsr+ACLss+ACLss1)*DT)
6843 ENDIF
6844 IF (AFAG_3M.EQ.0.OR.AFAG_3M.EQ.2) THEN
6845 AG1D = 0.
6846 ELSEIF (AFAG_3M.EQ.1) THEN
6847 AG1D = MAX(0.,AG1D+(AFZrg+AgCLig+AgCLsg+AgINig+AgINsg+AMLgr+ &
6848 ARMcg-AgCNgh-ACLgr+ACLirg+ACLsrg+ACLgrg)*DT)
6849 ENDIF
6850 IF (AFAH_3M.EQ.0.OR.AFAH_3M.EQ.2) THEN
6851 AH1D = 0.
6852 ELSEIF (AFAH_3M.EQ.1) THEN
6853 AH1D = MAX(0.,AH1D+(AMLhr+AhCNgh+AHdrm+AhCLih+AhCLsh+AHwml)*DT)
6854 ENDIF
6855 ! QNIN = MAX(0.,QNIN-(NNCci+NNMci)*DT)
6856 TK1D = TK1D+((QFZci+QFZrg+QMLir+QMLic+QMLsr+QMLgr+QMLhr+QRMci+ &
6857 QRMcs+QRMcg+QRMri+QRMrs+QRMrg+QIMii+QHdrm+QHwml)*XXLF)/ &
6858 CPM*DT
6860 IF (QC1D.GE.QSMALL.AND.NC1D.GE.NSMALL) THEN
6861 MVDC = (QC1D*iAMW/NC1D)**THRD
6862 IF (MVDC.GT.DCR) THEN
6863 QR1D = QR1D+QC1D
6864 NR1D = NR1D+NC1D
6865 QC1D = 0.; NC1D = 0.
6866 ENDIF
6867 ENDIF
6868 IF (QR1D.GE.QSMALL.AND.NR1D.GE.NSMALL) THEN
6869 MVDR = (QR1D*iAMW/NR1D)**THRD
6870 IF (MVDR.LT.DCR) THEN
6871 QC1D = QC1D+QR1D
6872 NC1D = NC1D+NR1D
6873 QR1D = 0.; NR1D = 0.
6874 ENDIF
6875 ENDIF
6876 IF (QH1D.GE.QSMALL.AND.NH1D.GE.NSMALL) THEN
6877 MVDH = (QH1D*iAMH/NH1D)**THRD
6878 IF (MVDH.LT.DHMIN) THEN
6879 QG1D = QG1D+QH1D
6880 NG1D = NG1D+NH1D
6881 VG1D = VG1D+QH1D/RHOG0
6882 QH1D = 0.; NH1D = 0.
6883 IF (AH1D.GE.ASMALL.AND.AFAG_3M.EQ.1) THEN
6884 AG1D = AG1D+AH1D
6885 AH1D = 0.
6886 ENDIF
6887 ENDIF
6888 ENDIF
6889 IF (GQCTR.GT.0.) THEN
6890 TQCI = QC1D+QI1D
6891 IF (TQCI.GT.RLIMIT*2.) THEN
6892 GQCTR = MIN(1.,GQCTR/TQCI)
6893 ELSE
6894 GQCTR = 0.
6895 ENDIF
6896 ELSE
6897 TQRSG = QR1D+QS1D+QG1D+QH1D
6898 IF (TQRSG.GT.RLIMIT*3.) THEN
6899 GQCTR = MAX(-1.,GQCTR/TQRSG)
6900 ELSE
6901 GQCTR = 0.
6902 ENDIF
6903 ENDIF
6905 END SUBROUTINE LARGE_DT
6906 !======================================================================
6907 END MODULE MODULE_MP_NTU
6908 !======================================================================