ERF
Energy Research and Forecasting: An Atmospheric Modeling Code
•All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros Pages
Functions/Subroutines | Variables
module_mp_morr_two_moment Module Reference

Functions/Subroutines

subroutine morr_two_moment_init (morr_rimed_ice, morr_noice)
 
subroutine, public mp_morr_two_moment (ITIMESTEP, TH, QV, QC, QR, QI, QS, QG, NI, NS, NR, NG, RHO, PII, P, DT_IN, DZ, HT, W, RAINNC, RAINNCV, SR, SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV, refl_10cm, diagflag, do_radar_ref, qrcuten, qscuten, qicuten, F_QNDROP, qndrop, IDS, IDE, JDS, JDE, KDS, KDE, IMS, IME, JMS, JME, KMS, KME, ITS, ITE, JTS, JTE, KTS, KTE, wetscav_on, rainprod, evapprod, QLSINK, PRECR, PRECI, PRECS, PRECG)
 
subroutine, private morr_two_moment_micro (i, j, istep, kts, kte, QC3DTEN, QI3DTEN, QNI3DTEN, QR3DTEN, NI3DTEN, NS3DTEN, NR3DTEN, QC3D, QI3D, QNI3D, QR3D, NI3D, NS3D, NR3D, T3DTEN, QV3DTEN, T3D, QV3D, PRES, DZQ, W3D, PRECRT, SNOWRT, SNOWPRT, GRPLPRT, EFFC, EFFI, EFFS, EFFR, DT, QG3DTEN, NG3DTEN, QG3D, NG3D, EFFG, qrcu1d, qscu1d, qicu1d, QGSTEN, QRSTEN, QISTEN, QNISTEN, QCSTEN, nc3d, nc3dten, iinum, c2prec, CSED, ISED, SSED, GSED, RSED)
 
real(c_double) function, public polysvp (T, TYPE)
 
real(c_double) function, private gamma (X)
 

Variables

real(c_double), parameter, private pi = 3.1415926535897932384626434
 
real(c_double), parameter, private xxx = 0.9189385332046727417803297
 
integer, private iact
 
integer, private inum
 
real(c_double), private ndcnst
 
integer, private iliq
 
integer, private inuc
 
integer, private ibase
 
integer, private isub
 
integer, private igraup
 
integer, private ihail
 
real(c_double), private ai
 
real(c_double), private ac
 
real(c_double), private as
 
real(c_double), private ar
 
real(c_double), private ag
 
real(c_double), private bi
 
real(c_double), private bc
 
real(c_double), private bs
 
real(c_double), private br
 
real(c_double), private bg
 
real(c_double), private rhosu
 
real(c_double), private rhow
 
real(c_double), private rhoi
 
real(c_double), private rhosn
 
real(c_double), private rhog
 
real(c_double), private aimm
 
real(c_double), private bimm
 
real(c_double), private ecr
 
real(c_double), private dcs
 
real(c_double), private mi0
 
real(c_double), private mg0
 
real(c_double), private f1s
 
real(c_double), private f2s
 
real(c_double), private f1r
 
real(c_double), private f2r
 
real(c_double), private qsmall
 
real(c_double), private ci
 
real(c_double), private di
 
real(c_double), private cs
 
real(c_double), private ds
 
real(c_double), private cg
 
real(c_double), private dg
 
real(c_double), private eii
 
real(c_double), private eci
 
real(c_double), private rin
 
real(c_double), private cpw
 
real(c_double), private c1
 
real(c_double), private k1
 
real(c_double), private mw
 
real(c_double), private osm
 
real(c_double), private vi
 
real(c_double), private epsm
 
real(c_double), private rhoa
 
real(c_double), private map
 
real(c_double), private ma
 
real(c_double), private rr
 
real(c_double), private bact
 
real(c_double), private rm1
 
real(c_double), private rm2
 
real(c_double), private nanew1
 
real(c_double), private nanew2
 
real(c_double), private sig1
 
real(c_double), private sig2
 
real(c_double), private f11
 
real(c_double), private f12
 
real(c_double), private f21
 
real(c_double), private f22
 
real(c_double), private mmult
 
real(c_double), private lammaxi
 
real(c_double), private lammini
 
real(c_double), private lammaxr
 
real(c_double), private lamminr
 
real(c_double), private lammaxs
 
real(c_double), private lammins
 
real(c_double), private lammaxg
 
real(c_double), private lamming
 
real(c_double), private cons1
 
real(c_double), private cons2
 
real(c_double), private cons3
 
real(c_double), private cons4
 
real(c_double), private cons5
 
real(c_double), private cons6
 
real(c_double), private cons7
 
real(c_double), private cons8
 
real(c_double), private cons9
 
real(c_double), private cons10
 
real(c_double), private cons11
 
real(c_double), private cons12
 
real(c_double), private cons13
 
real(c_double), private cons14
 
real(c_double), private cons15
 
real(c_double), private cons16
 
real(c_double), private cons17
 
real(c_double), private cons18
 
real(c_double), private cons19
 
real(c_double), private cons20
 
real(c_double), private cons21
 
real(c_double), private cons22
 
real(c_double), private cons23
 
real(c_double), private cons24
 
real(c_double), private cons25
 
real(c_double), private cons26
 
real(c_double), private cons27
 
real(c_double), private cons28
 
real(c_double), private cons29
 
real(c_double), private cons30
 
real(c_double), private cons31
 
real(c_double), private cons32
 
real(c_double), private cons33
 
real(c_double), private cons34
 
real(c_double), private cons35
 
real(c_double), private cons36
 
real(c_double), private cons37
 
real(c_double), private cons38
 
real(c_double), private cons39
 
real(c_double), private cons40
 
real(c_double), private cons41
 

Function/Subroutine Documentation

◆ gamma()

real(c_double) function, private module_mp_morr_two_moment::gamma ( real(c_double)  X)
private
4093 !----------------------------------------------------------------------
4094 !
4095 ! THIS ROUTINE CALCULATES THE GAMMA FUNCTION FOR A REAL(C_DOUBLE) ARGUMENT X.
4096 ! COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN REFERENCE 1.
4097 ! THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE GAMMA
4098 ! FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS. COEFFICIENTS
4099 ! FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED.
4100 ! THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM REFERENCE 2.
4101 ! THE ACCURACY ACHIEVED DEPENDS ON THE ARITHMETIC SYSTEM, THE
4102 ! COMPILER, THE INTRINSIC FUNCTIONS, AND PROPER SELECTION OF THE
4103 ! MACHINE-DEPENDENT CONSTANTS.
4104 !
4105 !
4106 !*******************************************************************
4107 !*******************************************************************
4108 !
4109 ! EXPLANATION OF MACHINE-DEPENDENT CONSTANTS
4110 !
4111 ! BETA - RADIX FOR THE FLOATING-POINT REPRESENTATION
4112 ! MAXEXP - THE SMALLEST POSITIVE POWER OF BETA THAT OVERFLOWS
4113 ! XBIG - THE LARGEST ARGUMENT FOR WHICH GAMMA(X) IS REPRESENTABLE
4114 ! IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION
4115 ! GAMMA(XBIG) = BETA**MAXEXP
4116 ! XINF - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER;
4117 ! APPROXIMATELY BETA**MAXEXP
4118 ! EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
4119 ! 1.0+EPS .GT. 1.0
4120 ! XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
4121 ! 1/XMININ IS MACHINE REPRESENTABLE
4122 !
4123 ! APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE:
4124 !
4125 ! BETA MAXEXP XBIG
4126 !
4127 ! CRAY-1 (S.P.) 2 8191 966.961
4128 ! CYBER 180/855
4129 ! UNDER NOS (S.P.) 2 1070 177.803
4130 ! IEEE (IBM/XT,
4131 ! SUN, ETC.) (S.P.) 2 128 35.040
4132 ! IEEE (IBM/XT,
4133 ! SUN, ETC.) (D.P.) 2 1024 171.624
4134 ! IBM 3033 (D.P.) 16 63 57.574
4135 ! VAX D-FORMAT (D.P.) 2 127 34.844
4136 ! VAX G-FORMAT (D.P.) 2 1023 171.489
4137 !
4138 ! XINF EPS XMININ
4139 !
4140 ! CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-2466
4141 ! CYBER 180/855
4142 ! UNDER NOS (S.P.) 1.26E+322 3.55E-15 3.14E-294
4143 ! IEEE (IBM/XT,
4144 ! SUN, ETC.) (S.P.) 3.40E+38 1.19E-7 1.18E-38
4145 ! IEEE (IBM/XT,
4146 ! SUN, ETC.) (D.P.) 1.79D+308 2.22D-16 2.23D-308
4147 ! IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-76
4148 ! VAX D-FORMAT (D.P.) 1.70D+38 1.39D-17 5.88D-39
4149 ! VAX G-FORMAT (D.P.) 8.98D+307 1.11D-16 1.12D-308
4150 !
4151 !*******************************************************************
4152 !*******************************************************************
4153 !
4154 ! ERROR RETURNS
4155 !
4156 ! THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR
4157 ! WHEN OVERFLOW WOULD OCCUR. THE COMPUTATION IS BELIEVED
4158 ! TO BE FREE OF UNDERFLOW AND OVERFLOW.
4159 !
4160 !
4161 ! INTRINSIC FUNCTIONS REQUIRED ARE:
4162 !
4163 ! INT, DBLE, EXP, LOG, REAL(C_DOUBLE), SIN
4164 !
4165 !
4166 ! REFERENCES: AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL
4167 ! FUNCTIONS W. J. CODY, LECTURE NOTES IN MATHEMATICS,
4168 ! 506, NUMERICAL ANALYSIS DUNDEE, 1975, G. A. WATSON
4169 ! (ED.), SPRINGER VERLAG, BERLIN, 1976.
4170 !
4171 ! COMPUTER APPROXIMATIONS, HART, ET. AL., WILEY AND
4172 ! SONS, NEW YORK, 1968.
4173 !
4174 ! LATEST MODIFICATION: OCTOBER 12, 1989
4175 !
4176 ! AUTHORS: W. J. CODY AND L. STOLTZ
4177 ! APPLIED MATHEMATICS DIVISION
4178 ! ARGONNE NATIONAL LABORATORY
4179 ! ARGONNE, IL 60439
4180 !
4181 !----------------------------------------------------------------------
4182  implicit none
4183  INTEGER I,N
4184  LOGICAL PARITY
4185  REAL(C_DOUBLE) &
4186  conv,eps,fact,half,one,res,sum,twelve, &
4187  two,x,xbig,xden,xinf,xminin,xnum,y,y1,ysq,z,zero
4188  REAL(C_DOUBLE), DIMENSION(7) :: C
4189  REAL(C_DOUBLE), DIMENSION(8) :: P
4190  REAL(C_DOUBLE), DIMENSION(8) :: Q
4191 !----------------------------------------------------------------------
4192 ! MATHEMATICAL CONSTANTS
4193 !----------------------------------------------------------------------
4194  DATA one,half,twelve,two,zero/1.0e0,0.5e0,12.0e0,2.0e0,0.0e0/
4195 
4196 
4197 !----------------------------------------------------------------------
4198 ! MACHINE DEPENDENT PARAMETERS
4199 !----------------------------------------------------------------------
4200  DATA xbig,xminin,eps/35.040e0,1.18e-38,1.19e-7/,xinf/3.4e38/
4201 !----------------------------------------------------------------------
4202 ! NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX
4203 ! APPROXIMATION OVER (1,2).
4204 !----------------------------------------------------------------------
4205  DATA p/-1.71618513886549492533811e+0,2.47656508055759199108314e+1, &
4206  -3.79804256470945635097577e+2,6.29331155312818442661052e+2, &
4207  8.66966202790413211295064e+2,-3.14512729688483675254357e+4, &
4208  -3.61444134186911729807069e+4,6.64561438202405440627855e+4/
4209  DATA q/-3.08402300119738975254353e+1,3.15350626979604161529144e+2, &
4210  -1.01515636749021914166146e+3,-3.10777167157231109440444e+3, &
4211  2.25381184209801510330112e+4,4.75584627752788110767815e+3, &
4212  -1.34659959864969306392456e+5,-1.15132259675553483497211e+5/
4213 !----------------------------------------------------------------------
4214 ! COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF).
4215 !----------------------------------------------------------------------
4216  DATA c/-1.910444077728e-03,8.4171387781295e-04, &
4217  -5.952379913043012e-04,7.93650793500350248e-04, &
4218  -2.777777777777681622553e-03,8.333333333333333331554247e-02, &
4219  5.7083835261e-03/
4220 !----------------------------------------------------------------------
4221 ! STATEMENT FUNCTIONS FOR CONVERSION BETWEEN INTEGER AND FLOAT
4222 !----------------------------------------------------------------------
4223  conv(i) = real(i)
4224  parity=.false.
4225  fact=one
4226  n=0
4227  y=x
4228  IF(y.LE.zero)THEN
4229 !----------------------------------------------------------------------
4230 ! ARGUMENT IS NEGATIVE
4231 !----------------------------------------------------------------------
4232  y=-x
4233  y1=aint(y)
4234  res=y-y1
4235  IF(res.NE.zero)THEN
4236  IF(y1.NE.aint(y1*half)*two)parity=.true.
4237  fact=-pi/sin(pi*res)
4238  y=y+one
4239  ELSE
4240  res=xinf
4241  GOTO 900
4242  ENDIF
4243  ENDIF
4244 !----------------------------------------------------------------------
4245 ! ARGUMENT IS POSITIVE
4246 !----------------------------------------------------------------------
4247  IF(y.LT.eps)THEN
4248 !----------------------------------------------------------------------
4249 ! ARGUMENT .LT. EPS
4250 !----------------------------------------------------------------------
4251  IF(y.GE.xminin)THEN
4252  res=one/y
4253  ELSE
4254  res=xinf
4255  GOTO 900
4256  ENDIF
4257  ELSEIF(y.LT.twelve)THEN
4258  y1=y
4259  IF(y.LT.one)THEN
4260 !----------------------------------------------------------------------
4261 ! 0.0 .LT. ARGUMENT .LT. 1.0
4262 !----------------------------------------------------------------------
4263  z=y
4264  y=y+one
4265  ELSE
4266 !----------------------------------------------------------------------
4267 ! 1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY
4268 !----------------------------------------------------------------------
4269  n=int(y)-1
4270  y=y-conv(n)
4271  z=y-one
4272  ENDIF
4273 !----------------------------------------------------------------------
4274 ! EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0
4275 !----------------------------------------------------------------------
4276  xnum=zero
4277  xden=one
4278  DO i=1,8
4279  xnum=(xnum+p(i))*z
4280  xden=xden*z+q(i)
4281  END DO
4282  res=xnum/xden+one
4283  IF(y1.LT.y)THEN
4284 !----------------------------------------------------------------------
4285 ! ADJUST RESULT FOR CASE 0.0 .LT. ARGUMENT .LT. 1.0
4286 !----------------------------------------------------------------------
4287  res=res/y1
4288  ELSEIF(y1.GT.y)THEN
4289 !----------------------------------------------------------------------
4290 ! ADJUST RESULT FOR CASE 2.0 .LT. ARGUMENT .LT. 12.0
4291 !----------------------------------------------------------------------
4292  DO i=1,n
4293  res=res*y
4294  y=y+one
4295  END DO
4296  ENDIF
4297  ELSE
4298 !----------------------------------------------------------------------
4299 ! EVALUATE FOR ARGUMENT .GE. 12.0,
4300 !----------------------------------------------------------------------
4301  IF(y.LE.xbig)THEN
4302  ysq=y*y
4303  sum=c(7)
4304  DO i=1,6
4305  sum=sum/ysq+c(i)
4306  END DO
4307  sum=sum/y-y+xxx
4308  sum=sum+(y-half)*log(y)
4309  res=exp(sum)
4310  ELSE
4311  res=xinf
4312  GOTO 900
4313  ENDIF
4314  ENDIF
4315 !----------------------------------------------------------------------
4316 ! FINAL ADJUSTMENTS AND RETURN
4317 !----------------------------------------------------------------------
4318  IF(parity)res=-res
4319  IF(fact.NE.one)res=fact/res
4320  900 gamma=res
4321  RETURN
4322 ! ---------- LAST LINE OF GAMMA ----------
real
double real
Definition: ERF_OrbCosZenith.H:9

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

Here is the caller graph for this function:

◆ morr_two_moment_init()

subroutine module_mp_morr_two_moment::morr_two_moment_init ( integer, intent(in)  morr_rimed_ice,
integer, intent(in)  morr_noice 
)
251 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
252 ! THIS SUBROUTINE INITIALIZES ALL PHYSICAL CONSTANTS AMND PARAMETERS
253 ! NEEDED BY THE MICROPHYSICS SCHEME.
254 ! NEEDS TO BE CALLED AT FIRST TIME STEP, PRIOR TO CALL TO MAIN MICROPHYSICS INTERFACE
255 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
256 
257  IMPLICIT NONE
258 
259  INTEGER, INTENT(IN):: morr_rimed_ice ! RAS
260  INTEGER, INTENT(IN):: morr_noice
261 
262  integer n,i
263 
264  print *,'IN MORR_TWO_MOMENT_INIT ',"with noice = ",morr_noice
265 
266 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
267 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
268 
269 ! THE FOLLOWING PARAMETERS ARE USER-DEFINED SWITCHES AND NEED TO BE
270 ! SET PRIOR TO CODE COMPILATION
271 
272 ! INUM IS AUTOMATICALLY SET TO 0 FOR WRF-CHEM BELOW,
273 ! ALLOWING PREDICTION OF DROPLET CONCENTRATION
274 ! THUS, THIS PARAMETER SHOULD NOT BE CHANGED HERE
275 ! AND SHOULD BE LEFT TO 1
276 
277  inum = 1
278 
279 ! SET CONSTANT DROPLET CONCENTRATION (UNITS OF CM-3)
280 ! IF NO COUPLING WITH WRF-CHEM
281 
282  ndcnst = 250.
283 
284 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
285 ! NOTE, THE FOLLOWING OPTIONS RELATED TO DROPLET ACTIVATION
286 ! (IACT, IBASE, ISUB) ARE NOT AVAILABLE IN CURRENT VERSION
287 ! FOR WRF-CHEM, DROPLET ACTIVATION IS PERFORMED
288 ! IN 'MIX_ACTIVATE', NOT IN MICROPHYSICS SCHEME
289 
290 
291 ! IACT = 1, USE POWER-LAW CCN SPECTRA, NCCN = CS^K
292 ! IACT = 2, USE LOGNORMAL AEROSOL SIZE DIST TO DERIVE CCN SPECTRA
293 
294  iact = 2
295 
296 ! IBASE = 1, NEGLECT DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO
297 ! UNRESOLVED ENTRAINMENT AND MIXING, ACTIVATE
298 ! AT CLOUD BASE OR IN REGION WITH LITTLE CLOUD WATER USING
299 ! NON-EQULIBRIUM SUPERSATURATION ASSUMING NO INITIAL CLOUD WATER,
300 ! IN CLOUD INTERIOR ACTIVATE USING EQUILIBRIUM SUPERSATURATION
301 ! IBASE = 2, ASSUME DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO
302 ! UNRESOLVED ENTRAINMENT AND MIXING DOMINATES,
303 ! ACTIVATE DROPLETS EVERYWHERE IN THE CLOUD USING NON-EQUILIBRIUM
304 ! SUPERSATURATION ASSUMING NO INITIAL CLOUD WATER, BASED ON THE
305 ! LOCAL SUB-GRID AND/OR GRID-SCALE VERTICAL VELOCITY
306 ! AT THE GRID POINT
307 
308 ! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0)
309 
310  ibase = 2
311 
312 ! INCLUDE SUB-GRID VERTICAL VELOCITY (standard deviation of w) IN DROPLET ACTIVATION
313 ! ISUB = 0, INCLUDE SUB-GRID W (RECOMMENDED FOR LOWER RESOLUTION)
314 ! currently, sub-grid w is constant of 0.5 m/s (not coupled with PBL/turbulence scheme)
315 ! ISUB = 1, EXCLUDE SUB-GRID W, ONLY USE GRID-SCALE W
316 
317 ! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0)
318 
319  isub = 0
320 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
321  if(morr_noice .eq. 1) then
322 
323 ! SWITCH FOR LIQUID-ONLY RUN
324 ! ILIQ = 0, INCLUDE ICE
325 ! ILIQ = 1, LIQUID ONLY, NO ICE
326 
327  iliq = 1
328 
329 ! SWITCH FOR ICE NUCLEATION
330 ! INUC = 0, USE FORMULA FROM RASMUSSEN ET AL. 2002 (MID-LATITUDE)
331 ! = 1, USE MPACE OBSERVATIONS (ARCTIC ONLY)
332 
333  inuc = 0
334 
335 ! SWITCH FOR GRAUPEL/HAIL NO GRAUPEL/HAIL
336 ! IGRAUP = 0, INCLUDE GRAUPEL/HAIL
337 ! IGRAUP = 1, NO GRAUPEL/HAIL
338 
339  igraup = 1
340 
341 ! HM ADDED 11/7/07
342 ! SWITCH FOR HAIL/GRAUPEL
343 ! IHAIL = 0, DENSE PRECIPITATING ICE IS GRAUPEL
344 ! IHAIL = 1, DENSE PRECIPITATING ICE IS HAIL
345 ! NOTE ---> RECOMMEND IHAIL = 1 FOR CONTINENTAL DEEP CONVECTION
346 
347  !IHAIL = 0 !changed to namelist option (morr_rimed_ice) by RAS
348  ! Check if namelist option is feasible, otherwise default to graupel - RAS
349  IF (morr_rimed_ice .eq. 1) THEN
350  ihail = 1
351  ELSE
352  ihail = 0
353  ENDIF
354 else
355 
356 ! SWITCH FOR LIQUID-ONLY RUN
357 ! ILIQ = 0, INCLUDE ICE
358 ! ILIQ = 1, LIQUID ONLY, NO ICE
359 
360  iliq = 0
361 
362 ! SWITCH FOR ICE NUCLEATION
363 ! INUC = 0, USE FORMULA FROM RASMUSSEN ET AL. 2002 (MID-LATITUDE)
364 ! = 1, USE MPACE OBSERVATIONS (ARCTIC ONLY)
365 
366  inuc = 0
367 
368 ! SWITCH FOR GRAUPEL/HAIL NO GRAUPEL/HAIL
369 ! IGRAUP = 0, INCLUDE GRAUPEL/HAIL
370 ! IGRAUP = 1, NO GRAUPEL/HAIL
371 
372  igraup = 0
373 
374 ! HM ADDED 11/7/07
375 ! SWITCH FOR HAIL/GRAUPEL
376 ! IHAIL = 0, DENSE PRECIPITATING ICE IS GRAUPEL
377 ! IHAIL = 1, DENSE PRECIPITATING ICE IS HAIL
378 ! NOTE ---> RECOMMEND IHAIL = 1 FOR CONTINENTAL DEEP CONVECTION
379 
380  !IHAIL = 0 !changed to namelist option (morr_rimed_ice) by RAS
381  ! Check if namelist option is feasible, otherwise default to graupel - RAS
382  IF (morr_rimed_ice .eq. 1) THEN
383  ihail = 1
384  ELSE
385  ihail = 0
386  ENDIF
387 endif
388 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
389 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
390 ! SET PHYSICAL CONSTANTS
391 
392 ! FALLSPEED PARAMETERS (V=AD^B)
393  ai = 700.
394  ac = 3.e7
395  as = 11.72
396  ar = 841.99667
397  bi = 1.
398  bc = 2.
399  bs = 0.41
400  br = 0.8
401  IF (ihail.EQ.0) THEN
402  ag = 19.3
403  bg = 0.37
404  ELSE ! (MATSUN AND HUGGINS 1980)
405  ag = 114.5
406  bg = 0.5
407  END IF
408 
409 ! CONSTANTS AND PARAMETERS
410 ! R = 287.15
411 ! RV = 461.5
412 ! CP = 1005.
413  rhosu = 85000./(287.15*273.15)
414  rhow = 997.
415  rhoi = 500.
416  rhosn = 100.
417  IF (ihail.EQ.0) THEN
418  rhog = 400.
419  ELSE
420  rhog = 900.
421  END IF
422  aimm = 0.66
423  bimm = 100.
424  ecr = 1.
425  dcs = 125.e-6
426  mi0 = 4./3.*pi*rhoi*(10.e-6)**3
427  mg0 = 1.6e-10
428  f1s = 0.86
429  f2s = 0.28
430  f1r = 0.78
431 ! F2R = 0.32
432 ! fix 053011
433  f2r = 0.308
434 ! G = 9.806
435 
436  qsmall = 1.d-14
437  print *,'SETTING SMALL TO ',qsmall
438 
439  eii = 0.1
440  eci = 0.7
441 ! HM, ADD FOR V3.2
442 ! hm, 7/23/13
443 ! CPW = 4218.
444  cpw = 4187.
445 
446 ! SIZE DISTRIBUTION PARAMETERS
447 
448  ci = rhoi*pi/6.
449  di = 3.
450  cs = rhosn*pi/6.
451  ds = 3.
452  cg = rhog*pi/6.
453  dg = 3.
454 
455 ! RADIUS OF CONTACT NUCLEI
456  rin = 0.1e-6
457 
458  mmult = 4./3.*pi*rhoi*(5.e-6)**3
459 
460 ! SIZE LIMITS FOR LAMBDA
461 
462  lammaxi = 1./1.e-6
463  lammini = 1./(2.*dcs+100.e-6)
464  lammaxr = 1./20.e-6
465 ! LAMMINR = 1./500.E-6
466  lamminr = 1./2800.e-6
467 
468  lammaxs = 1./10.e-6
469  lammins = 1./2000.e-6
470  lammaxg = 1./20.e-6
471  lamming = 1./2000.e-6
472 
473 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
474 ! note: these parameters only used by the non-wrf-chem version of the
475 ! scheme with predicted droplet number
476 
477 ! CCN SPECTRA FOR IACT = 1
478 
479 ! MARITIME
480 ! MODIFIED FROM RASMUSSEN ET AL. 2002
481 ! NCCN = C*S^K, NCCN IS IN CM-3, S IS SUPERSATURATION RATIO IN %
482 
483  k1 = 0.4
484  c1 = 120.
485 
486 ! CONTINENTAL
487 
488 ! K1 = 0.5
489 ! C1 = 1000.
490 
491 ! AEROSOL ACTIVATION PARAMETERS FOR IACT = 2
492 ! PARAMETERS CURRENTLY SET FOR AMMONIUM SULFATE
493 
494  mw = 0.018
495  osm = 1.
496  vi = 3.
497  epsm = 0.7
498  rhoa = 1777.
499  map = 0.132
500  ma = 0.0284
501 ! hm fix 6/23/16
502 ! RR = 8.3187
503  rr = 8.3145
504  bact = vi*osm*epsm*mw*rhoa/(map*rhow)
505 
506 ! AEROSOL SIZE DISTRIBUTION PARAMETERS CURRENTLY SET FOR MPACE
507 ! (see morrison et al. 2007, JGR)
508 ! MODE 1
509 
510  rm1 = 0.052e-6
511  sig1 = 2.04
512  nanew1 = 72.2e6
513  f11 = 0.5*exp(2.5*(log(sig1))**2)
514  f21 = 1.+0.25*log(sig1)
515 
516 ! MODE 2
517 
518  rm2 = 1.3e-6
519  sig2 = 2.5
520  nanew2 = 1.8e6
521  f12 = 0.5*exp(2.5*(log(sig2))**2)
522  f22 = 1.+0.25*log(sig2)
523 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
524 
525 ! CONSTANTS FOR EFFICIENCY
526 
527  cons1=gamma(1.+ds)*cs
528  cons2=gamma(1.+dg)*cg
529  cons3=gamma(4.+bs)/6.
530  cons4=gamma(4.+br)/6.
531  cons5=gamma(1.+bs)
532  cons6=gamma(1.+br)
533  cons7=gamma(4.+bg)/6.
534  cons8=gamma(1.+bg)
535  cons9=gamma(5./2.+br/2.)
536  cons10=gamma(5./2.+bs/2.)
537  cons11=gamma(5./2.+bg/2.)
538  cons12=gamma(1.+di)*ci
539  cons13=gamma(bs+3.)*pi/4.*eci
540  cons14=gamma(bg+3.)*pi/4.*eci
541  cons15=-1108.*eii*pi**((1.-bs)/3.)*rhosn**((-2.-bs)/3.)/(4.*720.)
542  cons16=gamma(bi+3.)*pi/4.*eci
543  cons17=4.*2.*3.*rhosu*pi*eci*eci*gamma(2.*bs+2.)/(8.*(rhog-rhosn))
544  cons18=rhosn*rhosn
545  cons19=rhow*rhow
546  cons20=20.*pi*pi*rhow*bimm
547  cons21=4./(dcs*rhoi)
548  cons22=pi*rhoi*dcs**3/6.
549  cons23=pi/4.*eii*gamma(bs+3.)
550  cons24=pi/4.*ecr*gamma(br+3.)
551  cons25=pi*pi/24.*rhow*ecr*gamma(br+6.)
552  cons26=pi/6.*rhow
553  cons27=gamma(1.+bi)
554  cons28=gamma(4.+bi)/6.
555  cons29=4./3.*pi*rhow*(25.e-6)**3
556  cons30=4./3.*pi*rhow
557  cons31=pi*pi*ecr*rhosn
558  cons32=pi/2.*ecr
559  cons33=pi*pi*ecr*rhog
560  cons34=5./2.+br/2.
561  cons35=5./2.+bs/2.
562  cons36=5./2.+bg/2.
563  cons37=4.*pi*1.38e-23/(6.*pi*rin)
564  cons38=pi*pi/3.*rhow
565  cons39=pi*pi/36.*rhow*bimm
566  cons40=pi/6.*bimm
567  cons41=pi*pi*ecr*rhow
568 

Referenced by mp_morr_two_moment_isohelper::morr_two_moment_init_c().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ morr_two_moment_micro()

subroutine, private module_mp_morr_two_moment::morr_two_moment_micro ( integer, intent(in)  i,
integer, intent(in)  j,
integer, intent(in)  istep,
integer, intent(in)  kts,
integer, intent(in)  kte,
real(c_double), dimension(kts:kte)  QC3DTEN,
real(c_double), dimension(kts:kte)  QI3DTEN,
real(c_double), dimension(kts:kte)  QNI3DTEN,
real(c_double), dimension(kts:kte)  QR3DTEN,
real(c_double), dimension(kts:kte)  NI3DTEN,
real(c_double), dimension(kts:kte)  NS3DTEN,
real(c_double), dimension(kts:kte)  NR3DTEN,
real(c_double), dimension(kts:kte)  QC3D,
real(c_double), dimension(kts:kte)  QI3D,
real(c_double), dimension(kts:kte)  QNI3D,
real(c_double), dimension(kts:kte)  QR3D,
real(c_double), dimension(kts:kte)  NI3D,
real(c_double), dimension(kts:kte)  NS3D,
real(c_double), dimension(kts:kte)  NR3D,
real(c_double), dimension(kts:kte)  T3DTEN,
real(c_double), dimension(kts:kte)  QV3DTEN,
real(c_double), dimension(kts:kte)  T3D,
real(c_double), dimension(kts:kte)  QV3D,
real(c_double), dimension(kts:kte)  PRES,
real(c_double), dimension(kts:kte)  DZQ,
real(c_double), dimension(kts:kte)  W3D,
real(c_double)  PRECRT,
real(c_double)  SNOWRT,
real(c_double)  SNOWPRT,
real(c_double)  GRPLPRT,
real(c_double), dimension(kts:kte)  EFFC,
real(c_double), dimension(kts:kte)  EFFI,
real(c_double), dimension(kts:kte)  EFFS,
real(c_double), dimension(kts:kte)  EFFR,
real(c_double)  DT,
real(c_double), dimension(kts:kte)  QG3DTEN,
real(c_double), dimension(kts:kte)  NG3DTEN,
real(c_double), dimension(kts:kte)  QG3D,
real(c_double), dimension(kts:kte)  NG3D,
real(c_double), dimension(kts:kte)  EFFG,
real(c_double), dimension(kts:kte)  qrcu1d,
real(c_double), dimension(kts:kte)  qscu1d,
real(c_double), dimension(kts:kte)  qicu1d,
real(c_double), dimension(kts:kte)  QGSTEN,
real(c_double), dimension(kts:kte)  QRSTEN,
real(c_double), dimension(kts:kte)  QISTEN,
real(c_double), dimension(kts:kte)  QNISTEN,
real(c_double), dimension(kts:kte)  QCSTEN,
real(c_double), dimension(kts:kte)  nc3d,
real(c_double), dimension(kts:kte)  nc3dten,
integer, intent(in)  iinum,
real(c_double), dimension(kts:kte)  c2prec,
real(c_double), dimension(kts:kte)  CSED,
real(c_double), dimension(kts:kte)  ISED,
real(c_double), dimension(kts:kte)  SSED,
real(c_double), dimension(kts:kte)  GSED,
real(c_double), dimension(kts:kte)  RSED 
)
private
918 
919 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
920 ! THIS PROGRAM IS THE MAIN TWO-MOMENT MICROPHYSICS SUBROUTINE DESCRIBED BY
921 ! MORRISON ET AL. 2005 JAS AND MORRISON ET AL. 2009 MWR
922 
923 ! THIS SCHEME IS A BULK DOUBLE-MOMENT SCHEME THAT PREDICTS MIXING
924 ! RATIOS AND NUMBER CONCENTRATIONS OF FIVE HYDROMETEOR SPECIES:
925 ! CLOUD DROPLETS, CLOUD (SMALL) ICE, RAIN, SNOW, AND GRAUPEL/HAIL.
926 
927 ! CODE STRUCTURE: MAIN SUBROUTINE IS 'MORR_TWO_MOMENT'. ALSO INCLUDED IN THIS FILE IS
928 ! 'FUNCTION POLYSVP', 'FUNCTION DERF1', AND
929 ! 'FUNCTION GAMMA'.
930 
931 ! NOTE: THIS SUBROUTINE USES 1D ARRAY IN VERTICAL (COLUMN), EVEN THOUGH VARIABLES ARE CALLED '3D'......
932 
933 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
934 
935 ! DECLARATIONS
936 
937  IMPLICIT NONE
938 
939 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
940 ! THESE VARIABLES BELOW MUST BE LINKED WITH THE MAIN MODEL.
941 ! DEFINE ARRAY SIZES
942 
943 ! INPUT NUMBER OF GRID CELLS
944 
945 ! INPUT/OUTPUT PARAMETERS ! DESCRIPTION (UNITS)
946  INTEGER, INTENT( IN) :: i,j,istep,kts,kte
947 
948  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QC3DTEN ! CLOUD WATER MIXING RATIO TENDENCY (KG/KG/S)
949  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QI3DTEN ! CLOUD ICE MIXING RATIO TENDENCY (KG/KG/S)
950  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QNI3DTEN ! SNOW MIXING RATIO TENDENCY (KG/KG/S)
951  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QR3DTEN ! RAIN MIXING RATIO TENDENCY (KG/KG/S)
952  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NI3DTEN ! CLOUD ICE NUMBER CONCENTRATION (1/KG/S)
953  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NS3DTEN ! SNOW NUMBER CONCENTRATION (1/KG/S)
954  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NR3DTEN ! RAIN NUMBER CONCENTRATION (1/KG/S)
955  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QC3D ! CLOUD WATER MIXING RATIO (KG/KG)
956  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QI3D ! CLOUD ICE MIXING RATIO (KG/KG)
957  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QNI3D ! SNOW MIXING RATIO (KG/KG)
958  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QR3D ! RAIN MIXING RATIO (KG/KG)
959  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NI3D ! CLOUD ICE NUMBER CONCENTRATION (1/KG)
960  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NS3D ! SNOW NUMBER CONCENTRATION (1/KG)
961  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NR3D ! RAIN NUMBER CONCENTRATION (1/KG)
962  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: T3DTEN ! TEMPERATURE TENDENCY (K/S)
963  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QV3DTEN ! WATER VAPOR MIXING RATIO TENDENCY (KG/KG/S)
964  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: T3D ! TEMPERATURE (K)
965  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QV3D ! WATER VAPOR MIXING RATIO (KG/KG)
966  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PRES ! ATMOSPHERIC PRESSURE (PA)
967  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: DZQ ! DIFFERENCE IN HEIGHT ACROSS LEVEL (m)
968  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: W3D ! GRID-SCALE VERTICAL VELOCITY (M/S)
969 ! below for wrf-chem
970  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: nc3d
971  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: nc3dten
972  integer, intent(in) :: iinum
973 
974 ! HM ADDED GRAUPEL VARIABLES
975  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QG3DTEN ! GRAUPEL MIX RATIO TENDENCY (KG/KG/S)
976  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NG3DTEN ! GRAUPEL NUMB CONC TENDENCY (1/KG/S)
977  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QG3D ! GRAUPEL MIX RATIO (KG/KG)
978  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NG3D ! GRAUPEL NUMBER CONC (1/KG)
979 
980 ! HM, ADD 1/16/07, SEDIMENTATION TENDENCIES FOR MIXING RATIO
981 
982  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QGSTEN ! GRAUPEL SED TEND (KG/KG/S)
983  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QRSTEN ! RAIN SED TEND (KG/KG/S)
984  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QISTEN ! CLOUD ICE SED TEND (KG/KG/S)
985  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QNISTEN ! SNOW SED TEND (KG/KG/S)
986  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QCSTEN ! CLOUD WAT SED TEND (KG/KG/S)
987 
988 ! hm add cumulus tendencies for precip
989  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: qrcu1d
990  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: qscu1d
991  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: qicu1d
992 
993 ! OUTPUT VARIABLES
994 
995  REAL(C_DOUBLE) PRECRT ! TOTAL PRECIP PER TIME STEP (mm)
996  REAL(C_DOUBLE) SNOWRT ! SNOW PER TIME STEP (mm)
997 ! hm added 7/13/13
998  REAL(C_DOUBLE) SNOWPRT ! TOTAL CLOUD ICE PLUS SNOW PER TIME STEP (mm)
999  REAL(C_DOUBLE) GRPLPRT ! TOTAL GRAUPEL PER TIME STEP (mm)
1000 
1001  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: EFFC ! DROPLET EFFECTIVE RADIUS (MICRON)
1002  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: EFFI ! CLOUD ICE EFFECTIVE RADIUS (MICRON)
1003  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: EFFS ! SNOW EFFECTIVE RADIUS (MICRON)
1004  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: EFFR ! RAIN EFFECTIVE RADIUS (MICRON)
1005  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: EFFG ! GRAUPEL EFFECTIVE RADIUS (MICRON)
1006 
1007 ! MODEL INPUT PARAMETERS (FORMERLY IN COMMON BLOCKS)
1008 
1009  REAL(C_DOUBLE) DT ! MODEL TIME STEP (SEC)
1010 
1011 
1012 !.....................................................................................................
1013 ! LOCAL VARIABLES: ALL PARAMETERS BELOW ARE LOCAL TO SCHEME AND DON'T NEED TO COMMUNICATE WITH THE
1014 ! REST OF THE MODEL.
1015 
1016 ! SIZE PARAMETER VARIABLES
1017 
1018  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: LAMC ! SLOPE PARAMETER FOR DROPLETS (M-1)
1019  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: LAMI ! SLOPE PARAMETER FOR CLOUD ICE (M-1)
1020  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: LAMS ! SLOPE PARAMETER FOR SNOW (M-1)
1021  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: LAMR ! SLOPE PARAMETER FOR RAIN (M-1)
1022  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: LAMG ! SLOPE PARAMETER FOR GRAUPEL (M-1)
1023  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: CDIST1 ! PSD PARAMETER FOR DROPLETS
1024  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: N0I ! INTERCEPT PARAMETER FOR CLOUD ICE (KG-1 M-1)
1025  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: N0S ! INTERCEPT PARAMETER FOR SNOW (KG-1 M-1)
1026  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: N0RR ! INTERCEPT PARAMETER FOR RAIN (KG-1 M-1)
1027  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: N0G ! INTERCEPT PARAMETER FOR GRAUPEL (KG-1 M-1)
1028  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PGAM ! SPECTRAL SHAPE PARAMETER FOR DROPLETS
1029 
1030 ! MICROPHYSICAL PROCESSES
1031 
1032  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NSUBC ! LOSS OF NC DURING EVAP
1033  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NSUBI ! LOSS OF NI DURING SUB.
1034  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NSUBS ! LOSS OF NS DURING SUB.
1035  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NSUBR ! LOSS OF NR DURING EVAP
1036  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PRD ! DEP CLOUD ICE
1037  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PRE ! EVAP OF RAIN
1038  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PRDS ! DEP SNOW
1039  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NNUCCC ! CHANGE N DUE TO CONTACT FREEZ DROPLETS
1040  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: MNUCCC ! CHANGE Q DUE TO CONTACT FREEZ DROPLETS
1041  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PRA ! ACCRETION DROPLETS BY RAIN
1042  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PRC ! AUTOCONVERSION DROPLETS
1043  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PCC ! COND/EVAP DROPLETS
1044  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NNUCCD ! CHANGE N FREEZING AEROSOL (PRIM ICE NUCLEATION)
1045  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: MNUCCD ! CHANGE Q FREEZING AEROSOL (PRIM ICE NUCLEATION)
1046  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: MNUCCR ! CHANGE Q DUE TO CONTACT FREEZ RAIN
1047  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NNUCCR ! CHANGE N DUE TO CONTACT FREEZ RAIN
1048  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NPRA ! CHANGE IN N DUE TO DROPLET ACC BY RAIN
1049  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NRAGG ! SELF-COLLECTION/BREAKUP OF RAIN
1050  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NSAGG ! SELF-COLLECTION OF SNOW
1051  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NPRC ! CHANGE NC AUTOCONVERSION DROPLETS
1052  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NPRC1 ! CHANGE NR AUTOCONVERSION DROPLETS
1053  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PRAI ! CHANGE Q ACCRETION CLOUD ICE BY SNOW
1054  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PRCI ! CHANGE Q AUTOCONVERSIN CLOUD ICE TO SNOW
1055  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PSACWS ! CHANGE Q DROPLET ACCRETION BY SNOW
1056  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NPSACWS ! CHANGE N DROPLET ACCRETION BY SNOW
1057  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PSACWI ! CHANGE Q DROPLET ACCRETION BY CLOUD ICE
1058  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NPSACWI ! CHANGE N DROPLET ACCRETION BY CLOUD ICE
1059  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NPRCI ! CHANGE N AUTOCONVERSION CLOUD ICE BY SNOW
1060  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NPRAI ! CHANGE N ACCRETION CLOUD ICE
1061  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NMULTS ! ICE MULT DUE TO RIMING DROPLETS BY SNOW
1062  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NMULTR ! ICE MULT DUE TO RIMING RAIN BY SNOW
1063  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QMULTS ! CHANGE Q DUE TO ICE MULT DROPLETS/SNOW
1064  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QMULTR ! CHANGE Q DUE TO ICE RAIN/SNOW
1065  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PRACS ! CHANGE Q RAIN-SNOW COLLECTION
1066  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NPRACS ! CHANGE N RAIN-SNOW COLLECTION
1067  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PCCN ! CHANGE Q DROPLET ACTIVATION
1068  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PSMLT ! CHANGE Q MELTING SNOW TO RAIN
1069  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: EVPMS ! CHNAGE Q MELTING SNOW EVAPORATING
1070  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NSMLTS ! CHANGE N MELTING SNOW
1071  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NSMLTR ! CHANGE N MELTING SNOW TO RAIN
1072 ! HM ADDED 12/13/06
1073  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PIACR ! CHANGE QR, ICE-RAIN COLLECTION
1074  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NIACR ! CHANGE N, ICE-RAIN COLLECTION
1075  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PRACI ! CHANGE QI, ICE-RAIN COLLECTION
1076  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PIACRS ! CHANGE QR, ICE RAIN COLLISION, ADDED TO SNOW
1077  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NIACRS ! CHANGE N, ICE RAIN COLLISION, ADDED TO SNOW
1078  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PRACIS ! CHANGE QI, ICE RAIN COLLISION, ADDED TO SNOW
1079  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: EPRD ! SUBLIMATION CLOUD ICE
1080  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: EPRDS ! SUBLIMATION SNOW
1081 ! HM ADDED GRAUPEL PROCESSES
1082  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PRACG ! CHANGE IN Q COLLECTION RAIN BY GRAUPEL
1083  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PSACWG ! CHANGE IN Q COLLECTION DROPLETS BY GRAUPEL
1084  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PGSACW ! CONVERSION Q TO GRAUPEL DUE TO COLLECTION DROPLETS BY SNOW
1085  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PGRACS ! CONVERSION Q TO GRAUPEL DUE TO COLLECTION RAIN BY SNOW
1086  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PRDG ! DEP OF GRAUPEL
1087  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: EPRDG ! SUB OF GRAUPEL
1088  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: EVPMG ! CHANGE Q MELTING OF GRAUPEL AND EVAPORATION
1089  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PGMLT ! CHANGE Q MELTING OF GRAUPEL
1090  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NPRACG ! CHANGE N COLLECTION RAIN BY GRAUPEL
1091  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NPSACWG ! CHANGE N COLLECTION DROPLETS BY GRAUPEL
1092  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NSCNG ! CHANGE N CONVERSION TO GRAUPEL DUE TO COLLECTION DROPLETS BY SNOW
1093  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NGRACS ! CHANGE N CONVERSION TO GRAUPEL DUE TO COLLECTION RAIN BY SNOW
1094  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NGMLTG ! CHANGE N MELTING GRAUPEL
1095  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NGMLTR ! CHANGE N MELTING GRAUPEL TO RAIN
1096  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NSUBG ! CHANGE N SUB/DEP OF GRAUPEL
1097  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: PSACR ! CONVERSION DUE TO COLL OF SNOW BY RAIN
1098  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NMULTG ! ICE MULT DUE TO ACC DROPLETS BY GRAUPEL
1099  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NMULTRG ! ICE MULT DUE TO ACC RAIN BY GRAUPEL
1100  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QMULTG ! CHANGE Q DUE TO ICE MULT DROPLETS/GRAUPEL
1101  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QMULTRG ! CHANGE Q DUE TO ICE MULT RAIN/GRAUPEL
1102 
1103 ! TIME-VARYING ATMOSPHERIC PARAMETERS
1104 
1105  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: KAP ! THERMAL CONDUCTIVITY OF AIR
1106  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: EVS ! SATURATION VAPOR PRESSURE
1107  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: EIS ! ICE SATURATION VAPOR PRESSURE
1108  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QVS ! SATURATION MIXING RATIO
1109  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QVI ! ICE SATURATION MIXING RATIO
1110  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QVQVS ! SAUTRATION RATIO
1111  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: QVQVSI! ICE SATURAION RATIO
1112  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: DV ! DIFFUSIVITY OF WATER VAPOR IN AIR
1113  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: XXLS ! LATENT HEAT OF SUBLIMATION
1114  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: XXLV ! LATENT HEAT OF VAPORIZATION
1115  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: CPM ! SPECIFIC HEAT AT CONST PRESSURE FOR MOIST AIR
1116  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: MU ! VISCOCITY OF AIR
1117  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: SC ! SCHMIDT NUMBER
1118  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: XLF ! LATENT HEAT OF FREEZING
1119  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: RHO ! AIR DENSITY
1120  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: AB ! CORRECTION TO CONDENSATION RATE DUE TO LATENT HEATING
1121  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: ABI ! CORRECTION TO DEPOSITION RATE DUE TO LATENT HEATING
1122 
1123 ! TIME-VARYING MICROPHYSICS PARAMETERS
1124 
1125  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: DAP ! DIFFUSIVITY OF AEROSOL
1126  REAL(C_DOUBLE) NACNT ! NUMBER OF CONTACT IN
1127  REAL(C_DOUBLE) FMULT ! TEMP.-DEP. PARAMETER FOR RIME-SPLINTERING
1128  REAL(C_DOUBLE) COFFI ! ICE AUTOCONVERSION PARAMETER
1129 
1130 ! FALL SPEED WORKING VARIABLES (DEFINED IN CODE)
1131 
1132  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: DUMI,DUMR,DUMFNI,DUMG,DUMFNG
1133  REAL(C_DOUBLE) UNI, UMI,UMR
1134  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: FR, FI, FNI,FG,FNG
1135  REAL(C_DOUBLE) RGVM
1136  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: FALOUTR,FALOUTI,FALOUTNI
1137  REAL(C_DOUBLE) FALTNDR,FALTNDI,FALTNDNI,RHO2
1138  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: DUMQS,DUMFNS
1139  REAL(C_DOUBLE) UMS,UNS
1140  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: FS,FNS, FALOUTS,FALOUTNS,FALOUTG,FALOUTNG
1141  REAL(C_DOUBLE) FALTNDS,FALTNDNS,UNR,FALTNDG,FALTNDNG
1142  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: DUMC,DUMFNC
1143  REAL(C_DOUBLE) UNC,UMC,UNG,UMG
1144  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: FC,FALOUTC,FALOUTNC
1145  REAL(C_DOUBLE) FALTNDC,FALTNDNC
1146  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: FNC,DUMFNR,FALOUTNR
1147  REAL(C_DOUBLE) FALTNDNR
1148  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: FNR
1149 
1150 ! FALL-SPEED PARAMETER 'A' WITH AIR DENSITY CORRECTION
1151 
1152  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: AIN,ARN,ASN,ACN,AGN
1153 
1154 ! EXTERNAL FUNCTION CALL RETURN VARIABLES
1155 
1156 ! REAL(C_DOUBLE) GAMMA, ! EULER GAMMA FUNCTION
1157 ! REAL(C_DOUBLE) POLYSVP, ! SAT. PRESSURE FUNCTION
1158 ! REAL(C_DOUBLE) DERF1 ! ERROR FUNCTION
1159 
1160 ! DUMMY VARIABLES
1161 
1162  REAL(C_DOUBLE) DUM,DUM1,DUM2,DUMT,DUMQV,DUMQSS,DUMQSI,DUMS
1163 
1164 ! PROGNOSTIC SUPERSATURATION
1165 
1166  REAL(C_DOUBLE) DQSDT ! CHANGE OF SAT. MIX. RAT. WITH TEMPERATURE
1167  REAL(C_DOUBLE) DQSIDT ! CHANGE IN ICE SAT. MIXING RAT. WITH T
1168  REAL(C_DOUBLE) EPSI ! 1/PHASE REL. TIME (SEE M2005), ICE
1169  REAL(C_DOUBLE) EPSS ! 1/PHASE REL. TIME (SEE M2005), SNOW
1170  REAL(C_DOUBLE) EPSR ! 1/PHASE REL. TIME (SEE M2005), RAIN
1171  REAL(C_DOUBLE) EPSG ! 1/PHASE REL. TIME (SEE M2005), GRAUPEL
1172 
1173 ! NEW DROPLET ACTIVATION VARIABLES
1174  REAL(C_DOUBLE) TAUC ! PHASE REL. TIME (SEE M2005), DROPLETS
1175  REAL(C_DOUBLE) TAUR ! PHASE REL. TIME (SEE M2005), RAIN
1176  REAL(C_DOUBLE) TAUI ! PHASE REL. TIME (SEE M2005), CLOUD ICE
1177  REAL(C_DOUBLE) TAUS ! PHASE REL. TIME (SEE M2005), SNOW
1178  REAL(C_DOUBLE) TAUG ! PHASE REL. TIME (SEE M2005), GRAUPEL
1179  REAL(C_DOUBLE) DUMACT,DUM3
1180 
1181 ! COUNTING/INDEX VARIABLES
1182 
1183  INTEGER K,NSTEP,N ! ,I
1184 
1185 ! LTRUE IS ONLY USED TO SPEED UP THE CODE !!
1186 ! LTRUE, SWITCH = 0, NO HYDROMETEORS IN COLUMN,
1187 ! = 1, HYDROMETEORS IN COLUMN
1188 
1189  INTEGER LTRUE
1190 
1191 ! DROPLET ACTIVATION/FREEZING AEROSOL
1192 
1193 
1194  REAL(C_DOUBLE) CT ! DROPLET ACTIVATION PARAMETER
1195  REAL(C_DOUBLE) TEMP1 ! DUMMY TEMPERATURE
1196  REAL(C_DOUBLE) SAT1 ! DUMMY SATURATION
1197  REAL(C_DOUBLE) SIGVL ! SURFACE TENSION LIQ/VAPOR
1198  REAL(C_DOUBLE) KEL ! KELVIN PARAMETER
1199  REAL(C_DOUBLE) KC2 ! TOTAL ICE NUCLEATION RATE
1200 
1201  REAL(C_DOUBLE) CRY,KRY ! AEROSOL ACTIVATION PARAMETERS
1202 
1203 ! MORE WORKING/DUMMY VARIABLES
1204 
1205  REAL(C_DOUBLE) DUMQI,DUMNI,DC0,DS0,DG0
1206  REAL(C_DOUBLE) DUMQC,DUMQR,RATIO,SUM_DEP,FUDGEF
1207 
1208 ! EFFECTIVE VERTICAL VELOCITY (M/S)
1209  REAL(C_DOUBLE) WEF
1210 
1211 ! WORKING PARAMETERS FOR ICE NUCLEATION
1212 
1213  REAL(C_DOUBLE) ANUC,BNUC
1214 
1215 ! WORKING PARAMETERS FOR AEROSOL ACTIVATION
1216 
1217  REAL(C_DOUBLE) AACT,GAMM,GG,PSI,ETA1,ETA2,SM1,SM2,SMAX,UU1,UU2,ALPHA
1218 
1219 ! DUMMY SIZE DISTRIBUTION PARAMETERS
1220 
1221  REAL(C_DOUBLE) DLAMS,DLAMR,DLAMI,DLAMC,DLAMG,LAMMAX,LAMMIN
1222 
1223  INTEGER IDROP
1224 
1225 ! FOR WRF-CHEM
1226  REAL(C_DOUBLE), DIMENSION(KTS:KTE)::C2PREC,CSED,ISED,SSED,GSED,RSED
1227  REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: tqimelt ! melting of cloud ice (tendency)
1228 
1229 ! comment lines for wrf-chem since these are intent(in) in that case
1230 ! REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NC3DTEN ! CLOUD DROPLET NUMBER CONCENTRATION (1/KG/S)
1231 ! REAL(C_DOUBLE), DIMENSION(KTS:KTE) :: NC3D ! CLOUD DROPLET NUMBER CONCENTRATION (1/KG)
1232 
1233 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
1234 
1235  ! print *,'IN MICRO KTS:KTE ', i,j,kts, kte
1236 
1237 ! SET LTRUE INITIALLY TO 0
1238 
1239  ltrue = 0
1240 
1241 ! ATMOSPHERIC PARAMETERS THAT VARY IN TIME AND HEIGHT
1242  DO k = kts,kte
1243 
1244 ! NC3DTEN LOCAL ARRAY INITIALIZED
1245  nc3dten(k) = 0.
1246 ! INITIALIZE VARIABLES FOR WRF-CHEM OUTPUT TO ZERO
1247 
1248  c2prec(k)=0.
1249  csed(k)=0.
1250  ised(k)=0.
1251  ssed(k)=0.
1252  gsed(k)=0.
1253  rsed(k)=0.
1254 
1255 ! LATENT HEAT OF VAPORATION
1256 
1257  xxlv(k) = 3.1484e6-2370.*t3d(k)
1258 
1259 ! LATENT HEAT OF SUBLIMATION
1260 
1261  xxls(k) = 3.15e6-2370.*t3d(k)+0.3337e6
1262 
1263  cpm(k) = cp*(1.+0.887*qv3d(k))
1264 
1265 ! SATURATION VAPOR PRESSURE AND MIXING RATIO
1266 
1267 ! hm, add fix for low pressure, 5/12/10
1268 
1269  evs(k) = min(0.99*pres(k),polysvp(t3d(k),0)) ! PA
1270  eis(k) = min(0.99*pres(k),polysvp(t3d(k),1)) ! PA
1271 ! Fortran version
1272 ! MAKE SURE ICE SATURATION DOESN'T EXCEED WATER SAT. NEAR FREEZING
1273 
1274  IF (eis(k).GT.evs(k)) eis(k) = evs(k)
1275 
1276  qvs(k) = ep_2*evs(k)/(pres(k)-evs(k))
1277  qvi(k) = ep_2*eis(k)/(pres(k)-eis(k))
1278 
1279  qvqvs(k) = qv3d(k)/qvs(k)
1280  qvqvsi(k) = qv3d(k)/qvi(k)
1281 
1282 ! AIR DENSITY
1283 
1284  rho(k) = pres(k)/(r*t3d(k))
1285 
1286 ! ADD NUMBER CONCENTRATION DUE TO CUMULUS TENDENCY
1287 ! ASSUME N0 ASSOCIATED WITH CUMULUS PARAM RAIN IS 10^7 M^-4
1288 ! ASSUME N0 ASSOCIATED WITH CUMULUS PARAM SNOW IS 2 X 10^7 M^-4
1289 ! FOR DETRAINED CLOUD ICE, ASSUME MEAN VOLUME DIAM OF 80 MICRON
1290 
1291  IF (qrcu1d(k).GE.1.e-10) THEN
1292  dum=1.8e5*(qrcu1d(k)*dt/(pi*rhow*rho(k)**3))**0.25
1293  nr3d(k)=nr3d(k)+dum
1294  END IF
1295  IF (qscu1d(k).GE.1.e-10) THEN
1296  dum=3.e5*(qscu1d(k)*dt/(cons1*rho(k)**3))**(1./(ds+1.))
1297  ns3d(k)=ns3d(k)+dum
1298  END IF
1299  IF (qicu1d(k).GE.1.e-10) THEN
1300  dum=qicu1d(k)*dt/(ci*(80.e-6)**di)
1301  ni3d(k)=ni3d(k)+dum
1302  END IF
1303 
1304 ! AT SUBSATURATION, REMOVE SMALL AMOUNTS OF CLOUD/PRECIP WATER
1305 ! hm modify 7/0/09 change limit to 1.e-8
1306 
1307  IF (qvqvs(k).LT.0.9) THEN
1308  IF (qr3d(k).LT.1.e-8) THEN
1309  qv3d(k)=qv3d(k)+qr3d(k)
1310  t3d(k)=t3d(k)-qr3d(k)*xxlv(k)/cpm(k)
1311  qr3d(k)=0.
1312  END IF
1313  IF (qc3d(k).LT.1.e-8) THEN
1314  qv3d(k)=qv3d(k)+qc3d(k)
1315  t3d(k)=t3d(k)-qc3d(k)*xxlv(k)/cpm(k)
1316  qc3d(k)=0.
1317  END IF
1318  END IF
1319 ! Fortran version
1320  IF (qvqvsi(k).LT.0.9) THEN
1321  IF (qi3d(k).LT.1.e-8) THEN
1322  qv3d(k)=qv3d(k)+qi3d(k)
1323  t3d(k)=t3d(k)-qi3d(k)*xxls(k)/cpm(k)
1324  qi3d(k)=0.
1325  END IF
1326  IF (qni3d(k).LT.1.e-8) THEN
1327  qv3d(k)=qv3d(k)+qni3d(k)
1328  t3d(k)=t3d(k)-qni3d(k)*xxls(k)/cpm(k)
1329  qni3d(k)=0.
1330  END IF
1331  IF (qg3d(k).LT.1.e-8) THEN
1332  qv3d(k)=qv3d(k)+qg3d(k)
1333  t3d(k)=t3d(k)-qg3d(k)*xxls(k)/cpm(k)
1334  qg3d(k)=0.
1335  END IF
1336  END IF
1337  ! Fortran version
1338 ! HEAT OF FUSION
1339 
1340  xlf(k) = xxls(k)-xxlv(k)
1341 
1342 !..................................................................
1343 ! IF MIXING RATIO < QSMALL SET MIXING RATIO AND NUMBER CONC TO ZERO
1344 
1345  IF (qc3d(k).LT.qsmall) THEN
1346  qc3d(k) = 0.
1347  nc3d(k) = 0.
1348  effc(k) = 0.
1349  END IF
1350  IF (qr3d(k).LT.qsmall) THEN
1351  qr3d(k) = 0.
1352  nr3d(k) = 0.
1353  effr(k) = 0.
1354  END IF
1355  IF (qi3d(k).LT.qsmall) THEN
1356  qi3d(k) = 0.
1357  ni3d(k) = 0.
1358  effi(k) = 0.
1359  END IF
1360  IF (qni3d(k).LT.qsmall) THEN
1361  qni3d(k) = 0.
1362  ns3d(k) = 0.
1363  effs(k) = 0.
1364  END IF
1365  IF (qg3d(k).LT.qsmall) THEN
1366  qg3d(k) = 0.
1367  ng3d(k) = 0.
1368  effg(k) = 0.
1369  END IF
1370 ! Fortran version
1371 ! INITIALIZE SEDIMENTATION TENDENCIES FOR MIXING RATIO
1372 
1373  qrsten(k) = 0.
1374  qisten(k) = 0.
1375  qnisten(k) = 0.
1376  qcsten(k) = 0.
1377  qgsten(k) = 0.
1378 
1379 !..................................................................
1380 ! MICROPHYSICS PARAMETERS VARYING IN TIME/HEIGHT
1381 
1382 ! fix 053011
1383  mu(k) = 1.496e-6*t3d(k)**1.5/(t3d(k)+120.)
1384 
1385 ! FALL SPEED WITH DENSITY CORRECTION (HEYMSFIELD AND BENSSEMER 2006)
1386 
1387  dum = (rhosu/rho(k))**0.54
1388 
1389 ! fix 053011
1390 ! AIN(K) = DUM*AI
1391 ! AA revision 4/1/11: Ikawa and Saito 1991 air-density correction
1392  ain(k) = (rhosu/rho(k))**0.35*ai
1393  arn(k) = dum*ar
1394  asn(k) = dum*as
1395 ! ACN(K) = DUM*AC
1396 ! AA revision 4/1/11: temperature-dependent Stokes fall speed
1397  acn(k) = g*rhow/(18.*mu(k))
1398 ! HM ADD GRAUPEL 8/28/06
1399  agn(k) = dum*ag
1400 !hm 4/7/09 bug fix, initialize lami to prevent later division by zero
1401  lami(k)=0.
1402 
1403 !..................................
1404 ! IF THERE IS NO CLOUD/PRECIP WATER, AND IF SUBSATURATED, THEN SKIP MICROPHYSICS
1405 ! FOR THIS LEVEL
1406 
1407  IF ( qc3d(k).LT.qsmall.AND. &
1408  qi3d(k).LT.qsmall.AND. &
1409  qni3d(k).LT.qsmall.AND. &
1410  qr3d(k).LT.qsmall.AND. &
1411  qg3d(k).LT.qsmall) THEN
1412  IF (t3d(k).LT.273.15.AND.qvqvsi(k).LT.0.999) then
1413  GOTO 200
1414  endif
1415  IF (t3d(k).GE.273.15.AND.qvqvs(k).LT.0.999) then
1416  GOTO 200
1417  endif
1418  END IF
1419 
1420 ! THERMAL CONDUCTIVITY FOR AIR
1421 
1422 ! fix 053011
1423  kap(k) = 1.414e3*mu(k)
1424 
1425 ! DIFFUSIVITY OF WATER VAPOR
1426 
1427  dv(k) = 8.794e-5*t3d(k)**1.81/pres(k)
1428 
1429 ! SCHMIT NUMBER
1430 
1431 ! fix 053011
1432  sc(k) = mu(k)/(rho(k)*dv(k))
1433 
1434 ! PSYCHOMETIC CORRECTIONS
1435 
1436 ! RATE OF CHANGE SAT. MIX. RATIO WITH TEMPERATURE
1437 
1438  dum = (rv*t3d(k)**2)
1439 
1440  dqsdt = xxlv(k)*qvs(k)/dum
1441  dqsidt = xxls(k)*qvi(k)/dum
1442 
1443  abi(k) = 1.+dqsidt*xxls(k)/cpm(k)
1444  ab(k) = 1.+dqsdt*xxlv(k)/cpm(k)
1445 !
1446 !.....................................................................
1447 !.....................................................................
1448 ! CASE FOR TEMPERATURE ABOVE FREEZING
1449 
1450  IF (t3d(k).GE.273.15) THEN
1451 
1452 !......................................................................
1453 !HM ADD, ALLOW FOR CONSTANT DROPLET NUMBER
1454 ! INUM = 0, PREDICT DROPLET NUMBER
1455 ! INUM = 1, SET CONSTANT DROPLET NUMBER
1456 
1457  IF (iinum.EQ.1) THEN
1458 ! CONVERT NDCNST FROM CM-3 TO KG-1
1459  nc3d(k)=ndcnst*1.e6/rho(k)
1460  END IF
1461 
1462 ! GET SIZE DISTRIBUTION PARAMETERS
1463 
1464 ! MELT VERY SMALL SNOW AND GRAUPEL MIXING RATIOS, ADD TO RAIN
1465  IF (qni3d(k).LT.1.e-6) THEN
1466  qr3d(k)=qr3d(k)+qni3d(k)
1467  nr3d(k)=nr3d(k)+ns3d(k)
1468  t3d(k)=t3d(k)-qni3d(k)*xlf(k)/cpm(k)
1469  qni3d(k) = 0.
1470  ns3d(k) = 0.
1471  END IF
1472  IF (qg3d(k).LT.1.e-6) THEN
1473  qr3d(k)=qr3d(k)+qg3d(k)
1474  nr3d(k)=nr3d(k)+ng3d(k)
1475  t3d(k)=t3d(k)-qg3d(k)*xlf(k)/cpm(k)
1476  qg3d(k) = 0.
1477  ng3d(k) = 0.
1478  END IF
1479  IF (qc3d(k).LT.qsmall.AND.qni3d(k).LT.1.e-8.AND.qr3d(k).LT.qsmall.AND.qg3d(k).LT.1.e-8) THEN
1480  GOTO 300
1481  ENDIF
1482 
1483 ! MAKE SURE NUMBER CONCENTRATIONS AREN'T NEGATIVE
1484 
1485  ns3d(k) = max(0.,ns3d(k))
1486  nc3d(k) = max(0.,nc3d(k))
1487  nr3d(k) = max(0.,nr3d(k))
1488  ng3d(k) = max(0.,ng3d(k))
1489 
1490 !......................................................................
1491 ! RAIN
1492 
1493  IF (qr3d(k).GE.qsmall) THEN
1494  lamr(k) = (pi*rhow*nr3d(k)/qr3d(k))**(1./3.)
1495  n0rr(k) = nr3d(k)*lamr(k)
1496 
1497 ! CHECK FOR SLOPE
1498 
1499 ! ADJUST VARS
1500 
1501  IF (lamr(k).LT.lamminr) THEN
1502 
1503  lamr(k) = lamminr
1504 
1505  n0rr(k) = lamr(k)**4*qr3d(k)/(pi*rhow)
1506 
1507  nr3d(k) = n0rr(k)/lamr(k)
1508  ELSE IF (lamr(k).GT.lammaxr) THEN
1509  lamr(k) = lammaxr
1510  n0rr(k) = lamr(k)**4*qr3d(k)/(pi*rhow)
1511 
1512  nr3d(k) = n0rr(k)/lamr(k)
1513  END IF
1514  END IF
1515 
1516 !......................................................................
1517 ! CLOUD DROPLETS
1518 
1519 ! MARTIN ET AL. (1994) FORMULA FOR PGAM
1520 
1521  IF (qc3d(k).GE.qsmall) THEN
1522 
1523  dum = pres(k)/(287.15*t3d(k))
1524  pgam(k)=0.0005714*(nc3d(k)/1.e6*dum)+0.2714
1525  pgam(k)=1./(pgam(k)**2)-1.
1526  pgam(k)=max(pgam(k),2.)
1527  pgam(k)=min(pgam(k),10.)
1528 
1529 ! CALCULATE LAMC
1530 
1531  lamc(k) = (cons26*nc3d(k)*gamma(pgam(k)+4.)/ &
1532  (qc3d(k)*gamma(pgam(k)+1.)))**(1./3.)
1533 
1534 ! LAMMIN, 60 MICRON DIAMETER
1535 ! LAMMAX, 1 MICRON
1536 
1537  lammin = (pgam(k)+1.)/60.e-6
1538  lammax = (pgam(k)+1.)/1.e-6
1539 
1540  IF (lamc(k).LT.lammin) THEN
1541  lamc(k) = lammin
1542 
1543  nc3d(k) = exp(3.*log(lamc(k))+log(qc3d(k))+ &
1544  log(gamma(pgam(k)+1.))-log(gamma(pgam(k)+4.)))/cons26
1545  ELSE IF (lamc(k).GT.lammax) THEN
1546  lamc(k) = lammax
1547 
1548  nc3d(k) = exp(3.*log(lamc(k))+log(qc3d(k))+ &
1549  log(gamma(pgam(k)+1.))-log(gamma(pgam(k)+4.)))/cons26
1550 
1551  END IF
1552 
1553  END IF
1554 
1555 !......................................................................
1556 ! SNOW
1557 
1558  IF (qni3d(k).GE.qsmall) THEN
1559  lams(k) = (cons1*ns3d(k)/qni3d(k))**(1./ds)
1560  n0s(k) = ns3d(k)*lams(k)
1561 
1562 ! CHECK FOR SLOPE
1563 
1564 ! ADJUST VARS
1565 
1566  IF (lams(k).LT.lammins) THEN
1567  lams(k) = lammins
1568  n0s(k) = lams(k)**4*qni3d(k)/cons1
1569 
1570  ns3d(k) = n0s(k)/lams(k)
1571 
1572  ELSE IF (lams(k).GT.lammaxs) THEN
1573 
1574  lams(k) = lammaxs
1575  n0s(k) = lams(k)**4*qni3d(k)/cons1
1576 
1577  ns3d(k) = n0s(k)/lams(k)
1578  END IF
1579  END IF
1580 
1581 !......................................................................
1582 ! GRAUPEL
1583 
1584  IF (qg3d(k).GE.qsmall) THEN
1585  lamg(k) = (cons2*ng3d(k)/qg3d(k))**(1./dg)
1586  n0g(k) = ng3d(k)*lamg(k)
1587 
1588 ! ADJUST VARS
1589 
1590  IF (lamg(k).LT.lamming) THEN
1591  lamg(k) = lamming
1592  n0g(k) = lamg(k)**4*qg3d(k)/cons2
1593 
1594  ng3d(k) = n0g(k)/lamg(k)
1595 
1596  ELSE IF (lamg(k).GT.lammaxg) THEN
1597 
1598  lamg(k) = lammaxg
1599  n0g(k) = lamg(k)**4*qg3d(k)/cons2
1600 
1601  ng3d(k) = n0g(k)/lamg(k)
1602  END IF
1603  END IF
1604 !.....................................................................
1605 ! ZERO OUT PROCESS RATES
1606 
1607  prc(k) = 0.
1608  nprc(k) = 0.
1609  nprc1(k) = 0.
1610  pra(k) = 0.
1611  npra(k) = 0.
1612  nragg(k) = 0.
1613  nsmlts(k) = 0.
1614  nsmltr(k) = 0.
1615  evpms(k) = 0.
1616  pcc(k) = 0.
1617  pre(k) = 0.
1618  nsubc(k) = 0.
1619  nsubr(k) = 0.
1620  pracg(k) = 0.
1621  npracg(k) = 0.
1622  psmlt(k) = 0.
1623  pgmlt(k) = 0.
1624  evpmg(k) = 0.
1625  pracs(k) = 0.
1626  npracs(k) = 0.
1627  ngmltg(k) = 0.
1628  ngmltr(k) = 0.
1629 
1630 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
1631 ! CALCULATION OF MICROPHYSICAL PROCESS RATES, T > 273.15 K
1632 
1633 !.................................................................
1634 !.......................................................................
1635 ! AUTOCONVERSION OF CLOUD LIQUID WATER TO RAIN
1636 ! FORMULA FROM BEHENG (1994)
1637 ! USING NUMERICAL SIMULATION OF STOCHASTIC COLLECTION EQUATION
1638 ! AND INITIAL CLOUD DROPLET SIZE DISTRIBUTION SPECIFIED
1639 ! AS A GAMMA DISTRIBUTION
1640 
1641 ! USE MINIMUM VALUE OF 1.E-6 TO PREVENT FLOATING POINT ERROR
1642 
1643  IF (qc3d(k).GE.1.e-6) THEN
1644 
1645 ! HM ADD 12/13/06, REPLACE WITH NEWER FORMULA
1646 ! FROM KHAIROUTDINOV AND KOGAN 2000, MWR
1647 
1648  prc(k)=1350.*qc3d(k)**2.47* &
1649  (nc3d(k)/1.e6*rho(k))**(-1.79)
1650 
1651 ! note: nprc1 is change in Nr,
1652 ! nprc is change in Nc
1653 
1654  nprc1(k) = prc(k)/cons29
1655  nprc(k) = prc(k)/(qc3d(k)/nc3d(k))
1656 
1657 ! hm bug fix 3/20/12
1658  nprc(k) = min(nprc(k),nc3d(k)/dt)
1659  nprc1(k) = min(nprc1(k),nprc(k))
1660 
1661  END IF
1662 
1663 !.......................................................................
1664 ! HM ADD 12/13/06, COLLECTION OF SNOW BY RAIN ABOVE FREEZING
1665 ! FORMULA FROM IKAWA AND SAITO (1991)
1666 
1667  IF (qr3d(k).GE.1.e-8.AND.qni3d(k).GE.1.e-8) THEN
1668 
1669  ums = asn(k)*cons3/(lams(k)**bs)
1670  umr = arn(k)*cons4/(lamr(k)**br)
1671  uns = asn(k)*cons5/lams(k)**bs
1672  unr = arn(k)*cons6/lamr(k)**br
1673 
1674 ! SET REASLISTIC LIMITS ON FALLSPEEDS
1675 
1676 ! bug fix, 10/08/09
1677  dum=(rhosu/rho(k))**0.54
1678  ums=min(ums,1.2*dum)
1679  uns=min(uns,1.2*dum)
1680  umr=min(umr,9.1*dum)
1681  unr=min(unr,9.1*dum)
1682 
1683 ! hm fix, 2/12/13
1684 ! for above freezing conditions to get accelerated melting of snow,
1685 ! we need collection of rain by snow (following Lin et al. 1983)
1686 ! PRACS(K) = CONS31*(((1.2*UMR-0.95*UMS)**2+ &
1687 ! 0.08*UMS*UMR)**0.5*RHO(K)* &
1688 ! N0RR(K)*N0S(K)/LAMS(K)**3* &
1689 ! (5./(LAMS(K)**3*LAMR(K))+ &
1690 ! 2./(LAMS(K)**2*LAMR(K)**2)+ &
1691 ! 0.5/(LAMS(K)*LAMR(K)**3)))
1692 
1693  pracs(k) = cons41*(((1.2*umr-0.95*ums)**2+ &
1694  0.08*ums*umr)**0.5*rho(k)* &
1695  n0rr(k)*n0s(k)/lamr(k)**3* &
1696  (5./(lamr(k)**3*lams(k))+ &
1697  2./(lamr(k)**2*lams(k)**2)+ &
1698  0.5/(lamr(k)*lams(k)**3)))
1699 
1700 ! fix 053011, npracs no longer subtracted from snow
1701 ! NPRACS(K) = CONS32*RHO(K)*(1.7*(UNR-UNS)**2+ &
1702 ! 0.3*UNR*UNS)**0.5*N0RR(K)*N0S(K)* &
1703 ! (1./(LAMR(K)**3*LAMS(K))+ &
1704 ! 1./(LAMR(K)**2*LAMS(K)**2)+ &
1705 ! 1./(LAMR(K)*LAMS(K)**3))
1706 
1707  END IF
1708 
1709 ! ADD COLLECTION OF GRAUPEL BY RAIN ABOVE FREEZING
1710 ! ASSUME ALL RAIN COLLECTION BY GRAUPEL ABOVE FREEZING IS SHED
1711 ! ASSUME SHED DROPS ARE 1 MM IN SIZE
1712 
1713  IF (qr3d(k).GE.1.e-8.AND.qg3d(k).GE.1.e-8) THEN
1714 
1715  umg = agn(k)*cons7/(lamg(k)**bg)
1716  umr = arn(k)*cons4/(lamr(k)**br)
1717  ung = agn(k)*cons8/lamg(k)**bg
1718  unr = arn(k)*cons6/lamr(k)**br
1719 
1720 ! SET REASLISTIC LIMITS ON FALLSPEEDS
1721 ! bug fix, 10/08/09
1722  dum=(rhosu/rho(k))**0.54
1723  umg=min(umg,20.*dum)
1724  ung=min(ung,20.*dum)
1725  umr=min(umr,9.1*dum)
1726  unr=min(unr,9.1*dum)
1727 
1728 ! PRACG IS MIXING RATIO OF RAIN PER SEC COLLECTED BY GRAUPEL/HAIL
1729  pracg(k) = cons41*(((1.2*umr-0.95*umg)**2+ &
1730  0.08*umg*umr)**0.5*rho(k)* &
1731  n0rr(k)*n0g(k)/lamr(k)**3* &
1732  (5./(lamr(k)**3*lamg(k))+ &
1733  2./(lamr(k)**2*lamg(k)**2)+ &
1734  0.5/(lamr(k)*lamg(k)**3)))
1735 
1736 ! ASSUME 1 MM DROPS ARE SHED, GET NUMBER SHED PER SEC
1737 
1738  dum = pracg(k)/5.2e-7
1739 
1740  npracg(k) = cons32*rho(k)*(1.7*(unr-ung)**2+ &
1741  0.3*unr*ung)**0.5*n0rr(k)*n0g(k)* &
1742  (1./(lamr(k)**3*lamg(k))+ &
1743  1./(lamr(k)**2*lamg(k)**2)+ &
1744  1./(lamr(k)*lamg(k)**3))
1745 
1746 ! hm 7/15/13, remove limit so that the number of collected drops can smaller than
1747 ! number of shed drops
1748 ! NPRACG(K)=MAX(NPRACG(K)-DUM,0.)
1749  npracg(k)=npracg(k)-dum
1750 
1751  END IF
1752 
1753 !.......................................................................
1754 ! ACCRETION OF CLOUD LIQUID WATER BY RAIN
1755 ! CONTINUOUS COLLECTION EQUATION WITH
1756 ! GRAVITATIONAL COLLECTION KERNEL, DROPLET FALL SPEED NEGLECTED
1757 
1758  IF (qr3d(k).GE.1.e-8 .AND. qc3d(k).GE.1.e-8) THEN
1759 
1760 ! 12/13/06 HM ADD, REPLACE WITH NEWER FORMULA FROM
1761 ! KHAIROUTDINOV AND KOGAN 2000, MWR
1762 
1763  dum=(qc3d(k)*qr3d(k))
1764  pra(k) = 67.*(dum)**1.15
1765  npra(k) = pra(k)/(qc3d(k)/nc3d(k))
1766 
1767  END IF
1768 !.......................................................................
1769 ! SELF-COLLECTION OF RAIN DROPS
1770 ! FROM BEHENG(1994)
1771 ! FROM NUMERICAL SIMULATION OF THE STOCHASTIC COLLECTION EQUATION
1772 ! AS DESCRINED ABOVE FOR AUTOCONVERSION
1773 
1774  IF (qr3d(k).GE.1.e-8) THEN
1775 ! include breakup add 10/09/09
1776  dum1=300.e-6
1777  if (1./lamr(k).lt.dum1) then
1778  dum=1.
1779  else if (1./lamr(k).ge.dum1) then
1780  dum=2.-exp(2300.*(1./lamr(k)-dum1))
1781  end if
1782 ! NRAGG(K) = -8.*NR3D(K)*QR3D(K)*RHO(K)
1783  nragg(k) = -5.78*dum*nr3d(k)*qr3d(k)*rho(k)
1784  END IF
1785 
1786 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
1787 ! CALCULATE EVAP OF RAIN (RUTLEDGE AND HOBBS 1983)
1788 
1789  IF (qr3d(k).GE.qsmall) THEN
1790  epsr = 2.*pi*n0rr(k)*rho(k)*dv(k)* &
1791  (f1r/(lamr(k)*lamr(k))+ &
1792  f2r*(arn(k)*rho(k)/mu(k))**0.5* &
1793  sc(k)**(1./3.)*cons9/ &
1794  (lamr(k)**cons34))
1795  ELSE
1796  epsr = 0.
1797  END IF
1798 ! NO CONDENSATION ONTO RAIN, ONLY EVAP ALLOWED
1799 
1800  IF (qv3d(k).LT.qvs(k)) THEN
1801  pre(k) = epsr*(qv3d(k)-qvs(k))/ab(k)
1802  pre(k) = min(pre(k),0.)
1803  ELSE
1804  pre(k) = 0.
1805  END IF
1806 !.......................................................................
1807 ! MELTING OF SNOW
1808 
1809 ! SNOW MAY PERSITS ABOVE FREEZING, FORMULA FROM RUTLEDGE AND HOBBS, 1984
1810 ! IF WATER SUPERSATURATION, SNOW MELTS TO FORM RAIN
1811 
1812  IF (qni3d(k).GE.1.e-8) THEN
1813 
1814 ! fix 053011
1815 ! HM, MODIFY FOR V3.2, ADD ACCELERATED MELTING DUE TO COLLISION WITH RAIN
1816 ! DUM = -CPW/XLF(K)*T3D(K)*PRACS(K)
1817  dum = -cpw/xlf(k)*(t3d(k)-273.15)*pracs(k)
1818 
1819 ! hm fix 1/20/15
1820 ! PSMLT(K)=2.*PI*N0S(K)*KAP(K)*(273.15-T3D(K))/ &
1821 ! XLF(K)*RHO(K)*(F1S/(LAMS(K)*LAMS(K))+ &
1822 ! F2S*(ASN(K)*RHO(K)/MU(K))**0.5* &
1823 ! SC(K)**(1./3.)*CONS10/ &
1824 ! (LAMS(K)**CONS35))+DUM
1825  psmlt(k)=2.*pi*n0s(k)*kap(k)*(273.15-t3d(k))/ &
1826  xlf(k)*(f1s/(lams(k)*lams(k))+ &
1827  f2s*(asn(k)*rho(k)/mu(k))**0.5* &
1828  sc(k)**(1./3.)*cons10/ &
1829  (lams(k)**cons35))+dum
1830 
1831 ! IN WATER SUBSATURATION, SNOW MELTS AND EVAPORATES
1832 
1833  IF (qvqvs(k).LT.1.) THEN
1834  epss = 2.*pi*n0s(k)*rho(k)*dv(k)* &
1835  (f1s/(lams(k)*lams(k))+ &
1836  f2s*(asn(k)*rho(k)/mu(k))**0.5* &
1837  sc(k)**(1./3.)*cons10/ &
1838  (lams(k)**cons35))
1839 ! hm fix 8/4/08
1840  evpms(k) = (qv3d(k)-qvs(k))*epss/ab(k)
1841  evpms(k) = max(evpms(k),psmlt(k))
1842  psmlt(k) = psmlt(k)-evpms(k)
1843  END IF
1844  END IF
1845 
1846 !.......................................................................
1847 ! MELTING OF GRAUPEL
1848 
1849 ! GRAUPEL MAY PERSITS ABOVE FREEZING, FORMULA FROM RUTLEDGE AND HOBBS, 1984
1850 ! IF WATER SUPERSATURATION, GRAUPEL MELTS TO FORM RAIN
1851 
1852  IF (qg3d(k).GE.1.e-8) THEN
1853 
1854 ! fix 053011
1855 ! HM, MODIFY FOR V3.2, ADD ACCELERATED MELTING DUE TO COLLISION WITH RAIN
1856 ! DUM = -CPW/XLF(K)*T3D(K)*PRACG(K)
1857  dum = -cpw/xlf(k)*(t3d(k)-273.15)*pracg(k)
1858 
1859 ! hm fix 1/20/15
1860 ! PGMLT(K)=2.*PI*N0G(K)*KAP(K)*(273.15-T3D(K))/ &
1861 ! XLF(K)*RHO(K)*(F1S/(LAMG(K)*LAMG(K))+ &
1862 ! F2S*(AGN(K)*RHO(K)/MU(K))**0.5* &
1863 ! SC(K)**(1./3.)*CONS11/ &
1864 ! (LAMG(K)**CONS36))+DUM
1865  pgmlt(k)=2.*pi*n0g(k)*kap(k)*(273.15-t3d(k))/ &
1866  xlf(k)*(f1s/(lamg(k)*lamg(k))+ &
1867  f2s*(agn(k)*rho(k)/mu(k))**0.5* &
1868  sc(k)**(1./3.)*cons11/ &
1869  (lamg(k)**cons36))+dum
1870 
1871 ! IN WATER SUBSATURATION, GRAUPEL MELTS AND EVAPORATES
1872 
1873  IF (qvqvs(k).LT.1.) THEN
1874  epsg = 2.*pi*n0g(k)*rho(k)*dv(k)* &
1875  (f1s/(lamg(k)*lamg(k))+ &
1876  f2s*(agn(k)*rho(k)/mu(k))**0.5* &
1877  sc(k)**(1./3.)*cons11/ &
1878  (lamg(k)**cons36))
1879 ! hm fix 8/4/08
1880  evpmg(k) = (qv3d(k)-qvs(k))*epsg/ab(k)
1881  evpmg(k) = max(evpmg(k),pgmlt(k))
1882  pgmlt(k) = pgmlt(k)-evpmg(k)
1883  END IF
1884  END IF
1885 
1886 ! HM, V3.2
1887 ! RESET PRACG AND PRACS TO ZERO, THIS IS DONE BECAUSE THERE IS NO
1888 ! TRANSFER OF MASS FROM SNOW AND GRAUPEL TO RAIN DIRECTLY FROM COLLECTION
1889 ! ABOVE FREEZING, IT IS ONLY USED FOR ENHANCEMENT OF MELTING AND SHEDDING
1890 
1891  pracg(k) = 0.
1892  pracs(k) = 0.
1893 
1894 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
1895 
1896 ! FOR CLOUD ICE, ONLY PROCESSES OPERATING AT T > 273.15 IS
1897 ! MELTING, WHICH IS ALREADY CONSERVED DURING PROCESS
1898 ! CALCULATION
1899 
1900 ! CONSERVATION OF QC
1901 
1902  dum = (prc(k)+pra(k))*dt
1903 
1904  IF (dum.GT.qc3d(k).AND.qc3d(k).GE.qsmall) THEN
1905 
1906  ratio = qc3d(k)/dum
1907 
1908  prc(k) = prc(k)*ratio
1909  pra(k) = pra(k)*ratio
1910 
1911  END IF
1912 
1913 ! CONSERVATION OF SNOW
1914 
1915  dum = (-psmlt(k)-evpms(k)+pracs(k))*dt
1916 
1917  IF (dum.GT.qni3d(k).AND.qni3d(k).GE.qsmall) THEN
1918 
1919 ! NO SOURCE TERMS FOR SNOW AT T > FREEZING
1920  ratio = qni3d(k)/dum
1921 
1922  psmlt(k) = psmlt(k)*ratio
1923  evpms(k) = evpms(k)*ratio
1924  pracs(k) = pracs(k)*ratio
1925 
1926  END IF
1927 
1928 ! CONSERVATION OF GRAUPEL
1929 
1930  dum = (-pgmlt(k)-evpmg(k)+pracg(k))*dt
1931 
1932  IF (dum.GT.qg3d(k).AND.qg3d(k).GE.qsmall) THEN
1933 
1934 ! NO SOURCE TERM FOR GRAUPEL ABOVE FREEZING
1935  ratio = qg3d(k)/dum
1936 
1937  pgmlt(k) = pgmlt(k)*ratio
1938  evpmg(k) = evpmg(k)*ratio
1939  pracg(k) = pracg(k)*ratio
1940 
1941  END IF
1942 
1943 ! CONSERVATION OF QR
1944 ! HM 12/13/06, ADDED CONSERVATION OF RAIN SINCE PRE IS NEGATIVE
1945 
1946  dum = (-pracs(k)-pracg(k)-pre(k)-pra(k)-prc(k)+psmlt(k)+pgmlt(k))*dt
1947 
1948  IF (dum.GT.qr3d(k).AND.qr3d(k).GE.qsmall) THEN
1949 
1950  ratio = (qr3d(k)/dt+pracs(k)+pracg(k)+pra(k)+prc(k)-psmlt(k)-pgmlt(k))/ &
1951  (-pre(k))
1952  pre(k) = pre(k)*ratio
1953  END IF
1954 
1955 !....................................
1956 
1957  qv3dten(k) = qv3dten(k)+(-pre(k)-evpms(k)-evpmg(k))
1958 
1959  t3dten(k) = t3dten(k)+(pre(k)*xxlv(k)+(evpms(k)+evpmg(k))*xxls(k)+&
1960  (psmlt(k)+pgmlt(k)-pracs(k)-pracg(k))*xlf(k))/cpm(k)
1961 
1962  qc3dten(k) = qc3dten(k)+(-pra(k)-prc(k))
1963  qr3dten(k) = qr3dten(k)+(pre(k)+pra(k)+prc(k)-psmlt(k)-pgmlt(k)+pracs(k)+pracg(k))
1964  qni3dten(k) = qni3dten(k)+(psmlt(k)+evpms(k)-pracs(k))
1965  qg3dten(k) = qg3dten(k)+(pgmlt(k)+evpmg(k)-pracg(k))
1966 ! fix 053011
1967 ! NS3DTEN(K) = NS3DTEN(K)-NPRACS(K)
1968 ! HM, bug fix 5/12/08, npracg is subtracted from nr not ng
1969 ! NG3DTEN(K) = NG3DTEN(K)
1970  nc3dten(k) = nc3dten(k)+ (-npra(k)-nprc(k))
1971  nr3dten(k) = nr3dten(k)+ (nprc1(k)+nragg(k)-npracg(k))
1972 ! Fortran version
1973 ! HM ADD, WRF-CHEM, ADD TENDENCIES FOR C2PREC
1974 
1975  c2prec(k) = pra(k)+prc(k)
1976  IF (pre(k).LT.0.) THEN
1977  dum = pre(k)*dt/qr3d(k)
1978  dum = max(-1.,dum)
1979  nsubr(k) = dum*nr3d(k)/dt
1980  END IF
1981 
1982  IF (evpms(k)+psmlt(k).LT.0.) THEN
1983  dum = (evpms(k)+psmlt(k))*dt/qni3d(k)
1984  dum = max(-1.,dum)
1985  nsmlts(k) = dum*ns3d(k)/dt
1986  END IF
1987  IF (psmlt(k).LT.0.) THEN
1988  dum = psmlt(k)*dt/qni3d(k)
1989  dum = max(-1.0,dum)
1990  nsmltr(k) = dum*ns3d(k)/dt
1991  END IF
1992  IF (evpmg(k)+pgmlt(k).LT.0.) THEN
1993  dum = (evpmg(k)+pgmlt(k))*dt/qg3d(k)
1994  dum = max(-1.,dum)
1995  ngmltg(k) = dum*ng3d(k)/dt
1996  END IF
1997  IF (pgmlt(k).LT.0.) THEN
1998  dum = pgmlt(k)*dt/qg3d(k)
1999  dum = max(-1.0,dum)
2000  ngmltr(k) = dum*ng3d(k)/dt
2001  END IF
2002 
2003  ns3dten(k) = ns3dten(k)+(nsmlts(k))
2004  ng3dten(k) = ng3dten(k)+(ngmltg(k))
2005  nr3dten(k) = nr3dten(k)+(nsubr(k)-nsmltr(k)-ngmltr(k))
2006 
2007  300 CONTINUE
2008 
2009 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2010 ! NOW CALCULATE SATURATION ADJUSTMENT TO CONDENSE EXTRA VAPOR ABOVE
2011 ! WATER SATURATION
2012 
2013  dumt = t3d(k)+dt*t3dten(k)
2014  dumqv = qv3d(k)+dt*qv3dten(k)
2015 ! hm, add fix for low pressure, 5/12/10
2016  dum=min(0.99*pres(k),polysvp(dumt,0))
2017  dumqss = ep_2*dum/(pres(k)-dum)
2018  dumqc = qc3d(k)+dt*qc3dten(k)
2019  dumqc = max(dumqc,0.)
2020 
2021 ! SATURATION ADJUSTMENT FOR LIQUID
2022 
2023  dums = dumqv-dumqss
2024  pcc(k) = dums/(1.+xxlv(k)**2*dumqss/(cpm(k)*rv*dumt**2))/dt
2025  IF (pcc(k)*dt+dumqc.LT.0.) THEN
2026  pcc(k) = -dumqc/dt
2027  END IF
2028 
2029  qv3dten(k) = qv3dten(k)-pcc(k)
2030  t3dten(k) = t3dten(k)+pcc(k)*xxlv(k)/cpm(k)
2031  qc3dten(k) = qc3dten(k)+pcc(k)
2032 !.......................................................................
2033 ! ACTIVATION OF CLOUD DROPLETS
2034 ! ACTIVATION OF DROPLET CURRENTLY NOT CALCULATED
2035 ! DROPLET CONCENTRATION IS SPECIFIED !!!!!
2036 
2037 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2038 ! SUBLIMATE, MELT, OR EVAPORATE NUMBER CONCENTRATION
2039 ! THIS FORMULATION ASSUMES 1:1 RATIO BETWEEN MASS LOSS AND
2040 ! LOSS OF NUMBER CONCENTRATION
2041 
2042 ! IF (PCC(K).LT.0.) THEN
2043 ! DUM = PCC(K)*DT/QC3D(K)
2044 ! DUM = MAX(-1.,DUM)
2045 ! NSUBC(K) = DUM*NC3D(K)/DT
2046 ! END IF
2047 
2048 ! UPDATE TENDENCIES
2049 
2050 ! NC3DTEN(K) = NC3DTEN(K)+NSUBC(K)
2051 
2052 !.....................................................................
2053 !.....................................................................
2054  ELSE ! TEMPERATURE < 273.15
2055 
2056 !......................................................................
2057 !HM ADD, ALLOW FOR CONSTANT DROPLET NUMBER
2058 ! INUM = 0, PREDICT DROPLET NUMBER
2059 ! INUM = 1, SET CONSTANT DROPLET NUMBER
2060 
2061  IF (iinum.EQ.1) THEN
2062 ! CONVERT NDCNST FROM CM-3 TO KG-1
2063  nc3d(k)=ndcnst*1.e6/rho(k)
2064  END IF
2065 
2066 ! CALCULATE SIZE DISTRIBUTION PARAMETERS
2067 ! MAKE SURE NUMBER CONCENTRATIONS AREN'T NEGATIVE
2068 
2069  ni3d(k) = max(0.,ni3d(k))
2070  ns3d(k) = max(0.,ns3d(k))
2071  nc3d(k) = max(0.,nc3d(k))
2072  nr3d(k) = max(0.,nr3d(k))
2073  ng3d(k) = max(0.,ng3d(k))
2074 
2075 !......................................................................
2076 ! CLOUD ICE
2077 
2078  IF (qi3d(k).GE.qsmall) THEN
2079  lami(k) = (cons12* &
2080  ni3d(k)/qi3d(k))**(1./di)
2081  n0i(k) = ni3d(k)*lami(k)
2082 
2083 ! CHECK FOR SLOPE
2084 
2085 ! ADJUST VARS
2086 
2087  IF (lami(k).LT.lammini) THEN
2088 
2089  lami(k) = lammini
2090 
2091  n0i(k) = lami(k)**4*qi3d(k)/cons12
2092 
2093  ni3d(k) = n0i(k)/lami(k)
2094  ELSE IF (lami(k).GT.lammaxi) THEN
2095  lami(k) = lammaxi
2096  n0i(k) = lami(k)**4*qi3d(k)/cons12
2097 
2098  ni3d(k) = n0i(k)/lami(k)
2099  END IF
2100  END IF
2101 
2102 !......................................................................
2103 ! RAIN
2104 
2105  IF (qr3d(k).GE.qsmall) THEN
2106  lamr(k) = (pi*rhow*nr3d(k)/qr3d(k))**(1./3.)
2107  n0rr(k) = nr3d(k)*lamr(k)
2108 
2109 ! CHECK FOR SLOPE
2110 
2111 ! ADJUST VARS
2112 
2113  IF (lamr(k).LT.lamminr) THEN
2114 
2115  lamr(k) = lamminr
2116 
2117  n0rr(k) = lamr(k)**4*qr3d(k)/(pi*rhow)
2118 
2119  nr3d(k) = n0rr(k)/lamr(k)
2120  ELSE IF (lamr(k).GT.lammaxr) THEN
2121  lamr(k) = lammaxr
2122  n0rr(k) = lamr(k)**4*qr3d(k)/(pi*rhow)
2123 
2124  nr3d(k) = n0rr(k)/lamr(k)
2125  END IF
2126  END IF
2127 !......................................................................
2128 ! CLOUD DROPLETS
2129 
2130 ! MARTIN ET AL. (1994) FORMULA FOR PGAM
2131 
2132  IF (qc3d(k).GE.qsmall) THEN
2133 
2134  dum = pres(k)/(287.15*t3d(k))
2135  pgam(k)=0.0005714*(nc3d(k)/1.e6*dum)+0.2714
2136  pgam(k)=1./(pgam(k)**2)-1.
2137  pgam(k)=max(pgam(k),2.)
2138  pgam(k)=min(pgam(k),10.)
2139 
2140 ! CALCULATE LAMC
2141 
2142  lamc(k) = (cons26*nc3d(k)*gamma(pgam(k)+4.)/ &
2143  (qc3d(k)*gamma(pgam(k)+1.)))**(1./3.)
2144 
2145 ! LAMMIN, 60 MICRON DIAMETER
2146 ! LAMMAX, 1 MICRON
2147 
2148  lammin = (pgam(k)+1.)/60.e-6
2149  lammax = (pgam(k)+1.)/1.e-6
2150 
2151  IF (lamc(k).LT.lammin) THEN
2152  lamc(k) = lammin
2153 
2154  nc3d(k) = exp(3.*log(lamc(k))+log(qc3d(k))+ &
2155  log(gamma(pgam(k)+1.))-log(gamma(pgam(k)+4.)))/cons26
2156  ELSE IF (lamc(k).GT.lammax) THEN
2157  lamc(k) = lammax
2158  nc3d(k) = exp(3.*log(lamc(k))+log(qc3d(k))+ &
2159  log(gamma(pgam(k)+1.))-log(gamma(pgam(k)+4.)))/cons26
2160 
2161  END IF
2162 
2163 ! TO CALCULATE DROPLET FREEZING
2164 
2165  cdist1(k) = nc3d(k)/gamma(pgam(k)+1.)
2166 
2167  END IF
2168 
2169 !......................................................................
2170 ! SNOW
2171 
2172  IF (qni3d(k).GE.qsmall) THEN
2173  lams(k) = (cons1*ns3d(k)/qni3d(k))**(1./ds)
2174  n0s(k) = ns3d(k)*lams(k)
2175 
2176 ! CHECK FOR SLOPE
2177 
2178 ! ADJUST VARS
2179 
2180  IF (lams(k).LT.lammins) THEN
2181  lams(k) = lammins
2182  n0s(k) = lams(k)**4*qni3d(k)/cons1
2183 
2184  ns3d(k) = n0s(k)/lams(k)
2185 
2186  ELSE IF (lams(k).GT.lammaxs) THEN
2187 
2188  lams(k) = lammaxs
2189  n0s(k) = lams(k)**4*qni3d(k)/cons1
2190 
2191  ns3d(k) = n0s(k)/lams(k)
2192  END IF
2193  END IF
2194 
2195 !......................................................................
2196 ! GRAUPEL
2197 
2198  IF (qg3d(k).GE.qsmall) THEN
2199  lamg(k) = (cons2*ng3d(k)/qg3d(k))**(1./dg)
2200  n0g(k) = ng3d(k)*lamg(k)
2201 
2202 ! CHECK FOR SLOPE
2203 
2204 ! ADJUST VARS
2205 
2206  IF (lamg(k).LT.lamming) THEN
2207  lamg(k) = lamming
2208  n0g(k) = lamg(k)**4*qg3d(k)/cons2
2209 
2210  ng3d(k) = n0g(k)/lamg(k)
2211 
2212  ELSE IF (lamg(k).GT.lammaxg) THEN
2213 
2214  lamg(k) = lammaxg
2215  n0g(k) = lamg(k)**4*qg3d(k)/cons2
2216 
2217  ng3d(k) = n0g(k)/lamg(k)
2218  END IF
2219  END IF
2220 !.....................................................................
2221 ! ZERO OUT PROCESS RATES
2222 
2223  mnuccc(k) = 0.
2224  nnuccc(k) = 0.
2225  prc(k) = 0.
2226  nprc(k) = 0.
2227  nprc1(k) = 0.
2228  nsagg(k) = 0.
2229  psacws(k) = 0.
2230  npsacws(k) = 0.
2231  psacwi(k) = 0.
2232  npsacwi(k) = 0.
2233  pracs(k) = 0.
2234  npracs(k) = 0.
2235  nmults(k) = 0.
2236  qmults(k) = 0.
2237  nmultr(k) = 0.
2238  qmultr(k) = 0.
2239  nmultg(k) = 0.
2240  qmultg(k) = 0.
2241  nmultrg(k) = 0.
2242  qmultrg(k) = 0.
2243  mnuccr(k) = 0.
2244  nnuccr(k) = 0.
2245  pra(k) = 0.
2246  npra(k) = 0.
2247  nragg(k) = 0.
2248  prci(k) = 0.
2249  nprci(k) = 0.
2250  prai(k) = 0.
2251  nprai(k) = 0.
2252  nnuccd(k) = 0.
2253  mnuccd(k) = 0.
2254  pcc(k) = 0.
2255  pre(k) = 0.
2256  prd(k) = 0.
2257  prds(k) = 0.
2258  eprd(k) = 0.
2259  eprds(k) = 0.
2260  nsubc(k) = 0.
2261  nsubi(k) = 0.
2262  nsubs(k) = 0.
2263  nsubr(k) = 0.
2264  piacr(k) = 0.
2265  niacr(k) = 0.
2266  praci(k) = 0.
2267  piacrs(k) = 0.
2268  niacrs(k) = 0.
2269  pracis(k) = 0.
2270 ! HM: ADD GRAUPEL PROCESSES
2271  pracg(k) = 0.
2272  psacr(k) = 0.
2273  psacwg(k) = 0.
2274  pgsacw(k) = 0.
2275  pgracs(k) = 0.
2276  prdg(k) = 0.
2277  eprdg(k) = 0.
2278  npracg(k) = 0.
2279  npsacwg(k) = 0.
2280  nscng(k) = 0.
2281  ngracs(k) = 0.
2282  nsubg(k) = 0.
2283 
2284 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2285 ! CALCULATION OF MICROPHYSICAL PROCESS RATES
2286 ! ACCRETION/AUTOCONVERSION/FREEZING/MELTING/COAG.
2287 !.......................................................................
2288 ! FREEZING OF CLOUD DROPLETS
2289 ! ONLY ALLOWED BELOW -4 C
2290  IF (qc3d(k).GE.qsmall .AND. t3d(k).LT.269.15) THEN
2291 
2292 ! NUMBER OF CONTACT NUCLEI (M^-3) FROM MEYERS ET AL., 1992
2293 ! FACTOR OF 1000 IS TO CONVERT FROM L^-1 TO M^-3
2294 
2295 ! MEYERS CURVE
2296 
2297  nacnt = exp(-2.80+0.262*(273.15-t3d(k)))*1000.
2298 
2299 ! COOPER CURVE
2300 ! NACNT = 5.*EXP(0.304*(273.15-T3D(K)))
2301 
2302 ! FLECTHER
2303 ! NACNT = 0.01*EXP(0.6*(273.15-T3D(K)))
2304 
2305 ! CONTACT FREEZING
2306 
2307 ! MEAN FREE PATH
2308 
2309  dum = 7.37*t3d(k)/(288.*10.*pres(k))/100.
2310 
2311 ! EFFECTIVE DIFFUSIVITY OF CONTACT NUCLEI
2312 ! BASED ON BROWNIAN DIFFUSION
2313 
2314  dap(k) = cons37*t3d(k)*(1.+dum/rin)/mu(k)
2315 
2316  mnuccc(k) = cons38*dap(k)*nacnt*exp(log(cdist1(k))+ &
2317  log(gamma(pgam(k)+5.))-4.*log(lamc(k)))
2318  nnuccc(k) = 2.*pi*dap(k)*nacnt*cdist1(k)* &
2319  gamma(pgam(k)+2.)/ &
2320  lamc(k)
2321 
2322 ! IMMERSION FREEZING (BIGG 1953)
2323 
2324 ! MNUCCC(K) = MNUCCC(K)+CONS39* &
2325 ! EXP(LOG(CDIST1(K))+LOG(GAMMA(7.+PGAM(K)))-6.*LOG(LAMC(K)))* &
2326 ! EXP(AIMM*(273.15-T3D(K)))
2327 
2328 ! NNUCCC(K) = NNUCCC(K)+ &
2329 ! CONS40*EXP(LOG(CDIST1(K))+LOG(GAMMA(PGAM(K)+4.))-3.*LOG(LAMC(K))) &
2330 ! *EXP(AIMM*(273.15-T3D(K)))
2331 
2332 ! hm 7/15/13 fix for consistency w/ original formula
2333  mnuccc(k) = mnuccc(k)+cons39* &
2334  exp(log(cdist1(k))+log(gamma(7.+pgam(k)))-6.*log(lamc(k)))* &
2335  (exp(aimm*(273.15-t3d(k)))-1.)
2336 
2337  nnuccc(k) = nnuccc(k)+ &
2338  cons40*exp(log(cdist1(k))+log(gamma(pgam(k)+4.))-3.*log(lamc(k))) &
2339  *(exp(aimm*(273.15-t3d(k)))-1.)
2340 
2341 ! PUT IN A CATCH HERE TO PREVENT DIVERGENCE BETWEEN NUMBER CONC. AND
2342 ! MIXING RATIO, SINCE STRICT CONSERVATION NOT CHECKED FOR NUMBER CONC
2343 
2344  nnuccc(k) = min(nnuccc(k),nc3d(k)/dt)
2345 
2346  END IF
2347 
2348 !.................................................................
2349 !.......................................................................
2350 ! AUTOCONVERSION OF CLOUD LIQUID WATER TO RAIN
2351 ! FORMULA FROM BEHENG (1994)
2352 ! USING NUMERICAL SIMULATION OF STOCHASTIC COLLECTION EQUATION
2353 ! AND INITIAL CLOUD DROPLET SIZE DISTRIBUTION SPECIFIED
2354 ! AS A GAMMA DISTRIBUTION
2355 
2356 ! USE MINIMUM VALUE OF 1.E-6 TO PREVENT FLOATING POINT ERROR
2357 
2358  IF (qc3d(k).GE.1.e-6) THEN
2359 
2360 ! HM ADD 12/13/06, REPLACE WITH NEWER FORMULA
2361 ! FROM KHAIROUTDINOV AND KOGAN 2000, MWR
2362 
2363  prc(k)=1350.*qc3d(k)**2.47* &
2364  (nc3d(k)/1.e6*rho(k))**(-1.79)
2365 
2366 ! note: nprc1 is change in Nr,
2367 ! nprc is change in Nc
2368 
2369  nprc1(k) = prc(k)/cons29
2370  nprc(k) = prc(k)/(qc3d(k)/nc3d(k))
2371 
2372 ! hm bug fix 3/20/12
2373  nprc(k) = min(nprc(k),nc3d(k)/dt)
2374  nprc1(k) = min(nprc1(k),nprc(k))
2375 
2376  END IF
2377 !.......................................................................
2378 ! SELF-COLLECTION OF DROPLET NOT INCLUDED IN KK2000 SCHEME
2379 
2380 ! SNOW AGGREGATION FROM PASSARELLI, 1978, USED BY REISNER, 1998
2381 ! THIS IS HARD-WIRED FOR BS = 0.4 FOR NOW
2382 
2383  IF (qni3d(k).GE.1.e-8) THEN
2384  nsagg(k) = cons15*asn(k)*rho(k)** &
2385  ((2.+bs)/3.)*qni3d(k)**((2.+bs)/3.)* &
2386  (ns3d(k)*rho(k))**((4.-bs)/3.)/ &
2387  (rho(k))
2388  END IF
2389 
2390 !.......................................................................
2391 ! ACCRETION OF CLOUD DROPLETS ONTO SNOW/GRAUPEL
2392 ! HERE USE CONTINUOUS COLLECTION EQUATION WITH
2393 ! SIMPLE GRAVITATIONAL COLLECTION KERNEL IGNORING
2394 
2395 ! SNOW
2396 
2397  IF (qni3d(k).GE.1.e-8 .AND. qc3d(k).GE.qsmall) THEN
2398 
2399  psacws(k) = cons13*asn(k)*qc3d(k)*rho(k)* &
2400  n0s(k)/ &
2401  lams(k)**(bs+3.)
2402  npsacws(k) = cons13*asn(k)*nc3d(k)*rho(k)* &
2403  n0s(k)/ &
2404  lams(k)**(bs+3.)
2405 
2406  END IF
2407 
2408 !............................................................................
2409 ! COLLECTION OF CLOUD WATER BY GRAUPEL
2410 
2411  IF (qg3d(k).GE.1.e-8 .AND. qc3d(k).GE.qsmall) THEN
2412 
2413  psacwg(k) = cons14*agn(k)*qc3d(k)*rho(k)* &
2414  n0g(k)/ &
2415  lamg(k)**(bg+3.)
2416  npsacwg(k) = cons14*agn(k)*nc3d(k)*rho(k)* &
2417  n0g(k)/ &
2418  lamg(k)**(bg+3.)
2419  END IF
2420 !.......................................................................
2421 ! HM, ADD 12/13/06
2422 ! CLOUD ICE COLLECTING DROPLETS, ASSUME THAT CLOUD ICE MEAN DIAM > 100 MICRON
2423 ! BEFORE RIMING CAN OCCUR
2424 ! ASSUME THAT RIME COLLECTED ON CLOUD ICE DOES NOT LEAD
2425 ! TO HALLET-MOSSOP SPLINTERING
2426 
2427  IF (qi3d(k).GE.1.e-8 .AND. qc3d(k).GE.qsmall) THEN
2428 
2429 ! PUT IN SIZE DEPENDENT COLLECTION EFFICIENCY BASED ON STOKES LAW
2430 ! FROM THOMPSON ET AL. 2004, MWR
2431 
2432  IF (1./lami(k).GE.100.e-6) THEN
2433 
2434  psacwi(k) = cons16*ain(k)*qc3d(k)*rho(k)* &
2435  n0i(k)/ &
2436  lami(k)**(bi+3.)
2437  npsacwi(k) = cons16*ain(k)*nc3d(k)*rho(k)* &
2438  n0i(k)/ &
2439  lami(k)**(bi+3.)
2440  END IF
2441  END IF
2442 
2443 !.......................................................................
2444 ! ACCRETION OF RAIN WATER BY SNOW
2445 ! FORMULA FROM IKAWA AND SAITO, 1991, USED BY REISNER ET AL, 1998
2446 
2447  IF (qr3d(k).GE.1.e-8.AND.qni3d(k).GE.1.e-8) THEN
2448 
2449  ums = asn(k)*cons3/(lams(k)**bs)
2450  umr = arn(k)*cons4/(lamr(k)**br)
2451  uns = asn(k)*cons5/lams(k)**bs
2452  unr = arn(k)*cons6/lamr(k)**br
2453 
2454 ! SET REASLISTIC LIMITS ON FALLSPEEDS
2455 
2456 ! bug fix, 10/08/09
2457  dum=(rhosu/rho(k))**0.54
2458  ums=min(ums,1.2*dum)
2459  uns=min(uns,1.2*dum)
2460  umr=min(umr,9.1*dum)
2461  unr=min(unr,9.1*dum)
2462 
2463  pracs(k) = cons41*(((1.2*umr-0.95*ums)**2+ &
2464  0.08*ums*umr)**0.5*rho(k)* &
2465  n0rr(k)*n0s(k)/lamr(k)**3* &
2466  (5./(lamr(k)**3*lams(k))+ &
2467  2./(lamr(k)**2*lams(k)**2)+ &
2468  0.5/(lamr(k)*lams(k)**3)))
2469 
2470  npracs(k) = cons32*rho(k)*(1.7*(unr-uns)**2+ &
2471  0.3*unr*uns)**0.5*n0rr(k)*n0s(k)* &
2472  (1./(lamr(k)**3*lams(k))+ &
2473  1./(lamr(k)**2*lams(k)**2)+ &
2474  1./(lamr(k)*lams(k)**3))
2475 
2476 ! MAKE SURE PRACS DOESN'T EXCEED TOTAL RAIN MIXING RATIO
2477 ! AS THIS MAY OTHERWISE RESULT IN TOO MUCH TRANSFER OF WATER DURING
2478 ! RIME-SPLINTERING
2479 
2480  pracs(k) = min(pracs(k),qr3d(k)/dt)
2481 
2482 ! COLLECTION OF SNOW BY RAIN - NEEDED FOR GRAUPEL CONVERSION CALCULATIONS
2483 ! ONLY CALCULATE IF SNOW AND RAIN MIXING RATIOS EXCEED 0.1 G/KG
2484 
2485 ! HM MODIFY FOR WRFV3.1
2486 ! IF (IHAIL.EQ.0) THEN
2487  IF (qni3d(k).GE.0.1e-3.AND.qr3d(k).GE.0.1e-3) THEN
2488  psacr(k) = cons31*(((1.2*umr-0.95*ums)**2+ &
2489  0.08*ums*umr)**0.5*rho(k)* &
2490  n0rr(k)*n0s(k)/lams(k)**3* &
2491  (5./(lams(k)**3*lamr(k))+ &
2492  2./(lams(k)**2*lamr(k)**2)+ &
2493  0.5/(lams(k)*lamr(k)**3)))
2494  END IF
2495 ! END IF
2496 
2497  END IF
2498 
2499 !.......................................................................
2500 
2501 ! COLLECTION OF RAINWATER BY GRAUPEL, FROM IKAWA AND SAITO 1990,
2502 ! USED BY REISNER ET AL 1998
2503  IF (qr3d(k).GE.1.e-8.AND.qg3d(k).GE.1.e-8) THEN
2504 
2505  umg = agn(k)*cons7/(lamg(k)**bg)
2506  umr = arn(k)*cons4/(lamr(k)**br)
2507  ung = agn(k)*cons8/lamg(k)**bg
2508  unr = arn(k)*cons6/lamr(k)**br
2509 
2510 ! SET REASLISTIC LIMITS ON FALLSPEEDS
2511 ! bug fix, 10/08/09
2512  dum=(rhosu/rho(k))**0.54
2513  umg=min(umg,20.*dum)
2514  ung=min(ung,20.*dum)
2515  umr=min(umr,9.1*dum)
2516  unr=min(unr,9.1*dum)
2517 
2518  pracg(k) = cons41*(((1.2*umr-0.95*umg)**2+ &
2519  0.08*umg*umr)**0.5*rho(k)* &
2520  n0rr(k)*n0g(k)/lamr(k)**3* &
2521  (5./(lamr(k)**3*lamg(k))+ &
2522  2./(lamr(k)**2*lamg(k)**2)+ &
2523  0.5/(lamr(k)*lamg(k)**3)))
2524 
2525  npracg(k) = cons32*rho(k)*(1.7*(unr-ung)**2+ &
2526  0.3*unr*ung)**0.5*n0rr(k)*n0g(k)* &
2527  (1./(lamr(k)**3*lamg(k))+ &
2528  1./(lamr(k)**2*lamg(k)**2)+ &
2529  1./(lamr(k)*lamg(k)**3))
2530 
2531 ! MAKE SURE PRACG DOESN'T EXCEED TOTAL RAIN MIXING RATIO
2532 ! AS THIS MAY OTHERWISE RESULT IN TOO MUCH TRANSFER OF WATER DURING
2533 ! RIME-SPLINTERING
2534 
2535  pracg(k) = min(pracg(k),qr3d(k)/dt)
2536 
2537  END IF
2538 
2539 !.......................................................................
2540 ! RIME-SPLINTERING - SNOW
2541 ! HALLET-MOSSOP (1974)
2542 ! NUMBER OF SPLINTERS FORMED IS BASED ON MASS OF RIMED WATER
2543 
2544 ! DUM1 = MASS OF INDIVIDUAL SPLINTERS
2545 
2546 ! HM ADD THRESHOLD SNOW AND DROPLET MIXING RATIO FOR RIME-SPLINTERING
2547 ! TO LIMIT RIME-SPLINTERING IN STRATIFORM CLOUDS
2548 ! THESE THRESHOLDS CORRESPOND WITH GRAUPEL THRESHOLDS IN RH 1984
2549 
2550 !v1.4
2551  IF (qni3d(k).GE.0.1e-3) THEN
2552  IF (qc3d(k).GE.0.5e-3.OR.qr3d(k).GE.0.1e-3) THEN
2553  IF (psacws(k).GT.0..OR.pracs(k).GT.0.) THEN
2554  IF (t3d(k).LT.270.16 .AND. t3d(k).GT.265.16) THEN
2555 
2556  IF (t3d(k).GT.270.16) THEN
2557  fmult = 0.
2558  ELSE IF (t3d(k).LE.270.16.AND.t3d(k).GT.268.16) THEN
2559  fmult = (270.16-t3d(k))/2.
2560  ELSE IF (t3d(k).GE.265.16.AND.t3d(k).LE.268.16) THEN
2561  fmult = (t3d(k)-265.16)/3.
2562  ELSE IF (t3d(k).LT.265.16) THEN
2563  fmult = 0.
2564  END IF
2565 
2566 ! 1000 IS TO CONVERT FROM KG TO G
2567 
2568 ! SPLINTERING FROM DROPLETS ACCRETED ONTO SNOW
2569 
2570  IF (psacws(k).GT.0.) THEN
2571  nmults(k) = 35.e4*psacws(k)*fmult*1000.
2572  qmults(k) = nmults(k)*mmult
2573 
2574 ! CONSTRAIN SO THAT TRANSFER OF MASS FROM SNOW TO ICE CANNOT BE MORE MASS
2575 ! THAN WAS RIMED ONTO SNOW
2576 
2577  qmults(k) = min(qmults(k),psacws(k))
2578  psacws(k) = psacws(k)-qmults(k)
2579 
2580  END IF
2581 
2582 ! RIMING AND SPLINTERING FROM ACCRETED RAINDROPS
2583 
2584  IF (pracs(k).GT.0.) THEN
2585  nmultr(k) = 35.e4*pracs(k)*fmult*1000.
2586  qmultr(k) = nmultr(k)*mmult
2587 
2588 ! CONSTRAIN SO THAT TRANSFER OF MASS FROM SNOW TO ICE CANNOT BE MORE MASS
2589 ! THAN WAS RIMED ONTO SNOW
2590 
2591  qmultr(k) = min(qmultr(k),pracs(k))
2592 
2593  pracs(k) = pracs(k)-qmultr(k)
2594 
2595  END IF
2596 
2597  END IF
2598  END IF
2599  END IF
2600  END IF
2601 
2602 !.......................................................................
2603 ! RIME-SPLINTERING - GRAUPEL
2604 ! HALLET-MOSSOP (1974)
2605 ! NUMBER OF SPLINTERS FORMED IS BASED ON MASS OF RIMED WATER
2606 
2607 ! DUM1 = MASS OF INDIVIDUAL SPLINTERS
2608 
2609 ! HM ADD THRESHOLD SNOW MIXING RATIO FOR RIME-SPLINTERING
2610 ! TO LIMIT RIME-SPLINTERING IN STRATIFORM CLOUDS
2611 
2612 ! IF (IHAIL.EQ.0) THEN
2613 ! v1.4
2614  IF (qg3d(k).GE.0.1e-3) THEN
2615  IF (qc3d(k).GE.0.5e-3.OR.qr3d(k).GE.0.1e-3) THEN
2616  IF (psacwg(k).GT.0..OR.pracg(k).GT.0.) THEN
2617  IF (t3d(k).LT.270.16 .AND. t3d(k).GT.265.16) THEN
2618 
2619  IF (t3d(k).GT.270.16) THEN
2620  fmult = 0.
2621  ELSE IF (t3d(k).LE.270.16.AND.t3d(k).GT.268.16) THEN
2622  fmult = (270.16-t3d(k))/2.
2623  ELSE IF (t3d(k).GE.265.16.AND.t3d(k).LE.268.16) THEN
2624  fmult = (t3d(k)-265.16)/3.
2625  ELSE IF (t3d(k).LT.265.16) THEN
2626  fmult = 0.
2627  END IF
2628 
2629 ! 1000 IS TO CONVERT FROM KG TO G
2630 
2631 ! SPLINTERING FROM DROPLETS ACCRETED ONTO GRAUPEL
2632 
2633  IF (psacwg(k).GT.0.) THEN
2634  nmultg(k) = 35.e4*psacwg(k)*fmult*1000.
2635  qmultg(k) = nmultg(k)*mmult
2636 
2637 ! CONSTRAIN SO THAT TRANSFER OF MASS FROM GRAUPEL TO ICE CANNOT BE MORE MASS
2638 ! THAN WAS RIMED ONTO GRAUPEL
2639 
2640  qmultg(k) = min(qmultg(k),psacwg(k))
2641  psacwg(k) = psacwg(k)-qmultg(k)
2642 
2643  END IF
2644 
2645 ! RIMING AND SPLINTERING FROM ACCRETED RAINDROPS
2646 
2647  IF (pracg(k).GT.0.) THEN
2648  nmultrg(k) = 35.e4*pracg(k)*fmult*1000.
2649  qmultrg(k) = nmultrg(k)*mmult
2650 
2651 ! CONSTRAIN SO THAT TRANSFER OF MASS FROM GRAUPEL TO ICE CANNOT BE MORE MASS
2652 ! THAN WAS RIMED ONTO GRAUPEL
2653 
2654  qmultrg(k) = min(qmultrg(k),pracg(k))
2655  pracg(k) = pracg(k)-qmultrg(k)
2656 
2657  END IF
2658  END IF
2659  END IF
2660  END IF
2661  END IF
2662 ! END IF
2663 
2664 !........................................................................
2665 ! CONVERSION OF RIMED CLOUD WATER ONTO SNOW TO GRAUPEL/HAIL
2666 
2667 ! IF (IHAIL.EQ.0) THEN
2668  IF (psacws(k).GT.0.) THEN
2669 ! ONLY ALLOW CONVERSION IF QNI > 0.1 AND QC > 0.5 G/KG FOLLOWING RUTLEDGE AND HOBBS (1984)
2670  IF (qni3d(k).GE.0.1e-3.AND.qc3d(k).GE.0.5e-3) THEN
2671 
2672 ! PORTION OF RIMING CONVERTED TO GRAUPEL (REISNER ET AL. 1998, ORIGINALLY IS1991)
2673  pgsacw(k) = min(psacws(k),cons17*dt*n0s(k)*qc3d(k)*qc3d(k)* &
2674  asn(k)*asn(k)/ &
2675  (rho(k)*lams(k)**(2.*bs+2.)))
2676 
2677 ! MIX RAT CONVERTED INTO GRAUPEL AS EMBRYO (REISNER ET AL. 1998, ORIG M1990)
2678  dum = max(rhosn/(rhog-rhosn)*pgsacw(k),0.)
2679 
2680 ! NUMBER CONCENTRAITON OF EMBRYO GRAUPEL FROM RIMING OF SNOW
2681  nscng(k) = dum/mg0*rho(k)
2682 ! LIMIT MAX NUMBER CONVERTED TO SNOW NUMBER
2683  nscng(k) = min(nscng(k),ns3d(k)/dt)
2684 
2685 ! PORTION OF RIMING LEFT FOR SNOW
2686  psacws(k) = psacws(k) - pgsacw(k)
2687  END IF
2688  END IF
2689 
2690 ! CONVERSION OF RIMED RAINWATER ONTO SNOW CONVERTED TO GRAUPEL
2691 
2692  IF (pracs(k).GT.0.) THEN
2693 ! ONLY ALLOW CONVERSION IF QNI > 0.1 AND QR > 0.1 G/KG FOLLOWING RUTLEDGE AND HOBBS (1984)
2694  IF (qni3d(k).GE.0.1e-3.AND.qr3d(k).GE.0.1e-3) THEN
2695 ! PORTION OF COLLECTED RAINWATER CONVERTED TO GRAUPEL (REISNER ET AL. 1998)
2696  dum = cons18*(4./lams(k))**3*(4./lams(k))**3 &
2697  /(cons18*(4./lams(k))**3*(4./lams(k))**3+ &
2698  cons19*(4./lamr(k))**3*(4./lamr(k))**3)
2699  dum=min(dum,1.)
2700  dum=max(dum,0.)
2701  pgracs(k) = (1.-dum)*pracs(k)
2702  ngracs(k) = (1.-dum)*npracs(k)
2703 ! LIMIT MAX NUMBER CONVERTED TO MIN OF EITHER RAIN OR SNOW NUMBER CONCENTRATION
2704  ngracs(k) = min(ngracs(k),nr3d(k)/dt)
2705  ngracs(k) = min(ngracs(k),ns3d(k)/dt)
2706 
2707 ! AMOUNT LEFT FOR SNOW PRODUCTION
2708  pracs(k) = pracs(k) - pgracs(k)
2709  npracs(k) = npracs(k) - ngracs(k)
2710 ! CONVERSION TO GRAUPEL DUE TO COLLECTION OF SNOW BY RAIN
2711  psacr(k)=psacr(k)*(1.-dum)
2712  END IF
2713  END IF
2714 ! END IF
2715 
2716 !.......................................................................
2717 ! FREEZING OF RAIN DROPS
2718 ! FREEZING ALLOWED BELOW -4 C
2719 
2720  IF (t3d(k).LT.269.15.AND.qr3d(k).GE.qsmall) THEN
2721 
2722 ! IMMERSION FREEZING (BIGG 1953)
2723 ! MNUCCR(K) = CONS20*NR3D(K)*EXP(AIMM*(273.15-T3D(K)))/LAMR(K)**3 &
2724 ! /LAMR(K)**3
2725 
2726 ! NNUCCR(K) = PI*NR3D(K)*BIMM*EXP(AIMM*(273.15-T3D(K)))/LAMR(K)**3
2727 
2728 ! hm fix 7/15/13 for consistency w/ original formula
2729  mnuccr(k) = cons20*nr3d(k)*(exp(aimm*(273.15-t3d(k)))-1.)/lamr(k)**3 &
2730  /lamr(k)**3
2731 
2732  nnuccr(k) = pi*nr3d(k)*bimm*(exp(aimm*(273.15-t3d(k)))-1.)/lamr(k)**3
2733 
2734 ! PREVENT DIVERGENCE BETWEEN MIXING RATIO AND NUMBER CONC
2735  nnuccr(k) = min(nnuccr(k),nr3d(k)/dt)
2736 
2737  END IF
2738 
2739 !.......................................................................
2740 ! ACCRETION OF CLOUD LIQUID WATER BY RAIN
2741 ! CONTINUOUS COLLECTION EQUATION WITH
2742 ! GRAVITATIONAL COLLECTION KERNEL, DROPLET FALL SPEED NEGLECTED
2743 
2744  IF (qr3d(k).GE.1.e-8 .AND. qc3d(k).GE.1.e-8) THEN
2745 
2746 ! 12/13/06 HM ADD, REPLACE WITH NEWER FORMULA FROM
2747 ! KHAIROUTDINOV AND KOGAN 2000, MWR
2748 
2749  dum=(qc3d(k)*qr3d(k))
2750  pra(k) = 67.*(dum)**1.15
2751  npra(k) = pra(k)/(qc3d(k)/nc3d(k))
2752 
2753  END IF
2754 !.......................................................................
2755 ! SELF-COLLECTION OF RAIN DROPS
2756 ! FROM BEHENG(1994)
2757 ! FROM NUMERICAL SIMULATION OF THE STOCHASTIC COLLECTION EQUATION
2758 ! AS DESCRINED ABOVE FOR AUTOCONVERSION
2759 
2760  IF (qr3d(k).GE.1.e-8) THEN
2761 ! include breakup add 10/09/09
2762  dum1=300.e-6
2763  if (1./lamr(k).lt.dum1) then
2764  dum=1.
2765  else if (1./lamr(k).ge.dum1) then
2766  dum=2.-exp(2300.*(1./lamr(k)-dum1))
2767  end if
2768 ! NRAGG(K) = -8.*NR3D(K)*QR3D(K)*RHO(K)
2769  nragg(k) = -5.78*dum*nr3d(k)*qr3d(k)*rho(k)
2770  END IF
2771 
2772 !.......................................................................
2773 ! AUTOCONVERSION OF CLOUD ICE TO SNOW
2774 ! FOLLOWING HARRINGTON ET AL. (1995) WITH MODIFICATION
2775 ! HERE IT IS ASSUMED THAT AUTOCONVERSION CAN ONLY OCCUR WHEN THE
2776 ! ICE IS GROWING, I.E. IN CONDITIONS OF ICE SUPERSATURATION
2777 
2778  IF (qi3d(k).GE.1.e-8 .AND.qvqvsi(k).GE.1.) THEN
2779 
2780 ! COFFI = 2./LAMI(K)
2781 ! IF (COFFI.GE.DCS) THEN
2782  nprci(k) = cons21*(qv3d(k)-qvi(k))*rho(k) &
2783  *n0i(k)*exp(-lami(k)*dcs)*dv(k)/abi(k)
2784  prci(k) = cons22*nprci(k)
2785  nprci(k) = min(nprci(k),ni3d(k)/dt)
2786 
2787 ! END IF
2788  END IF
2789 
2790 !.......................................................................
2791 ! ACCRETION OF CLOUD ICE BY SNOW
2792 ! FOR THIS CALCULATION, IT IS ASSUMED THAT THE VS >> VI
2793 ! AND DS >> DI FOR CONTINUOUS COLLECTION
2794 
2795  IF (qni3d(k).GE.1.e-8 .AND. qi3d(k).GE.qsmall) THEN
2796  prai(k) = cons23*asn(k)*qi3d(k)*rho(k)*n0s(k)/ &
2797  lams(k)**(bs+3.)
2798  nprai(k) = cons23*asn(k)*ni3d(k)* &
2799  rho(k)*n0s(k)/ &
2800  lams(k)**(bs+3.)
2801  nprai(k)=min(nprai(k),ni3d(k)/dt)
2802  END IF
2803 
2804 !.......................................................................
2805 ! HM, ADD 12/13/06, COLLISION OF RAIN AND ICE TO PRODUCE SNOW OR GRAUPEL
2806 ! FOLLOWS REISNER ET AL. 1998
2807 ! ASSUMED FALLSPEED AND SIZE OF ICE CRYSTAL << THAN FOR RAIN
2808 
2809  IF (qr3d(k).GE.1.e-8.AND.qi3d(k).GE.1.e-8.AND.t3d(k).LE.273.15) THEN
2810 
2811 ! ALLOW GRAUPEL FORMATION FROM RAIN-ICE COLLISIONS ONLY IF RAIN MIXING RATIO > 0.1 G/KG,
2812 ! OTHERWISE ADD TO SNOW
2813 
2814  IF (qr3d(k).GE.0.1e-3) THEN
2815  niacr(k)=cons24*ni3d(k)*n0rr(k)*arn(k) &
2816  /lamr(k)**(br+3.)*rho(k)
2817  piacr(k)=cons25*ni3d(k)*n0rr(k)*arn(k) &
2818  /lamr(k)**(br+3.)/lamr(k)**3*rho(k)
2819  praci(k)=cons24*qi3d(k)*n0rr(k)*arn(k)/ &
2820  lamr(k)**(br+3.)*rho(k)
2821  niacr(k)=min(niacr(k),nr3d(k)/dt)
2822  niacr(k)=min(niacr(k),ni3d(k)/dt)
2823  ELSE
2824  niacrs(k)=cons24*ni3d(k)*n0rr(k)*arn(k) &
2825  /lamr(k)**(br+3.)*rho(k)
2826  piacrs(k)=cons25*ni3d(k)*n0rr(k)*arn(k) &
2827  /lamr(k)**(br+3.)/lamr(k)**3*rho(k)
2828  pracis(k)=cons24*qi3d(k)*n0rr(k)*arn(k)/ &
2829  lamr(k)**(br+3.)*rho(k)
2830  niacrs(k)=min(niacrs(k),nr3d(k)/dt)
2831  niacrs(k)=min(niacrs(k),ni3d(k)/dt)
2832  END IF
2833  END IF
2834 
2835 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2836 ! NUCLEATION OF CLOUD ICE FROM HOMOGENEOUS AND HETEROGENEOUS FREEZING ON AEROSOL
2837 
2838  IF (inuc.EQ.0) THEN
2839 
2840 ! add threshold according to Greg Thomspon
2841 
2842  if ((qvqvs(k).GE.0.999.and.t3d(k).le.265.15).or. &
2843  qvqvsi(k).ge.1.08) then
2844 
2845 ! hm, modify dec. 5, 2006, replace with cooper curve
2846  kc2 = 0.005*exp(0.304*(273.15-t3d(k)))*1000. ! convert from L-1 to m-3
2847 ! limit to 500 L-1
2848  kc2 = min(kc2,500.e3)
2849  kc2=max(kc2/rho(k),0.) ! convert to kg-1
2850 
2851  IF (kc2.GT.ni3d(k)+ns3d(k)+ng3d(k)) THEN
2852  nnuccd(k) = (kc2-ni3d(k)-ns3d(k)-ng3d(k))/dt
2853  mnuccd(k) = nnuccd(k)*mi0
2854  END IF
2855 
2856  END IF
2857 
2858  ELSE IF (inuc.EQ.1) THEN
2859 
2860  IF (t3d(k).LT.273.15.AND.qvqvsi(k).GT.1.) THEN
2861 
2862  kc2 = 0.16*1000./rho(k) ! CONVERT FROM L-1 TO KG-1
2863  IF (kc2.GT.ni3d(k)+ns3d(k)+ng3d(k)) THEN
2864  nnuccd(k) = (kc2-ni3d(k)-ns3d(k)-ng3d(k))/dt
2865  mnuccd(k) = nnuccd(k)*mi0
2866  END IF
2867  END IF
2868 
2869  END IF
2870 
2871 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2872 
2873  101 CONTINUE
2874 
2875 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2876 ! CALCULATE EVAP/SUB/DEP TERMS FOR QI,QNI,QR
2877 
2878 ! NO VENTILATION FOR CLOUD ICE
2879 
2880  IF (qi3d(k).GE.qsmall) THEN
2881 
2882  epsi = 2.*pi*n0i(k)*rho(k)*dv(k)/(lami(k)*lami(k))
2883 
2884  ELSE
2885  epsi = 0.
2886  END IF
2887 
2888  IF (qni3d(k).GE.qsmall) THEN
2889  epss = 2.*pi*n0s(k)*rho(k)*dv(k)* &
2890  (f1s/(lams(k)*lams(k))+ &
2891  f2s*(asn(k)*rho(k)/mu(k))**0.5* &
2892  sc(k)**(1./3.)*cons10/ &
2893  (lams(k)**cons35))
2894  ELSE
2895  epss = 0.
2896  END IF
2897 
2898  IF (qg3d(k).GE.qsmall) THEN
2899  epsg = 2.*pi*n0g(k)*rho(k)*dv(k)* &
2900  (f1s/(lamg(k)*lamg(k))+ &
2901  f2s*(agn(k)*rho(k)/mu(k))**0.5* &
2902  sc(k)**(1./3.)*cons11/ &
2903  (lamg(k)**cons36))
2904 
2905 
2906  ELSE
2907  epsg = 0.
2908  END IF
2909 
2910  IF (qr3d(k).GE.qsmall) THEN
2911  epsr = 2.*pi*n0rr(k)*rho(k)*dv(k)* &
2912  (f1r/(lamr(k)*lamr(k))+ &
2913  f2r*(arn(k)*rho(k)/mu(k))**0.5* &
2914  sc(k)**(1./3.)*cons9/ &
2915  (lamr(k)**cons34))
2916  ELSE
2917  epsr = 0.
2918  END IF
2919 
2920 ! ONLY INCLUDE REGION OF ICE SIZE DIST < DCS
2921 ! DUM IS FRACTION OF D*N(D) < DCS
2922 
2923 ! LOGIC BELOW FOLLOWS THAT OF HARRINGTON ET AL. 1995 (JAS)
2924  IF (qi3d(k).GE.qsmall) THEN
2925  dum=(1.-exp(-lami(k)*dcs)*(1.+lami(k)*dcs))
2926  prd(k) = epsi*(qv3d(k)-qvi(k))/abi(k)*dum
2927  ELSE
2928  dum=0.
2929  END IF
2930 ! ADD DEPOSITION IN TAIL OF ICE SIZE DIST TO SNOW IF SNOW IS PRESENT
2931  IF (qni3d(k).GE.qsmall) THEN
2932  prds(k) = epss*(qv3d(k)-qvi(k))/abi(k)+ &
2933  epsi*(qv3d(k)-qvi(k))/abi(k)*(1.-dum)
2934 ! OTHERWISE ADD TO CLOUD ICE
2935  ELSE
2936  prd(k) = prd(k)+epsi*(qv3d(k)-qvi(k))/abi(k)*(1.-dum)
2937  END IF
2938 ! VAPOR DPEOSITION ON GRAUPEL
2939  prdg(k) = epsg*(qv3d(k)-qvi(k))/abi(k)
2940 
2941 ! NO CONDENSATION ONTO RAIN, ONLY EVAP
2942 
2943  IF (qv3d(k).LT.qvs(k)) THEN
2944  pre(k) = epsr*(qv3d(k)-qvs(k))/ab(k)
2945  pre(k) = min(pre(k),0.)
2946  ELSE
2947  pre(k) = 0.
2948  END IF
2949 
2950 ! MAKE SURE NOT PUSHED INTO ICE SUPERSAT/SUBSAT
2951 ! FORMULA FROM REISNER 2 SCHEME
2952 
2953  dum = (qv3d(k)-qvi(k))/dt
2954 
2955  fudgef = 0.9999
2956  sum_dep = prd(k)+prds(k)+mnuccd(k)+prdg(k)
2957 
2958  IF( (dum.GT.0. .AND. sum_dep.GT.dum*fudgef) .OR. &
2959  (dum.LT.0. .AND. sum_dep.LT.dum*fudgef) ) THEN
2960  mnuccd(k) = fudgef*mnuccd(k)*dum/sum_dep
2961  prd(k) = fudgef*prd(k)*dum/sum_dep
2962  prds(k) = fudgef*prds(k)*dum/sum_dep
2963  prdg(k) = fudgef*prdg(k)*dum/sum_dep
2964  ENDIF
2965 
2966 ! IF CLOUD ICE/SNOW/GRAUPEL VAP DEPOSITION IS NEG, THEN ASSIGN TO SUBLIMATION PROCESSES
2967 
2968  IF (prd(k).LT.0.) THEN
2969  eprd(k)=prd(k)
2970  prd(k)=0.
2971  END IF
2972  IF (prds(k).LT.0.) THEN
2973  eprds(k)=prds(k)
2974  prds(k)=0.
2975  END IF
2976  IF (prdg(k).LT.0.) THEN
2977  eprdg(k)=prdg(k)
2978  prdg(k)=0.
2979  END IF
2980 !.......................................................................
2981 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2982 
2983 ! CONSERVATION OF WATER
2984 ! THIS IS ADOPTED LOOSELY FROM MM5 RESINER CODE. HOWEVER, HERE WE
2985 ! ONLY ADJUST PROCESSES THAT ARE NEGATIVE, RATHER THAN ALL PROCESSES.
2986 
2987 ! IF MIXING RATIOS LESS THAN QSMALL, THEN NO DEPLETION OF WATER
2988 ! THROUGH MICROPHYSICAL PROCESSES, SKIP CONSERVATION
2989 
2990 ! NOTE: CONSERVATION CHECK NOT APPLIED TO NUMBER CONCENTRATION SPECIES. ADDITIONAL CATCH
2991 ! BELOW WILL PREVENT NEGATIVE NUMBER CONCENTRATION
2992 ! FOR EACH MICROPHYSICAL PROCESS WHICH PROVIDES A SOURCE FOR NUMBER, THERE IS A CHECK
2993 ! TO MAKE SURE THAT CAN'T EXCEED TOTAL NUMBER OF DEPLETED SPECIES WITH THE TIME
2994 ! STEP
2995 
2996 !****SENSITIVITY - NO ICE
2997 
2998  IF (iliq.EQ.1) THEN
2999  mnuccc(k)=0.
3000  nnuccc(k)=0.
3001  mnuccr(k)=0.
3002  nnuccr(k)=0.
3003  mnuccd(k)=0.
3004  nnuccd(k)=0.
3005  END IF
3006 
3007 ! ****SENSITIVITY - NO GRAUPEL
3008  IF (igraup.EQ.1) THEN
3009  pracg(k) = 0.
3010  psacr(k) = 0.
3011  psacwg(k) = 0.
3012  prdg(k) = 0.
3013  eprdg(k) = 0.
3014  evpmg(k) = 0.
3015  pgmlt(k) = 0.
3016  npracg(k) = 0.
3017  npsacwg(k) = 0.
3018  nscng(k) = 0.
3019  ngracs(k) = 0.
3020  nsubg(k) = 0.
3021  ngmltg(k) = 0.
3022  ngmltr(k) = 0.
3023 ! fix 053011
3024  piacrs(k)=piacrs(k)+piacr(k)
3025  piacr(k) = 0.
3026 ! fix 070713
3027  pracis(k)=pracis(k)+praci(k)
3028  praci(k) = 0.
3029  psacws(k)=psacws(k)+pgsacw(k)
3030  pgsacw(k) = 0.
3031  pracs(k)=pracs(k)+pgracs(k)
3032  pgracs(k) = 0.
3033  END IF
3034 
3035 ! CONSERVATION OF QC
3036 
3037  dum = (prc(k)+pra(k)+mnuccc(k)+psacws(k)+psacwi(k)+qmults(k)+psacwg(k)+pgsacw(k)+qmultg(k))*dt
3038 
3039  IF (dum.GT.qc3d(k).AND.qc3d(k).GE.qsmall) THEN
3040  ratio = qc3d(k)/dum
3041 
3042  prc(k) = prc(k)*ratio
3043  pra(k) = pra(k)*ratio
3044  mnuccc(k) = mnuccc(k)*ratio
3045  psacws(k) = psacws(k)*ratio
3046  psacwi(k) = psacwi(k)*ratio
3047  qmults(k) = qmults(k)*ratio
3048  qmultg(k) = qmultg(k)*ratio
3049  psacwg(k) = psacwg(k)*ratio
3050  pgsacw(k) = pgsacw(k)*ratio
3051  END IF
3052 
3053 ! CONSERVATION OF QI
3054 
3055  dum = (-prd(k)-mnuccc(k)+prci(k)+prai(k)-qmults(k)-qmultg(k)-qmultr(k)-qmultrg(k) &
3056  -mnuccd(k)+praci(k)+pracis(k)-eprd(k)-psacwi(k))*dt
3057 
3058  IF (dum.GT.qi3d(k).AND.qi3d(k).GE.qsmall) THEN
3059 
3060  ratio = (qi3d(k)/dt+prd(k)+mnuccc(k)+qmults(k)+qmultg(k)+qmultr(k)+qmultrg(k)+ &
3061  mnuccd(k)+psacwi(k))/ &
3062  (prci(k)+prai(k)+praci(k)+pracis(k)-eprd(k))
3063 
3064  prci(k) = prci(k)*ratio
3065  prai(k) = prai(k)*ratio
3066  praci(k) = praci(k)*ratio
3067  pracis(k) = pracis(k)*ratio
3068  eprd(k) = eprd(k)*ratio
3069 
3070  END IF
3071 
3072 ! CONSERVATION OF QR
3073 
3074  dum=((pracs(k)-pre(k))+(qmultr(k)+qmultrg(k)-prc(k))+(mnuccr(k)-pra(k))+ &
3075  piacr(k)+piacrs(k)+pgracs(k)+pracg(k))*dt
3076 
3077  IF (dum.GT.qr3d(k).AND.qr3d(k).GE.qsmall) THEN
3078 
3079  ratio = (qr3d(k)/dt+prc(k)+pra(k))/ &
3080  (-pre(k)+qmultr(k)+qmultrg(k)+pracs(k)+mnuccr(k)+piacr(k)+piacrs(k)+pgracs(k)+pracg(k))
3081 
3082  pre(k) = pre(k)*ratio
3083  pracs(k) = pracs(k)*ratio
3084  qmultr(k) = qmultr(k)*ratio
3085  qmultrg(k) = qmultrg(k)*ratio
3086  mnuccr(k) = mnuccr(k)*ratio
3087  piacr(k) = piacr(k)*ratio
3088  piacrs(k) = piacrs(k)*ratio
3089  pgracs(k) = pgracs(k)*ratio
3090  pracg(k) = pracg(k)*ratio
3091 
3092  END IF
3093 
3094 ! CONSERVATION OF QNI
3095 ! CONSERVATION FOR GRAUPEL SCHEME
3096 
3097  IF (igraup.EQ.0) THEN
3098 
3099  dum = (-prds(k)-psacws(k)-prai(k)-prci(k)-pracs(k)-eprds(k)+psacr(k)-piacrs(k)-pracis(k))*dt
3100 
3101  IF (dum.GT.qni3d(k).AND.qni3d(k).GE.qsmall) THEN
3102 
3103  ratio = (qni3d(k)/dt+prds(k)+psacws(k)+prai(k)+prci(k)+pracs(k)+piacrs(k)+pracis(k))/(-eprds(k)+psacr(k))
3104 
3105  eprds(k) = eprds(k)*ratio
3106  psacr(k) = psacr(k)*ratio
3107 
3108  END IF
3109 
3110 ! FOR NO GRAUPEL, NEED TO INCLUDE FREEZING OF RAIN FOR SNOW
3111  ELSE IF (igraup.EQ.1) THEN
3112 
3113  dum = (-prds(k)-psacws(k)-prai(k)-prci(k)-pracs(k)-eprds(k)+psacr(k)-piacrs(k)-pracis(k)-mnuccr(k))*dt
3114 
3115  IF (dum.GT.qni3d(k).AND.qni3d(k).GE.qsmall) THEN
3116 
3117  ratio = (qni3d(k)/dt+prds(k)+psacws(k)+prai(k)+prci(k)+pracs(k)+piacrs(k)+pracis(k)+mnuccr(k))/(-eprds(k)+psacr(k))
3118 
3119  eprds(k) = eprds(k)*ratio
3120  psacr(k) = psacr(k)*ratio
3121 
3122  END IF
3123 
3124  END IF
3125 
3126 ! CONSERVATION OF QG
3127 
3128  dum = (-psacwg(k)-pracg(k)-pgsacw(k)-pgracs(k)-prdg(k)-mnuccr(k)-eprdg(k)-piacr(k)-praci(k)-psacr(k))*dt
3129 
3130  IF (dum.GT.qg3d(k).AND.qg3d(k).GE.qsmall) THEN
3131 
3132  ratio = (qg3d(k)/dt+psacwg(k)+pracg(k)+pgsacw(k)+pgracs(k)+prdg(k)+mnuccr(k)+psacr(k)+&
3133  piacr(k)+praci(k))/(-eprdg(k))
3134 
3135  eprdg(k) = eprdg(k)*ratio
3136 
3137  END IF
3138 
3139 ! TENDENCIES
3140 
3141  qv3dten(k) = qv3dten(k)+(-pre(k)-prd(k)-prds(k)-mnuccd(k)-eprd(k)-eprds(k)-prdg(k)-eprdg(k))
3142 
3143 ! BUG FIX HM, 3/1/11, INCLUDE PIACR AND PIACRS
3144  t3dten(k) = t3dten(k)+(pre(k) &
3145  *xxlv(k)+(prd(k)+prds(k)+ &
3146  mnuccd(k)+eprd(k)+eprds(k)+prdg(k)+eprdg(k))*xxls(k)+ &
3147  (psacws(k)+psacwi(k)+mnuccc(k)+mnuccr(k)+ &
3148  qmults(k)+qmultg(k)+qmultr(k)+qmultrg(k)+pracs(k) &
3149  +psacwg(k)+pracg(k)+pgsacw(k)+pgracs(k)+piacr(k)+piacrs(k))*xlf(k))/cpm(k)
3150 
3151  qc3dten(k) = qc3dten(k)+ &
3152  (-pra(k)-prc(k)-mnuccc(k)+pcc(k)- &
3153  psacws(k)-psacwi(k)-qmults(k)-qmultg(k)-psacwg(k)-pgsacw(k))
3154  qi3dten(k) = qi3dten(k)+ &
3155  (prd(k)+eprd(k)+psacwi(k)+mnuccc(k)-prci(k)- &
3156  prai(k)+qmults(k)+qmultg(k)+qmultr(k)+qmultrg(k)+mnuccd(k)-praci(k)-pracis(k))
3157  qr3dten(k) = qr3dten(k)+ &
3158  (pre(k)+pra(k)+prc(k)-pracs(k)-mnuccr(k)-qmultr(k)-qmultrg(k) &
3159  -piacr(k)-piacrs(k)-pracg(k)-pgracs(k))
3160  IF (igraup.EQ.0) THEN
3161 
3162  qni3dten(k) = qni3dten(k)+ &
3163  (prai(k)+psacws(k)+prds(k)+pracs(k)+prci(k)+eprds(k)-psacr(k)+piacrs(k)+pracis(k))
3164  ns3dten(k) = ns3dten(k)+(nsagg(k)+nprci(k)-nscng(k)-ngracs(k)+niacrs(k))
3165  qg3dten(k) = qg3dten(k)+(pracg(k)+psacwg(k)+pgsacw(k)+pgracs(k)+ &
3166  prdg(k)+eprdg(k)+mnuccr(k)+piacr(k)+praci(k)+psacr(k))
3167  ng3dten(k) = ng3dten(k)+(nscng(k)+ngracs(k)+nnuccr(k)+niacr(k))
3168 
3169 ! FOR NO GRAUPEL, NEED TO INCLUDE FREEZING OF RAIN FOR SNOW
3170  ELSE IF (igraup.EQ.1) THEN
3171 
3172  qni3dten(k) = qni3dten(k)+ &
3173  (prai(k)+psacws(k)+prds(k)+pracs(k)+prci(k)+eprds(k)-psacr(k)+piacrs(k)+pracis(k)+mnuccr(k))
3174  ns3dten(k) = ns3dten(k)+(nsagg(k)+nprci(k)-nscng(k)-ngracs(k)+niacrs(k)+nnuccr(k))
3175 
3176  END IF
3177 
3178  nc3dten(k) = nc3dten(k)+(-nnuccc(k)-npsacws(k) &
3179  -npra(k)-nprc(k)-npsacwi(k)-npsacwg(k))
3180 
3181  ni3dten(k) = ni3dten(k)+ &
3182  (nnuccc(k)-nprci(k)-nprai(k)+nmults(k)+nmultg(k)+nmultr(k)+nmultrg(k)+ &
3183  nnuccd(k)-niacr(k)-niacrs(k))
3184 
3185  nr3dten(k) = nr3dten(k)+(nprc1(k)-npracs(k)-nnuccr(k) &
3186  +nragg(k)-niacr(k)-niacrs(k)-npracg(k)-ngracs(k))
3187 
3188 ! HM ADD, WRF-CHEM, ADD TENDENCIES FOR C2PREC
3189 
3190  c2prec(k) = pra(k)+prc(k)+psacws(k)+qmults(k)+qmultg(k)+psacwg(k)+ &
3191  pgsacw(k)+mnuccc(k)+psacwi(k)
3192 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3193 ! NOW CALCULATE SATURATION ADJUSTMENT TO CONDENSE EXTRA VAPOR ABOVE
3194 ! WATER SATURATION
3195 
3196  dumt = t3d(k)+dt*t3dten(k)
3197  dumqv = qv3d(k) + dt * qv3dten(k)
3198 
3199  ! hm, add fix for low pressure, 5/12/10
3200  dum=min(0.99*pres(k),polysvp(dumt,0))
3201  dumqss = ep_2*dum/(pres(k)-dum)
3202 
3203  dumqc = qc3d(k) + dt * qc3dten(k)
3204 
3205  dumqc = max(dumqc,0.)
3206 
3207 ! SATURATION ADJUSTMENT FOR LIQUID
3208 
3209  dums = dumqv-dumqss
3210 
3211  pcc(k) = dums/(1.+xxlv(k)**2*dumqss/(cpm(k)*rv*dumt**2))/dt
3212 
3213  IF (pcc(k)*dt+dumqc.LT.0.) THEN
3214  pcc(k) = -dumqc/dt
3215  END IF
3216 
3217  qv3dten(k) = qv3dten(k)-pcc(k)
3218  t3dten(k) = t3dten(k)+pcc(k)*xxlv(k)/cpm(k)
3219  qc3dten(k) = qc3dten(k)+pcc(k)
3220 ! Fortran version
3221 !.......................................................................
3222 ! ACTIVATION OF CLOUD DROPLETS
3223 ! ACTIVATION OF DROPLET CURRENTLY NOT CALCULATED
3224 ! DROPLET CONCENTRATION IS SPECIFIED !!!!!
3225 
3226 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3227 ! SUBLIMATE, MELT, OR EVAPORATE NUMBER CONCENTRATION
3228 ! THIS FORMULATION ASSUMES 1:1 RATIO BETWEEN MASS LOSS AND
3229 ! LOSS OF NUMBER CONCENTRATION
3230 
3231 ! IF (PCC(K).LT.0.) THEN
3232 ! DUM = PCC(K)*DT/QC3D(K)
3233 ! DUM = MAX(-1.,DUM)
3234 ! NSUBC(K) = DUM*NC3D(K)/DT
3235 ! END IF
3236 
3237  IF (eprd(k).LT.0.) THEN
3238  dum = eprd(k)*dt/qi3d(k)
3239  dum = max(-1.,dum)
3240  nsubi(k) = dum*ni3d(k)/dt
3241  END IF
3242  IF (eprds(k).LT.0.) THEN
3243  dum = eprds(k)*dt/qni3d(k)
3244  dum = max(-1.,dum)
3245  nsubs(k) = dum*ns3d(k)/dt
3246  END IF
3247  IF (pre(k).LT.0.) THEN
3248  dum = pre(k)*dt/qr3d(k)
3249  dum = max(-1.,dum)
3250  nsubr(k) = dum*nr3d(k)/dt
3251  END IF
3252  IF (eprdg(k).LT.0.) THEN
3253  dum = eprdg(k)*dt/qg3d(k)
3254  dum = max(-1.,dum)
3255  nsubg(k) = dum*ng3d(k)/dt
3256  END IF
3257 
3258 ! nsubr(k)=0.
3259 ! nsubs(k)=0.
3260 ! nsubg(k)=0.
3261 
3262 ! UPDATE TENDENCIES
3263 
3264 ! NC3DTEN(K) = NC3DTEN(K)+NSUBC(K)
3265  ni3dten(k) = ni3dten(k)+nsubi(k)
3266  ns3dten(k) = ns3dten(k)+nsubs(k)
3267  ng3dten(k) = ng3dten(k)+nsubg(k)
3268  nr3dten(k) = nr3dten(k)+nsubr(k)
3269 
3270  END IF !!!!!! TEMPERATURE
3271 
3272 ! SWITCH LTRUE TO 1, SINCE HYDROMETEORS ARE PRESENT
3273  ltrue = 1
3274 
3275  200 CONTINUE
3276 
3277  END DO
3278 
3279 ! INITIALIZE PRECIP AND SNOW RATES
3280  precrt = 0.
3281  snowrt = 0.
3282 ! hm added 7/13/13
3283  snowprt = 0.
3284  grplprt = 0.
3285 
3286 ! IF THERE ARE NO HYDROMETEORS, THEN SKIP TO END OF SUBROUTINE
3287  DO k = kts,kte
3288 ! Fortran version
3289  END DO
3290  IF (ltrue.EQ.0) GOTO 400
3291 
3292 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3293 !.......................................................................
3294 ! CALCULATE SEDIMENATION
3295 ! THE NUMERICS HERE FOLLOW FROM REISNER ET AL. (1998)
3296 ! FALLOUT TERMS ARE CALCULATED ON SPLIT TIME STEPS TO ENSURE NUMERICAL
3297 ! STABILITY, I.E. COURANT# < 1
3298 
3299 !.......................................................................
3300 
3301  nstep = 1
3302 
3303  DO k = kte,kts,-1
3304 
3305  dumi(k) = qi3d(k)+qi3dten(k)*dt
3306  dumqs(k) = qni3d(k)+qni3dten(k)*dt
3307  dumr(k) = qr3d(k)+qr3dten(k)*dt
3308  dumfni(k) = ni3d(k)+ni3dten(k)*dt
3309  dumfns(k) = ns3d(k)+ns3dten(k)*dt
3310  dumfnr(k) = nr3d(k)+nr3dten(k)*dt
3311  dumc(k) = qc3d(k)+qc3dten(k)*dt
3312  dumfnc(k) = nc3d(k)+nc3dten(k)*dt
3313  dumg(k) = qg3d(k)+qg3dten(k)*dt
3314  dumfng(k) = ng3d(k)+ng3dten(k)*dt
3315 
3316 ! SWITCH FOR CONSTANT DROPLET NUMBER
3317  IF (iinum.EQ.1) THEN
3318  dumfnc(k) = nc3d(k)
3319  END IF
3320 
3321 ! GET DUMMY LAMDA FOR SEDIMENTATION CALCULATIONS
3322 
3323 ! MAKE SURE NUMBER CONCENTRATIONS ARE POSITIVE
3324  dumfni(k) = max(0.,dumfni(k))
3325  dumfns(k) = max(0.,dumfns(k))
3326  dumfnc(k) = max(0.,dumfnc(k))
3327  dumfnr(k) = max(0.,dumfnr(k))
3328  dumfng(k) = max(0.,dumfng(k))
3329 
3330 !......................................................................
3331 ! CLOUD ICE
3332 
3333  IF (dumi(k).GE.qsmall) THEN
3334  dlami = (cons12*dumfni(k)/dumi(k))**(1./di)
3335  dlami=max(dlami,lammini)
3336  dlami=min(dlami,lammaxi)
3337  END IF
3338 !......................................................................
3339 ! RAIN
3340 
3341  IF (dumr(k).GE.qsmall) THEN
3342  dlamr = (pi*rhow*dumfnr(k)/dumr(k))**(1./3.)
3343  dlamr=max(dlamr,lamminr)
3344  dlamr=min(dlamr,lammaxr)
3345  END IF
3346 !......................................................................
3347 ! CLOUD DROPLETS
3348 
3349  IF (dumc(k).GE.qsmall) THEN
3350  dum = pres(k)/(287.15*t3d(k))
3351  pgam(k)=0.0005714*(nc3d(k)/1.e6*dum)+0.2714
3352  pgam(k)=1./(pgam(k)**2)-1.
3353  pgam(k)=max(pgam(k),2.)
3354  pgam(k)=min(pgam(k),10.)
3355 
3356  dlamc = (cons26*dumfnc(k)*gamma(pgam(k)+4.)/(dumc(k)*gamma(pgam(k)+1.)))**(1./3.)
3357  lammin = (pgam(k)+1.)/60.e-6
3358  lammax = (pgam(k)+1.)/1.e-6
3359  dlamc=max(dlamc,lammin)
3360  dlamc=min(dlamc,lammax)
3361  END IF
3362 !......................................................................
3363 ! SNOW
3364 
3365  IF (dumqs(k).GE.qsmall) THEN
3366  dlams = (cons1*dumfns(k)/ dumqs(k))**(1./ds)
3367  dlams=max(dlams,lammins)
3368  dlams=min(dlams,lammaxs)
3369  END IF
3370 !......................................................................
3371 ! GRAUPEL
3372 
3373  IF (dumg(k).GE.qsmall) THEN
3374  dlamg = (cons2*dumfng(k)/ dumg(k))**(1./dg)
3375  dlamg=max(dlamg,lamming)
3376  dlamg=min(dlamg,lammaxg)
3377  END IF
3378 !......................................................................
3379 ! CALCULATE NUMBER-WEIGHTED AND MASS-WEIGHTED TERMINAL FALL SPEEDS
3380 
3381 ! CLOUD WATER
3382 
3383  IF (dumc(k).GE.qsmall) THEN
3384  unc = acn(k)*gamma(1.+bc+pgam(k))/ (dlamc**bc*gamma(pgam(k)+1.))
3385  umc = acn(k)*gamma(4.+bc+pgam(k))/ (dlamc**bc*gamma(pgam(k)+4.))
3386  ELSE
3387  umc = 0.
3388  unc = 0.
3389  END IF
3390 
3391  IF (dumi(k).GE.qsmall) THEN
3392  uni = ain(k)*cons27/dlami**bi
3393  umi = ain(k)*cons28/(dlami**bi)
3394  ELSE
3395  umi = 0.
3396  uni = 0.
3397  END IF
3398 
3399  IF (dumr(k).GE.qsmall) THEN
3400  unr = arn(k)*cons6/dlamr**br
3401  umr = arn(k)*cons4/(dlamr**br)
3402  ELSE
3403  umr = 0.
3404  unr = 0.
3405  END IF
3406 
3407  IF (dumqs(k).GE.qsmall) THEN
3408  ums = asn(k)*cons3/(dlams**bs)
3409  uns = asn(k)*cons5/dlams**bs
3410  ELSE
3411  ums = 0.
3412  uns = 0.
3413  END IF
3414 
3415  IF (dumg(k).GE.qsmall) THEN
3416  umg = agn(k)*cons7/(dlamg**bg)
3417  ung = agn(k)*cons8/dlamg**bg
3418  ELSE
3419  umg = 0.
3420  ung = 0.
3421  END IF
3422 
3423 ! SET REALISTIC LIMITS ON FALLSPEED
3424 
3425 ! bug fix, 10/08/09
3426  dum=(rhosu/rho(k))**0.54
3427  ums=min(ums,1.2*dum)
3428  uns=min(uns,1.2*dum)
3429 ! fix 053011
3430 ! fix for correction by AA 4/6/11
3431  umi=min(umi,1.2*(rhosu/rho(k))**0.35)
3432  uni=min(uni,1.2*(rhosu/rho(k))**0.35)
3433  umr=min(umr,9.1*dum)
3434  unr=min(unr,9.1*dum)
3435  umg=min(umg,20.*dum)
3436  ung=min(ung,20.*dum)
3437 
3438  fr(k) = umr
3439  fi(k) = umi
3440  fni(k) = uni
3441  fs(k) = ums
3442  fns(k) = uns
3443  fnr(k) = unr
3444  fc(k) = umc
3445  fnc(k) = unc
3446  fg(k) = umg
3447  fng(k) = ung
3448 
3449 ! V3.3 MODIFY FALLSPEED BELOW LEVEL OF PRECIP
3450 
3451  IF (k.LE.kte-1) THEN
3452  IF (fr(k).LT.1.e-10) THEN
3453  fr(k)=fr(k+1)
3454  END IF
3455  IF (fi(k).LT.1.e-10) THEN
3456  fi(k)=fi(k+1)
3457  END IF
3458  IF (fni(k).LT.1.e-10) THEN
3459  fni(k)=fni(k+1)
3460  END IF
3461  IF (fs(k).LT.1.e-10) THEN
3462  fs(k)=fs(k+1)
3463  END IF
3464  IF (fns(k).LT.1.e-10) THEN
3465  fns(k)=fns(k+1)
3466  END IF
3467  IF (fnr(k).LT.1.e-10) THEN
3468  fnr(k)=fnr(k+1)
3469  END IF
3470  IF (fc(k).LT.1.e-10) THEN
3471  fc(k)=fc(k+1)
3472  END IF
3473  IF (fnc(k).LT.1.e-10) THEN
3474  fnc(k)=fnc(k+1)
3475  END IF
3476  IF (fg(k).LT.1.e-10) THEN
3477  fg(k)=fg(k+1)
3478  END IF
3479  IF (fng(k).LT.1.e-10) THEN
3480  fng(k)=fng(k+1)
3481  END IF
3482  END IF ! K LE KTE-1
3483 
3484 ! CALCULATE NUMBER OF SPLIT TIME STEPS
3485 
3486  rgvm = max(fr(k),fi(k),fs(k),fc(k),fni(k),fnr(k),fns(k),fnc(k),fg(k),fng(k))
3487 ! VVT CHANGED IFIX -> INT (GENERIC FUNCTION)
3488  nstep = max(int(rgvm*dt/dzq(k)+1.),nstep)
3489 ! Fortran version
3490 ! MULTIPLY VARIABLES BY RHO
3491  dumr(k) = dumr(k)*rho(k)
3492  dumi(k) = dumi(k)*rho(k)
3493  dumfni(k) = dumfni(k)*rho(k)
3494  dumqs(k) = dumqs(k)*rho(k)
3495  dumfns(k) = dumfns(k)*rho(k)
3496  dumfnr(k) = dumfnr(k)*rho(k)
3497  dumc(k) = dumc(k)*rho(k)
3498  dumfnc(k) = dumfnc(k)*rho(k)
3499  dumg(k) = dumg(k)*rho(k)
3500  dumfng(k) = dumfng(k)*rho(k)
3501 
3502  END DO
3503 
3504  DO n = 1,nstep
3505 
3506  DO k = kts,kte
3507  faloutr(k) = fr(k)*dumr(k)
3508  falouti(k) = fi(k)*dumi(k)
3509  faloutni(k) = fni(k)*dumfni(k)
3510  falouts(k) = fs(k)*dumqs(k)
3511  faloutns(k) = fns(k)*dumfns(k)
3512  faloutnr(k) = fnr(k)*dumfnr(k)
3513  faloutc(k) = fc(k)*dumc(k)
3514  faloutnc(k) = fnc(k)*dumfnc(k)
3515  faloutg(k) = fg(k)*dumg(k)
3516  faloutng(k) = fng(k)*dumfng(k)
3517  END DO
3518 
3519 ! TOP OF MODEL
3520 
3521  k = kte
3522  faltndr = faloutr(k)/dzq(k)
3523  faltndi = falouti(k)/dzq(k)
3524  faltndni = faloutni(k)/dzq(k)
3525  faltnds = falouts(k)/dzq(k)
3526  faltndns = faloutns(k)/dzq(k)
3527  faltndnr = faloutnr(k)/dzq(k)
3528  faltndc = faloutc(k)/dzq(k)
3529  faltndnc = faloutnc(k)/dzq(k)
3530  faltndg = faloutg(k)/dzq(k)
3531  faltndng = faloutng(k)/dzq(k)
3532 ! ADD FALLOUT TERMS TO EULERIAN TENDENCIES
3533 
3534  qrsten(k) = qrsten(k)-faltndr/nstep/rho(k)
3535  qisten(k) = qisten(k)-faltndi/nstep/rho(k)
3536  ni3dten(k) = ni3dten(k)-faltndni/nstep/rho(k)
3537  qnisten(k) = qnisten(k)-faltnds/nstep/rho(k)
3538  ns3dten(k) = ns3dten(k)-faltndns/nstep/rho(k)
3539  nr3dten(k) = nr3dten(k)-faltndnr/nstep/rho(k)
3540  qcsten(k) = qcsten(k)-faltndc/nstep/rho(k)
3541  nc3dten(k) = nc3dten(k)-faltndnc/nstep/rho(k)
3542  qgsten(k) = qgsten(k)-faltndg/nstep/rho(k)
3543  ng3dten(k) = ng3dten(k)-faltndng/nstep/rho(k)
3544 
3545  dumr(k) = dumr(k)-faltndr*dt/nstep
3546  dumi(k) = dumi(k)-faltndi*dt/nstep
3547  dumfni(k) = dumfni(k)-faltndni*dt/nstep
3548  dumqs(k) = dumqs(k)-faltnds*dt/nstep
3549  dumfns(k) = dumfns(k)-faltndns*dt/nstep
3550  dumfnr(k) = dumfnr(k)-faltndnr*dt/nstep
3551  dumc(k) = dumc(k)-faltndc*dt/nstep
3552  dumfnc(k) = dumfnc(k)-faltndnc*dt/nstep
3553  dumg(k) = dumg(k)-faltndg*dt/nstep
3554  dumfng(k) = dumfng(k)-faltndng*dt/nstep
3555 
3556  DO k = kte-1,kts,-1
3557  faltndr = (faloutr(k+1)-faloutr(k))/dzq(k)
3558  faltndi = (falouti(k+1)-falouti(k))/dzq(k)
3559  faltndni = (faloutni(k+1)-faloutni(k))/dzq(k)
3560  faltnds = (falouts(k+1)-falouts(k))/dzq(k)
3561  faltndns = (faloutns(k+1)-faloutns(k))/dzq(k)
3562  faltndnr = (faloutnr(k+1)-faloutnr(k))/dzq(k)
3563  faltndc = (faloutc(k+1)-faloutc(k))/dzq(k)
3564  faltndnc = (faloutnc(k+1)-faloutnc(k))/dzq(k)
3565  faltndg = (faloutg(k+1)-faloutg(k))/dzq(k)
3566  faltndng = (faloutng(k+1)-faloutng(k))/dzq(k)
3567 
3568 ! ADD FALLOUT TERMS TO EULERIAN TENDENCIES
3569 
3570  qrsten(k) = qrsten(k)+faltndr/nstep/rho(k)
3571  qisten(k) = qisten(k)+faltndi/nstep/rho(k)
3572  ni3dten(k) = ni3dten(k)+faltndni/nstep/rho(k)
3573  qnisten(k) = qnisten(k)+faltnds/nstep/rho(k)
3574  ns3dten(k) = ns3dten(k)+faltndns/nstep/rho(k)
3575  nr3dten(k) = nr3dten(k)+faltndnr/nstep/rho(k)
3576  qcsten(k) = qcsten(k)+faltndc/nstep/rho(k)
3577  nc3dten(k) = nc3dten(k)+faltndnc/nstep/rho(k)
3578  qgsten(k) = qgsten(k)+faltndg/nstep/rho(k)
3579  ng3dten(k) = ng3dten(k)+faltndng/nstep/rho(k)
3580 ! Fortran version
3581  dumr(k) = dumr(k)+faltndr*dt/nstep
3582  dumi(k) = dumi(k)+faltndi*dt/nstep
3583  dumfni(k) = dumfni(k)+faltndni*dt/nstep
3584  dumqs(k) = dumqs(k)+faltnds*dt/nstep
3585  dumfns(k) = dumfns(k)+faltndns*dt/nstep
3586  dumfnr(k) = dumfnr(k)+faltndnr*dt/nstep
3587  dumc(k) = dumc(k)+faltndc*dt/nstep
3588  dumfnc(k) = dumfnc(k)+faltndnc*dt/nstep
3589  dumg(k) = dumg(k)+faltndg*dt/nstep
3590  dumfng(k) = dumfng(k)+faltndng*dt/nstep
3591 
3592 ! FOR WRF-CHEM, NEED PRECIP RATES (UNITS OF KG/M^2/S)
3593  csed(k)=csed(k)+faloutc(k)/nstep
3594  ised(k)=ised(k)+falouti(k)/nstep
3595  ssed(k)=ssed(k)+falouts(k)/nstep
3596  gsed(k)=gsed(k)+faloutg(k)/nstep
3597  rsed(k)=rsed(k)+faloutr(k)/nstep
3598  END DO
3599 
3600 ! GET PRECIPITATION AND SNOWFALL ACCUMULATION DURING THE TIME STEP
3601 ! FACTOR OF 1000 CONVERTS FROM M TO MM, BUT DIVISION BY DENSITY
3602 ! OF LIQUID WATER CANCELS THIS FACTOR OF 1000
3603 
3604  precrt = precrt+(faloutr(kts)+faloutc(kts)+falouts(kts)+falouti(kts)+faloutg(kts)) &
3605  *dt/nstep
3606  snowrt = snowrt+(falouts(kts)+falouti(kts)+faloutg(kts))*dt/nstep
3607 ! hm added 7/13/13
3608  snowprt = snowprt+(falouti(kts)+falouts(kts))*dt/nstep
3609  grplprt = grplprt+(faloutg(kts))*dt/nstep
3610  END DO
3611 
3612  DO k=kts,kte
3613 ! Fortran version
3614 ! ADD ON SEDIMENTATION TENDENCIES FOR MIXING RATIO TO REST OF TENDENCIES
3615 
3616  qr3dten(k)=qr3dten(k)+qrsten(k)
3617  qi3dten(k)=qi3dten(k)+qisten(k)
3618  qc3dten(k)=qc3dten(k)+qcsten(k)
3619  qg3dten(k)=qg3dten(k)+qgsten(k)
3620  qni3dten(k)=qni3dten(k)+qnisten(k)
3621 ! Fortran version
3622 ! PUT ALL CLOUD ICE IN SNOW CATEGORY IF MEAN DIAMETER EXCEEDS 2 * dcs
3623 
3624 !hm 4/7/09 bug fix
3625 ! IF (QI3D(K).GE.QSMALL.AND.T3D(K).LT.273.15) THEN
3626  IF (qi3d(k).GE.qsmall.AND.t3d(k).LT.273.15.AND.lami(k).GE.1.e-10) THEN
3627  IF (1./lami(k).GE.2.*dcs) THEN
3628  qni3dten(k) = qni3dten(k)+qi3d(k)/dt+ qi3dten(k)
3629  ns3dten(k) = ns3dten(k)+ni3d(k)/dt+ ni3dten(k)
3630  qi3dten(k) = -qi3d(k)/dt
3631  ni3dten(k) = -ni3d(k)/dt
3632  END IF
3633  END IF
3634 
3635 ! hm add tendencies here, then call sizeparameter
3636 ! to ensure consisitency between mixing ratio and number concentration
3637 
3638  qc3d(k) = qc3d(k)+qc3dten(k)*dt
3639  qi3d(k) = qi3d(k)+qi3dten(k)*dt
3640  qni3d(k) = qni3d(k)+qni3dten(k)*dt
3641  qr3d(k) = qr3d(k)+qr3dten(k)*dt
3642  nc3d(k) = nc3d(k)+nc3dten(k)*dt
3643  ni3d(k) = ni3d(k)+ni3dten(k)*dt
3644  ns3d(k) = ns3d(k)+ns3dten(k)*dt
3645  nr3d(k) = nr3d(k)+nr3dten(k)*dt
3646 ! Fortran version
3647  IF (igraup.EQ.0) THEN
3648  qg3d(k) = qg3d(k)+qg3dten(k)*dt
3649  ng3d(k) = ng3d(k)+ng3dten(k)*dt
3650  END IF
3651 
3652 ! ADD TEMPERATURE AND WATER VAPOR TENDENCIES FROM MICROPHYSICS
3653  t3d(k) = t3d(k)+t3dten(k)*dt
3654  qv3d(k) = qv3d(k)+qv3dten(k)*dt
3655 ! Fortran version
3656 ! SATURATION VAPOR PRESSURE AND MIXING RATIO
3657 
3658 ! hm, add fix for low pressure, 5/12/10
3659  evs(k) = min(0.99*pres(k),polysvp(t3d(k),0)) ! PA
3660  eis(k) = min(0.99*pres(k),polysvp(t3d(k),1)) ! PA
3661 
3662 ! MAKE SURE ICE SATURATION DOESN'T EXCEED WATER SAT. NEAR FREEZING
3663 
3664  IF (eis(k).GT.evs(k)) eis(k) = evs(k)
3665 
3666  qvs(k) = ep_2*evs(k)/(pres(k)-evs(k))
3667  qvi(k) = ep_2*eis(k)/(pres(k)-eis(k))
3668 
3669  qvqvs(k) = qv3d(k)/qvs(k)
3670  qvqvsi(k) = qv3d(k)/qvi(k)
3671 ! Fortran version
3672 ! AT SUBSATURATION, REMOVE SMALL AMOUNTS OF CLOUD/PRECIP WATER
3673 ! hm 7/9/09 change limit to 1.e-8
3674 
3675  IF (qvqvs(k).LT.0.9) THEN
3676  IF (qr3d(k).LT.1.e-8) THEN
3677  qv3d(k)=qv3d(k)+qr3d(k)
3678  t3d(k)=t3d(k)-qr3d(k)*xxlv(k)/cpm(k)
3679  qr3d(k)=0.
3680  END IF
3681  IF (qc3d(k).LT.1.e-8) THEN
3682  qv3d(k)=qv3d(k)+qc3d(k)
3683  t3d(k)=t3d(k)-qc3d(k)*xxlv(k)/cpm(k)
3684  qc3d(k)=0.
3685  END IF
3686  END IF
3687  IF (qvqvsi(k).LT.0.9) THEN
3688  IF (qi3d(k).LT.1.e-8) THEN
3689  qv3d(k)=qv3d(k)+qi3d(k)
3690  t3d(k)=t3d(k)-qi3d(k)*xxls(k)/cpm(k)
3691  qi3d(k)=0.
3692  END IF
3693  IF (qni3d(k).LT.1.e-8) THEN
3694  qv3d(k)=qv3d(k)+qni3d(k)
3695  t3d(k)=t3d(k)-qni3d(k)*xxls(k)/cpm(k)
3696  qni3d(k)=0.
3697  END IF
3698  IF (qg3d(k).LT.1.e-8) THEN
3699  qv3d(k)=qv3d(k)+qg3d(k)
3700  t3d(k)=t3d(k)-qg3d(k)*xxls(k)/cpm(k)
3701  qg3d(k)=0.
3702  END IF
3703  END IF
3704 ! Fortran version
3705 !..................................................................
3706 ! IF MIXING RATIO < QSMALL SET MIXING RATIO AND NUMBER CONC TO ZERO
3707 
3708  IF (qc3d(k).LT.qsmall) THEN
3709  qc3d(k) = 0.
3710  nc3d(k) = 0.
3711  effc(k) = 0.
3712  END IF
3713  IF (qr3d(k).LT.qsmall) THEN
3714  qr3d(k) = 0.
3715  nr3d(k) = 0.
3716  effr(k) = 0.
3717  END IF
3718  IF (qi3d(k).LT.qsmall) THEN
3719  qi3d(k) = 0.
3720  ni3d(k) = 0.
3721  effi(k) = 0.
3722  END IF
3723  IF (qni3d(k).LT.qsmall) THEN
3724  qni3d(k) = 0.
3725  ns3d(k) = 0.
3726  effs(k) = 0.
3727  END IF
3728  IF (qg3d(k).LT.qsmall) THEN
3729  qg3d(k) = 0.
3730  ng3d(k) = 0.
3731  effg(k) = 0.
3732  END IF
3733 ! Fortran version
3734 !..................................
3735 ! IF THERE IS NO CLOUD/PRECIP WATER, THEN SKIP CALCULATIONS
3736 
3737  IF (qc3d(k).LT.qsmall.AND.qi3d(k).LT.qsmall.AND.qni3d(k).LT.qsmall &
3738  .AND.qr3d(k).LT.qsmall.AND.qg3d(k).LT.qsmall) GOTO 500
3739 
3740 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3741 ! CALCULATE INSTANTANEOUS PROCESSES
3742 
3743 ! ADD MELTING OF CLOUD ICE TO FORM RAIN
3744 
3745  IF (qi3d(k).GE.qsmall.AND.t3d(k).GE.273.15) THEN
3746  qr3d(k) = qr3d(k)+qi3d(k)
3747  t3d(k) = t3d(k)-qi3d(k)*xlf(k)/cpm(k)
3748  qi3d(k) = 0.
3749  nr3d(k) = nr3d(k)+ni3d(k)
3750  ni3d(k) = 0.
3751  END IF
3752 ! Fortran version
3753 ! ****SENSITIVITY - NO ICE
3754  IF (iliq.EQ.1) GOTO 778
3755 
3756 ! HOMOGENEOUS FREEZING OF CLOUD WATER
3757 
3758  IF (t3d(k).LE.233.15.AND.qc3d(k).GE.qsmall) THEN
3759  qi3d(k)=qi3d(k)+qc3d(k)
3760  t3d(k)=t3d(k)+qc3d(k)*xlf(k)/cpm(k)
3761  qc3d(k)=0.
3762  ni3d(k)=ni3d(k)+nc3d(k)
3763  nc3d(k)=0.
3764  END IF
3765 ! Fortran version
3766 ! HOMOGENEOUS FREEZING OF RAIN
3767 
3768  IF (igraup.EQ.0) THEN
3769 
3770  IF (t3d(k).LE.233.15.AND.qr3d(k).GE.qsmall) THEN
3771  qg3d(k) = qg3d(k)+qr3d(k)
3772  t3d(k) = t3d(k)+qr3d(k)*xlf(k)/cpm(k)
3773  qr3d(k) = 0.
3774  ng3d(k) = ng3d(k)+ nr3d(k)
3775  nr3d(k) = 0.
3776  END IF
3777 
3778  ELSE IF (igraup.EQ.1) THEN
3779 
3780  IF (t3d(k).LE.233.15.AND.qr3d(k).GE.qsmall) THEN
3781  qni3d(k) = qni3d(k)+qr3d(k)
3782  t3d(k) = t3d(k)+qr3d(k)*xlf(k)/cpm(k)
3783  qr3d(k) = 0.
3784  ns3d(k) = ns3d(k)+nr3d(k)
3785  nr3d(k) = 0.
3786  END IF
3787 
3788  END IF
3789 ! Fortran version
3790  778 CONTINUE
3791 
3792 ! MAKE SURE NUMBER CONCENTRATIONS AREN'T NEGATIVE
3793 
3794  ni3d(k) = max(0.,ni3d(k))
3795  ns3d(k) = max(0.,ns3d(k))
3796  nc3d(k) = max(0.,nc3d(k))
3797  nr3d(k) = max(0.,nr3d(k))
3798  ng3d(k) = max(0.,ng3d(k))
3799 
3800 !......................................................................
3801 ! CLOUD ICE
3802 
3803  IF (qi3d(k).GE.qsmall) THEN
3804  lami(k) = (cons12* &
3805  ni3d(k)/qi3d(k))**(1./di)
3806 
3807 ! CHECK FOR SLOPE
3808 
3809 ! ADJUST VARS
3810 
3811  IF (lami(k).LT.lammini) THEN
3812 
3813  lami(k) = lammini
3814 
3815  n0i(k) = lami(k)**4*qi3d(k)/cons12
3816 
3817  ni3d(k) = n0i(k)/lami(k)
3818  ELSE IF (lami(k).GT.lammaxi) THEN
3819  lami(k) = lammaxi
3820  n0i(k) = lami(k)**4*qi3d(k)/cons12
3821 
3822  ni3d(k) = n0i(k)/lami(k)
3823  END IF
3824  END IF
3825 
3826 !......................................................................
3827 ! RAIN
3828 
3829  IF (qr3d(k).GE.qsmall) THEN
3830  lamr(k) = (pi*rhow*nr3d(k)/qr3d(k))**(1./3.)
3831 
3832 ! CHECK FOR SLOPE
3833 
3834 ! ADJUST VARS
3835 
3836  IF (lamr(k).LT.lamminr) THEN
3837 
3838  lamr(k) = lamminr
3839 
3840  n0rr(k) = lamr(k)**4*qr3d(k)/(pi*rhow)
3841 
3842  nr3d(k) = n0rr(k)/lamr(k)
3843  ELSE IF (lamr(k).GT.lammaxr) THEN
3844  lamr(k) = lammaxr
3845  n0rr(k) = lamr(k)**4*qr3d(k)/(pi*rhow)
3846 
3847  nr3d(k) = n0rr(k)/lamr(k)
3848  END IF
3849 
3850  END IF
3851 
3852 !......................................................................
3853 ! CLOUD DROPLETS
3854 
3855 ! MARTIN ET AL. (1994) FORMULA FOR PGAM
3856 
3857  IF (qc3d(k).GE.qsmall) THEN
3858 
3859  dum = pres(k)/(287.15*t3d(k))
3860  pgam(k)=0.0005714*(nc3d(k)/1.e6*dum)+0.2714
3861  pgam(k)=1./(pgam(k)**2)-1.
3862  pgam(k)=max(pgam(k),2.)
3863  pgam(k)=min(pgam(k),10.)
3864 
3865 ! CALCULATE LAMC
3866 
3867  lamc(k) = (cons26*nc3d(k)*gamma(pgam(k)+4.)/ &
3868  (qc3d(k)*gamma(pgam(k)+1.)))**(1./3.)
3869 
3870 ! LAMMIN, 60 MICRON DIAMETER
3871 ! LAMMAX, 1 MICRON
3872 
3873  lammin = (pgam(k)+1.)/60.e-6
3874  lammax = (pgam(k)+1.)/1.e-6
3875 
3876  IF (lamc(k).LT.lammin) THEN
3877  lamc(k) = lammin
3878  nc3d(k) = exp(3.*log(lamc(k))+log(qc3d(k))+ &
3879  log(gamma(pgam(k)+1.))-log(gamma(pgam(k)+4.)))/cons26
3880 
3881  ELSE IF (lamc(k).GT.lammax) THEN
3882  lamc(k) = lammax
3883  nc3d(k) = exp(3.*log(lamc(k))+log(qc3d(k))+ &
3884  log(gamma(pgam(k)+1.))-log(gamma(pgam(k)+4.)))/cons26
3885 
3886  END IF
3887 
3888  END IF
3889 
3890 !......................................................................
3891 ! SNOW
3892 
3893  IF (qni3d(k).GE.qsmall) THEN
3894  lams(k) = (cons1*ns3d(k)/qni3d(k))**(1./ds)
3895 
3896 ! CHECK FOR SLOPE
3897 
3898 ! ADJUST VARS
3899 
3900  IF (lams(k).LT.lammins) THEN
3901  lams(k) = lammins
3902  n0s(k) = lams(k)**4*qni3d(k)/cons1
3903 
3904  ns3d(k) = n0s(k)/lams(k)
3905 
3906  ELSE IF (lams(k).GT.lammaxs) THEN
3907 
3908  lams(k) = lammaxs
3909  n0s(k) = lams(k)**4*qni3d(k)/cons1
3910  ns3d(k) = n0s(k)/lams(k)
3911  END IF
3912 
3913  END IF
3914 
3915 !......................................................................
3916 ! GRAUPEL
3917 
3918  IF (qg3d(k).GE.qsmall) THEN
3919  lamg(k) = (cons2*ng3d(k)/qg3d(k))**(1./dg)
3920 
3921 ! CHECK FOR SLOPE
3922 
3923 ! ADJUST VARS
3924 
3925  IF (lamg(k).LT.lamming) THEN
3926  lamg(k) = lamming
3927  n0g(k) = lamg(k)**4*qg3d(k)/cons2
3928 
3929  ng3d(k) = n0g(k)/lamg(k)
3930 
3931  ELSE IF (lamg(k).GT.lammaxg) THEN
3932 
3933  lamg(k) = lammaxg
3934  n0g(k) = lamg(k)**4*qg3d(k)/cons2
3935 
3936  ng3d(k) = n0g(k)/lamg(k)
3937  END IF
3938 
3939  END IF
3940 
3941  500 CONTINUE
3942 
3943 ! CALCULATE EFFECTIVE RADIUS
3944 
3945  IF (qi3d(k).GE.qsmall) THEN
3946  effi(k) = 3./lami(k)/2.*1.e6
3947  ELSE
3948  effi(k) = 25.
3949  END IF
3950 
3951  IF (qni3d(k).GE.qsmall) THEN
3952  effs(k) = 3./lams(k)/2.*1.e6
3953  ELSE
3954  effs(k) = 25.
3955  END IF
3956 
3957  IF (qr3d(k).GE.qsmall) THEN
3958  effr(k) = 3./lamr(k)/2.*1.e6
3959  ELSE
3960  effr(k) = 25.
3961  END IF
3962 
3963  IF (qc3d(k).GE.qsmall) THEN
3964  effc(k) = gamma(pgam(k)+4.)/ &
3965  gamma(pgam(k)+3.)/lamc(k)/2.*1.e6
3966  ELSE
3967  effc(k) = 25.
3968  END IF
3969 
3970  IF (qg3d(k).GE.qsmall) THEN
3971  effg(k) = 3./lamg(k)/2.*1.e6
3972  ELSE
3973  effg(k) = 25.
3974  END IF
3975 
3976 ! HM ADD 1/10/06, ADD UPPER BOUND ON ICE NUMBER, THIS IS NEEDED
3977 ! TO PREVENT VERY LARGE ICE NUMBER DUE TO HOMOGENEOUS FREEZING
3978 ! OF DROPLETS, ESPECIALLY WHEN INUM = 1, SET MAX AT 10 CM-3
3979 ! NI3D(K) = MIN(NI3D(K),10.E6/RHO(K))
3980 ! HM, 12/28/12, LOWER MAXIMUM ICE CONCENTRATION TO ADDRESS PROBLEM
3981 ! OF EXCESSIVE AND PERSISTENT ANVIL
3982 ! NOTE: THIS MAY CHANGE/REDUCE SENSITIVITY TO AEROSOL/CCN CONCENTRATION
3983  ni3d(k) = min(ni3d(k),0.3e6/rho(k))
3984 
3985 ! ADD BOUND ON DROPLET NUMBER - CANNOT EXCEED AEROSOL CONCENTRATION
3986  IF (iinum.EQ.0.AND.iact.EQ.2) THEN
3987  nc3d(k) = min(nc3d(k),(nanew1+nanew2)/rho(k))
3988  END IF
3989 ! SWITCH FOR CONSTANT DROPLET NUMBER
3990  IF (iinum.EQ.1) THEN
3991 ! CHANGE NDCNST FROM CM-3 TO KG-1
3992  nc3d(k) = ndcnst*1.e6/rho(k)
3993  END IF
3994 
3995  END DO !!! K LOOP
3996 
3997  400 CONTINUE
3998 
3999 ! ALL DONE !!!!!!!!!!!
4000  RETURN

Referenced by mp_morr_two_moment().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ mp_morr_two_moment()

subroutine, public module_mp_morr_two_moment::mp_morr_two_moment ( integer, intent(in)  ITIMESTEP,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout)  TH,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout)  QV,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout)  QC,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout)  QR,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout)  QI,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout)  QS,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout)  QG,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout)  NI,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout)  NS,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout)  NR,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout)  NG,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(in)  RHO,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(in)  PII,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(in)  P,
real(c_double), intent(in)  DT_IN,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(in)  DZ,
real(c_double), dimension(ims:ime ,jms:jme ), intent(in)  HT,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(in)  W,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout)  RAINNC,
real(c_double), dimension(ims:ime, jms:jme), intent(inout)  RAINNCV,
real(c_double), dimension(ims:ime, jms:jme), intent(inout)  SR,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout)  SNOWNC,
real(c_double), dimension(ims:ime, jms:jme), intent(inout)  SNOWNCV,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout)  GRAUPELNC,
real(c_double), dimension(ims:ime, jms:jme), intent(inout)  GRAUPELNCV,
real(c_double), dimension(ims:ime, jms:kme, kms:jme), intent(inout)  refl_10cm,
logical, intent(in), optional  diagflag,
integer, intent(in), optional  do_radar_ref,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(in)  qrcuten,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(in)  qscuten,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(in)  qicuten,
logical, intent(in), optional  F_QNDROP,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout), optional  qndrop,
integer, intent(in)  IDS,
integer, intent(in)  IDE,
integer, intent(in)  JDS,
integer, intent(in)  JDE,
integer, intent(in)  KDS,
integer, intent(in)  KDE,
integer, intent(in)  IMS,
integer, intent(in)  IME,
integer, intent(in)  JMS,
integer, intent(in)  JME,
integer, intent(in)  KMS,
integer, intent(in)  KME,
integer, intent(in)  ITS,
integer, intent(in)  ITE,
integer, intent(in)  JTS,
integer, intent(in)  JTE,
integer, intent(in)  KTS,
integer, intent(in)  KTE,
logical, intent(in), optional  wetscav_on,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout), optional  rainprod,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout), optional  evapprod,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout), optional  QLSINK,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout), optional  PRECR,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout), optional  PRECI,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout), optional  PRECS,
real(c_double), dimension(ims:ime, jms:jme, kms:kme), intent(inout), optional  PRECG 
)
599 
600 ! QV - water vapor mixing ratio (kg/kg)
601 ! QC - cloud water mixing ratio (kg/kg)
602 ! QR - rain water mixing ratio (kg/kg)
603 ! QI - cloud ice mixing ratio (kg/kg)
604 ! QS - snow mixing ratio (kg/kg)
605 ! QG - graupel mixing ratio (KG/KG)
606 ! NI - cloud ice number concentration (1/kg)
607 ! NS - Snow Number concentration (1/kg)
608 ! NR - Rain Number concentration (1/kg)
609 ! NG - Graupel number concentration (1/kg)
610 ! NOTE: RHO AND HT NOT USED BY THIS SCHEME AND DO NOT NEED TO BE PASSED INTO SCHEME!!!!
611 ! P - AIR PRESSURE (PA)
612 ! W - VERTICAL AIR VELOCITY (M/S)
613 ! TH - POTENTIAL TEMPERATURE (K)
614 ! PII - exner function - used to convert potential temp to temp
615 ! DZ - difference in height over interface (m)
616 ! DT_IN - model time step (sec)
617 ! ITIMESTEP - time step counter
618 ! RAINNC - accumulated grid-scale precipitation (mm)
619 ! RAINNCV - one time step grid scale precipitation (mm/time step)
620 ! SNOWNC - accumulated grid-scale snow plus cloud ice (mm)
621 ! SNOWNCV - one time step grid scale snow plus cloud ice (mm/time step)
622 ! GRAUPELNC - accumulated grid-scale graupel (mm)
623 ! GRAUPELNCV - one time step grid scale graupel (mm/time step)
624 ! SR - one time step mass ratio of snow to total precip
625 ! qrcuten, rain tendency from parameterized cumulus convection
626 ! qscuten, snow tendency from parameterized cumulus convection
627 ! qicuten, cloud ice tendency from parameterized cumulus convection
628 
629 ! variables below currently not in use, not coupled to PBL or radiation codes
630 ! TKE - turbulence kinetic energy (m^2 s-2), NEEDED FOR DROPLET ACTIVATION (SEE CODE BELOW)
631 ! NCTEND - droplet concentration tendency from pbl (kg-1 s-1)
632 ! NCTEND - CLOUD ICE concentration tendency from pbl (kg-1 s-1)
633 ! KZH - heat eddy diffusion coefficient from YSU scheme (M^2 S-1), NEEDED FOR DROPLET ACTIVATION (SEE CODE BELOW)
634 ! EFFCS - CLOUD DROPLET EFFECTIVE RADIUS OUTPUT TO RADIATION CODE (micron)
635 ! EFFIS - CLOUD DROPLET EFFECTIVE RADIUS OUTPUT TO RADIATION CODE (micron)
636 ! HM, ADDED FOR WRF-CHEM COUPLING
637 ! QLSINK - TENDENCY OF CLOUD WATER TO RAIN, SNOW, GRAUPEL (KG/KG/S)
638 ! CSED,ISED,SSED,GSED,RSED - SEDIMENTATION FLUXES (KG/M^2/S) FOR CLOUD WATER, ICE, SNOW, GRAUPEL, RAIN
639 ! PRECI,PRECS,PRECG,PRECR - SEDIMENTATION FLUXES (KG/M^2/S) FOR ICE, SNOW, GRAUPEL, RAIN
640 
641 ! rainprod - total tendency of conversion of cloud water/ice and graupel to rain (kg kg-1 s-1)
642 ! evapprod - tendency of evaporation of rain (kg kg-1 s-1)
643 
644 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
645 
646 ! reflectivity currently not included!!!!
647 ! REFL_10CM - CALCULATED RADAR REFLECTIVITY AT 10 CM (DBZ)
648 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
649 
650 ! EFFC - DROPLET EFFECTIVE RADIUS (MICRON)
651 ! EFFR - RAIN EFFECTIVE RADIUS (MICRON)
652 ! EFFS - SNOW EFFECTIVE RADIUS (MICRON)
653 ! EFFI - CLOUD ICE EFFECTIVE RADIUS (MICRON)
654 
655 ! ADDITIONAL OUTPUT FROM MICRO - SEDIMENTATION TENDENCIES, NEEDED FOR LIQUID-ICE STATIC ENERGY
656 
657 ! QGSTEN - GRAUPEL SEDIMENTATION TEND (KG/KG/S)
658 ! QRSTEN - RAIN SEDIMENTATION TEND (KG/KG/S)
659 ! QISTEN - CLOUD ICE SEDIMENTATION TEND (KG/KG/S)
660 ! QNISTEN - SNOW SEDIMENTATION TEND (KG/KG/S)
661 ! QCSTEN - CLOUD WATER SEDIMENTATION TEND (KG/KG/S)
662 
663  IMPLICIT NONE
664 
665  INTEGER, INTENT(IN ) :: ids, ide, jds, jde, kds, kde , &
666  ims, ime, jms, jme, kms, kme , &
667  its, ite, jts, jte, kts, kte
668 
669  REAL(C_DOUBLE), DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(INOUT) :: qv, qc, qr, qi, qs, qg, ni, ns, nr, TH, NG
670  REAL(C_DOUBLE), DIMENSION(ims:ime, jms:jme, kms:kme), optional,INTENT(INOUT) :: qndrop
671  REAL(C_DOUBLE), DIMENSION(ims:ime, jms:jme, kms:kme), optional,INTENT(INOUT) :: QLSINK, rainprod, evapprod, PRECI,PRECS,PRECG, &
672  & PRECR
673  REAL(C_DOUBLE), DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(IN ) :: pii, p, dz, rho, w
674 
675  REAL(C_DOUBLE), INTENT(IN):: dt_in
676  INTEGER, INTENT(IN):: ITIMESTEP
677  REAL(C_DOUBLE), INTENT(INOUT), DIMENSION(ims:ime, jms:jme, kms:kme) :: rainnc, snownc, graupelnc
678  REAL(C_DOUBLE), INTENT(INOUT), DIMENSION(ims:ime, jms:jme) :: rainncv, sr, snowncv, graupelncv
679 ! REAL(C_DOUBLE), DIMENSION(ims:ime, jms:jme ), INTENT(INOUT) :: RAINNC, RAINNCV, SR, SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV
680  REAL(C_DOUBLE), DIMENSION(ims:ime, jms:kme, kms:jme), INTENT(INOUT) :: refl_10cm
681  REAL(C_DOUBLE), DIMENSION(ims:ime ,jms:jme ), INTENT(IN ) :: ht
682 
683  LOGICAL, optional, INTENT(IN) :: wetscav_on
684 
685  ! LOCAL VARIABLES
686 
687  REAL(C_DOUBLE), DIMENSION(its:ite, jts:jte, kts:kte) :: effi, effs, effr, EFFG
688  REAL(C_DOUBLE), DIMENSION(its:ite, jts:jte, kts:kte) :: T, EFFC
689 
690  REAL(C_DOUBLE), DIMENSION(kts:kte) :: &
691  QC_TEND1D, QI_TEND1D, QNI_TEND1D, QR_TEND1D, &
692  NI_TEND1D, NS_TEND1D, NR_TEND1D, &
693  QC1D, QI1D, QR1D,NI1D, NS1D, NR1D, QS1D, &
694  T_TEND1D,QV_TEND1D, T1D, QV1D, P1D, W1D, &
695  EFFC1D, EFFI1D, EFFS1D, EFFR1D,DZ1D, &
696  QG_TEND1D, NG_TEND1D, QG1D, NG1D, EFFG1D, &
697 ! ADD SEDIMENTATION TENDENCIES (UNITS OF KG/KG/S)
698  qgsten,qrsten, qisten, qnisten, qcsten, &
699 ! ADD CUMULUS TENDENCIES
700  qrcu1d, qscu1d, qicu1d
701 ! add cumulus tendencies
702 
703  REAL(C_DOUBLE), DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(IN):: qrcuten, qscuten, qicuten
704 
705  LOGICAL, INTENT(IN), OPTIONAL :: F_QNDROP
706  LOGICAL :: flag_qndrop ! wrf-chem
707  integer :: iinum ! wrf-chem
708 
709 ! wrf-chem
710  REAL(C_DOUBLE), DIMENSION(kts:kte) :: nc1d, nc_tend1d,C2PREC,CSED,ISED,SSED,GSED,RSED
711  REAL(C_DOUBLE), DIMENSION(kts:kte) :: rainprod1d, evapprod1d
712 ! HM add reflectivity
713  REAL(C_DOUBLE), DIMENSION(kts:kte) :: dBZ
714 
715  REAL(C_DOUBLE) PRECPRT1D, SNOWRT1D, SNOWPRT1D, GRPLPRT1D ! hm added 7/13/13
716 
717  INTEGER I,J,K
718 
719  REAL(C_DOUBLE) DT
720 
721  LOGICAL, OPTIONAL, INTENT(IN) :: diagflag
722  INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref
723 
724  LOGICAL :: has_wetscav
725 
726  ! return
727  print *,'IN MORR_TWO_MOMENT MAIN ROUTINE '
728 
729 ! below for wrf-chem
730  flag_qndrop = .false.
731  IF ( PRESENT ( f_qndrop ) ) flag_qndrop = f_qndrop
732 !!!!!!!!!!!!!!!!!!!!!!
733 
734  IF( PRESENT( wetscav_on ) ) THEN
735  has_wetscav = wetscav_on
736  ELSE
737  has_wetscav = .false.
738  ENDIF
739 
740  ! Initialize tendencies (all set to 0) and transfer
741  ! array to local variables
742  dt = dt_in
743 
744  ! Currently mixing of number concentrations also is neglected (not coupled with PBL schemes)
745 
746  print *,'IMS IME ',ims,ime
747  print *,'JMS JME ',jms,jme
748  print *,'KMS KME ',kms,kme
749 
750  print *,'ITS ITE ',its,ite
751  print *,'JTS JTE ',jts,jte
752  print *,'KTS KTE ',kts,kte
753 
754  DO i=its,ite
755  DO j=jts,jte
756  DO k=kts,kte
757  t(i,j,k) = th(i,j,k) * pii(i,j,k)
758  END DO
759  END DO
760  END DO
761 
762  do i=its,ite ! i loop (east-west)
763  do j=jts,jte ! j loop (north-south)
764  !
765  ! Transfer 3D arrays into 1D for microphysical calculations
766  !
767 
768 ! hm , initialize 1d tendency arrays to zero
769 
770  do k=kts,kte ! k loop (vertical)
771 
772  qc_tend1d(k) = 0.
773  qi_tend1d(k) = 0.
774  qni_tend1d(k) = 0.
775  qr_tend1d(k) = 0.
776  ni_tend1d(k) = 0.
777  ns_tend1d(k) = 0.
778  nr_tend1d(k) = 0.
779  t_tend1d(k) = 0.
780  qv_tend1d(k) = 0.
781  nc_tend1d(k) = 0. ! wrf-chem
782 
783  qc1d(k) = qc(i,j,k)
784  qi1d(k) = qi(i,j,k)
785  qs1d(k) = qs(i,j,k)
786  qr1d(k) = qr(i,j,k)
787 
788  ni1d(k) = ni(i,j,k)
789 
790  ns1d(k) = ns(i,j,k)
791  nr1d(k) = nr(i,j,k)
792 ! HM ADD GRAUPEL
793  qg1d(k) = qg(i,j,k)
794  ng1d(k) = ng(i,j,k)
795  qg_tend1d(k) = 0.
796  ng_tend1d(k) = 0.
797 
798  t1d(k) = t(i,j,k)
799  qv1d(k) = qv(i,j,k)
800  p1d(k) = p(i,j,k)
801  dz1d(k) = dz(i,j,k)
802  w1d(k) = w(i,j,k)
803 ! add cumulus tendencies, already decoupled
804  qrcu1d(k) = qrcuten(i,j,k)
805  qscu1d(k) = qscuten(i,j,k)
806  qicu1d(k) = qicuten(i,j,k)
807  end do !jdf added this
808 
809 ! below for wrf-chem
810  IF (flag_qndrop .AND. PRESENT( qndrop )) THEN
811  iact = 3
812  DO k = kts, kte
813  nc1d(k)=qndrop(i,j,k)
814  iinum=0
815  ENDDO
816  ELSE
817  DO k = kts, kte
818  nc1d(k)=0. ! temporary placeholder, set to constant in microphysics subroutine
819  iinum=1
820  ENDDO
821  ENDIF
822 
823 !jdf end do
824 
825  call morr_two_moment_micro(i,j,itimestep,kts,kte,qc_tend1d, qi_tend1d, qni_tend1d, qr_tend1d, &
826  ni_tend1d, ns_tend1d, nr_tend1d, &
827  qc1d, qi1d, qs1d, qr1d,ni1d, ns1d, nr1d, &
828  t_tend1d,qv_tend1d, t1d, qv1d, p1d, dz1d, w1d, &
829  precprt1d,snowrt1d, &
830  snowprt1d,grplprt1d, & ! hm added 7/13/13
831  effc1d,effi1d,effs1d,effr1d,dt, &
832  qg_tend1d,ng_tend1d,qg1d,ng1d,effg1d, &
833  qrcu1d, qscu1d, qicu1d, &
834 ! ADD SEDIMENTATION TENDENCIES
835  qgsten,qrsten,qisten,qnisten,qcsten, &
836  nc1d, nc_tend1d, iinum, c2prec,csed,ised,ssed,gsed,rsed)
837 
838  !
839  ! Transfer 1D arrays back into 3D arrays
840  !
841  do k=kts,kte
842 
843  ! hm, add tendencies to update global variables
844  ! HM, TENDENCIES FOR Q AND N NOW ADDED IN M2005MICRO, SO WE
845  ! ONLY NEED TO TRANSFER 1D VARIABLES BACK TO 3D
846 
847  qc(i,j,k) = qc1d(k)
848  qi(i,j,k) = qi1d(k)
849  qs(i,j,k) = qs1d(k)
850  qr(i,j,k) = qr1d(k)
851  ni(i,j,k) = ni1d(k)
852  ns(i,j,k) = ns1d(k)
853  nr(i,j,k) = nr1d(k)
854  qg(i,j,k) = qg1d(k)
855  ng(i,j,k) = ng1d(k)
856 
857  t(i,j,k) = t1d(k)
858  th(i,j,k) = t(i,j,k)/pii(i,j,k) ! CONVERT TEMP BACK TO POTENTIAL TEMP
859  qv(i,j,k) = qv1d(k)
860 
861  effc(i,j,k) = effc1d(k)
862  effi(i,j,k) = effi1d(k)
863  effs(i,j,k) = effs1d(k)
864  effr(i,j,k) = effr1d(k)
865  effg(i,j,k) = effg1d(k)
866 
867 ! wrf-chem
868  IF (flag_qndrop .AND. PRESENT( qndrop )) THEN
869  qndrop(i,j,k) = nc1d(k)
870 !jdf CSED3D(i,j,k) = CSED(k)
871  END IF
872  IF ( PRESENT( qlsink ) ) THEN
873  if(qc(i,j,k)>1.e-10) then
874  qlsink(i,j,k) = c2prec(k)/qc(i,j,k)
875  else
876  qlsink(i,j,k) = 0.0
877  endif
878  END IF
879  IF ( PRESENT( precr ) ) precr(i,j,k) = rsed(k)
880  IF ( PRESENT( preci ) ) preci(i,j,k) = ised(k)
881  IF ( PRESENT( precs ) ) precs(i,j,k) = ssed(k)
882  IF ( PRESENT( precg ) ) precg(i,j,k) = gsed(k)
883 ! EFFECTIVE RADIUS FOR RADIATION CODE (currently not coupled)
884 ! HM, ADD LIMIT TO PREVENT BLOWING UP OPTICAL PROPERTIES, 8/18/07
885 ! EFFCS(I,J,K) = MIN(EFFC(I,J,K),50.)
886 ! EFFCS(I,J,K) = MAX(EFFCS(I,J,K),1.)
887 ! EFFIS(I,J,K) = MIN(EFFI(I,J,K),130.)
888 ! EFFIS(I,J,K) = MAX(EFFIS(I,J,K),13.)
889 
890  end do
891 
892 ! hm modified so that m2005 precip variables correctly match wrf precip variables
893  rainnc(i,j,kts) = rainnc(i,j,kts)+precprt1d
894  rainncv(i,j) = precprt1d
895  snownc(i,j,kts) = snownc(i,j,kts)+snowprt1d
896  snowncv(i,j) = snowprt1d
897  graupelnc(i,j,kts) = graupelnc(i,j,kts)+grplprt1d
898  graupelncv(i,j) = grplprt1d
899  sr(i,j) = snowrt1d/(precprt1d+1.e-12)
900 
901  end do
902  end do
903 

Referenced by mp_morr_two_moment_isohelper::mp_morr_two_moment_c().

Here is the call graph for this function:
Here is the caller graph for this function:

◆ polysvp()

real(c_double) function, public module_mp_morr_two_moment::polysvp ( real(c_double)  T,
integer  TYPE 
)
4006 
4007 !-------------------------------------------
4008 
4009 ! COMPUTE SATURATION VAPOR PRESSURE
4010 
4011 ! POLYSVP RETURNED IN UNITS OF PA.
4012 ! T IS INPUT IN UNITS OF K.
4013 ! TYPE REFERS TO SATURATION WITH RESPECT TO LIQUID (0) OR ICE (1)
4014 
4015 ! REPLACE GOFF-GRATCH WITH FASTER FORMULATION FROM FLATAU ET AL. 1992, TABLE 4 (RIGHT-HAND COLUMN)
4016 
4017  IMPLICIT NONE
4018 
4019  REAL(C_DOUBLE) DUM
4020  REAL(C_DOUBLE) T
4021  INTEGER TYPE
4022 ! ice
4023  real a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i
4024  data a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i /&
4025  6.11147274, 0.503160820, 0.188439774e-1, &
4026  0.420895665e-3, 0.615021634e-5,0.602588177e-7, &
4027  0.385852041e-9, 0.146898966e-11, 0.252751365e-14/
4028 
4029 ! liquid
4030  real a0,a1,a2,a3,a4,a5,a6,a7,a8
4031 
4032 ! V1.7
4033  data a0,a1,a2,a3,a4,a5,a6,a7,a8 /&
4034  6.11239921, 0.443987641, 0.142986287e-1, &
4035  0.264847430e-3, 0.302950461e-5, 0.206739458e-7, &
4036  0.640689451e-10,-0.952447341e-13,-0.976195544e-15/
4037  real dt
4038 
4039 ! ICE
4040 
4041  IF (type.EQ.1) THEN
4042 
4043 ! POLYSVP = 10.**(-9.09718*(273.16/T-1.)-3.56654* &
4044 ! LOG10(273.16/T)+0.876793*(1.-T/273.16)+ &
4045 ! LOG10(6.1071))*100.
4046 ! hm 11/16/20, use Goff-Gratch for T < 195.8 K and Flatau et al. equal or above 195.8 K
4047  if (t.ge.195.8) then
4048  dt=t-273.15
4049  polysvp = a0i + dt*(a1i+dt*(a2i+dt*(a3i+dt*(a4i+dt*(a5i+dt*(a6i+dt*(a7i+a8i*dt)))))))
4050  polysvp = polysvp*100.
4051  else
4052 
4053  polysvp = 10.**(-9.09718*(273.16/t-1.)-3.56654* &
4054  dlog10(273.16d0/t)+0.876793*(1.-t/273.16)+ &
4055  dlog10(6.1071d0))*100.
4056 
4057  end if
4058 
4059  END IF
4060 
4061 ! LIQUID
4062 
4063  IF (type.EQ.0) THEN
4064 
4065 ! POLYSVP = 10.**(-7.90298*(373.16/T-1.)+ &
4066 ! 5.02808*LOG10(373.16/T)- &
4067 ! 1.3816E-7*(10**(11.344*(1.-T/373.16))-1.)+ &
4068 ! 8.1328E-3*(10**(-3.49149*(373.16/T-1.))-1.)+ &
4069 ! LOG10(1013.246))*100.
4070 ! hm 11/16/20, use Goff-Gratch for T < 202.0 K and Flatau et al. equal or above 202.0 K
4071  if (t.ge.202.0) then
4072  dt = t-273.15
4073  polysvp = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt)))))))
4074  polysvp = polysvp*100.
4075  else
4076 
4077 ! note: uncertain below -70 C, but produces physical values (non-negative) unlike flatau
4078  polysvp = 10.**(-7.90298*(373.16/t-1.)+ &
4079  5.02808*dlog10(373.16d0/t)- &
4080  1.3816e-7*(10**(11.344*(1.-t/373.16))-1.)+ &
4081  8.1328e-3*(10**(-3.49149*(373.16/t-1.))-1.)+ &
4082  dlog10(1013.246d0))*100.
4083  end if
4084 
4085  END IF
4086 
4087 

Referenced by calc_saturation_vapor_pressure(), and morr_two_moment_micro().

Here is the caller graph for this function:

Variable Documentation

◆ ac

real(c_double), private module_mp_morr_two_moment::ac
private

Referenced by erf_slow_rhs_post(), and morr_two_moment_init().

◆ ag

real(c_double), private module_mp_morr_two_moment::ag
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ ai

real(c_double), private module_mp_morr_two_moment::ai
private
180  REAL(C_DOUBLE), PRIVATE :: AI,AC,AS,AR,AG ! 'A' PARAMETER IN FALLSPEED-DIAM RELATIONSHIP

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ aimm

real(c_double), private module_mp_morr_two_moment::aimm
private
190  REAL(C_DOUBLE), PRIVATE :: AIMM ! PARAMETER IN BIGG IMMERSION FREEZING

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ ar

real(c_double), private module_mp_morr_two_moment::ar
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ as

real(c_double), private module_mp_morr_two_moment::as
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ bact

real(c_double), private module_mp_morr_two_moment::bact
private
224  REAL(C_DOUBLE), PRIVATE :: BACT ! ACTIVATION PARAMETER

Referenced by morr_two_moment_init().

◆ bc

real(c_double), private module_mp_morr_two_moment::bc
private

Referenced by morr_two_moment_init(), morr_two_moment_micro(), and redistribute_term().

◆ bg

real(c_double), private module_mp_morr_two_moment::bg
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ bi

real(c_double), private module_mp_morr_two_moment::bi
private
181  REAL(C_DOUBLE), PRIVATE :: BI,BC,BS,BR,BG ! 'B' PARAMETER IN FALLSPEED-DIAM RELATIONSHIP

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ bimm

real(c_double), private module_mp_morr_two_moment::bimm
private
191  REAL(C_DOUBLE), PRIVATE :: BIMM ! PARAMETER IN BIGG IMMERSION FREEZING

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ br

real(c_double), private module_mp_morr_two_moment::br
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ bs

real(c_double), private module_mp_morr_two_moment::bs
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ c1

real(c_double), private module_mp_morr_two_moment::c1
private
211  REAL(C_DOUBLE), PRIVATE :: C1 ! 'C' IN NCCN = CS^K (CM-3)

Referenced by SatMethods::Bolton_svp_water(), WaterVaporSat::findsp(), morr_two_moment_init(), and z0_est().

◆ cg

real(c_double), private module_mp_morr_two_moment::cg
private

Referenced by morr_two_moment_init().

◆ ci

real(c_double), private module_mp_morr_two_moment::ci
private
202  REAL(C_DOUBLE), PRIVATE :: CI,DI,CS,DS,CG,DG ! SIZE DISTRIBUTION PARAMETERS FOR CLOUD ICE, SNOW, GRAUPEL

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons1

real(c_double), private module_mp_morr_two_moment::cons1
private
240  REAL(C_DOUBLE), PRIVATE :: CONS1,CONS2,CONS3,CONS4,CONS5,CONS6,CONS7,CONS8,CONS9,CONS10

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons10

real(c_double), private module_mp_morr_two_moment::cons10
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons11

real(c_double), private module_mp_morr_two_moment::cons11
private
241  REAL(C_DOUBLE), PRIVATE :: CONS11,CONS12,CONS13,CONS14,CONS15,CONS16,CONS17,CONS18,CONS19,CONS20

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons12

real(c_double), private module_mp_morr_two_moment::cons12
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons13

real(c_double), private module_mp_morr_two_moment::cons13
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons14

real(c_double), private module_mp_morr_two_moment::cons14
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons15

real(c_double), private module_mp_morr_two_moment::cons15
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons16

real(c_double), private module_mp_morr_two_moment::cons16
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons17

real(c_double), private module_mp_morr_two_moment::cons17
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons18

real(c_double), private module_mp_morr_two_moment::cons18
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons19

real(c_double), private module_mp_morr_two_moment::cons19
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons2

real(c_double), private module_mp_morr_two_moment::cons2
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons20

real(c_double), private module_mp_morr_two_moment::cons20
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons21

real(c_double), private module_mp_morr_two_moment::cons21
private
242  REAL(C_DOUBLE), PRIVATE :: CONS21,CONS22,CONS23,CONS24,CONS25,CONS26,CONS27,CONS28,CONS29,CONS30

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons22

real(c_double), private module_mp_morr_two_moment::cons22
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons23

real(c_double), private module_mp_morr_two_moment::cons23
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons24

real(c_double), private module_mp_morr_two_moment::cons24
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons25

real(c_double), private module_mp_morr_two_moment::cons25
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons26

real(c_double), private module_mp_morr_two_moment::cons26
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons27

real(c_double), private module_mp_morr_two_moment::cons27
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons28

real(c_double), private module_mp_morr_two_moment::cons28
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons29

real(c_double), private module_mp_morr_two_moment::cons29
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons3

real(c_double), private module_mp_morr_two_moment::cons3
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons30

real(c_double), private module_mp_morr_two_moment::cons30
private

Referenced by morr_two_moment_init().

◆ cons31

real(c_double), private module_mp_morr_two_moment::cons31
private
243  REAL(C_DOUBLE), PRIVATE :: CONS31,CONS32,CONS33,CONS34,CONS35,CONS36,CONS37,CONS38,CONS39,CONS40

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons32

real(c_double), private module_mp_morr_two_moment::cons32
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons33

real(c_double), private module_mp_morr_two_moment::cons33
private

Referenced by morr_two_moment_init().

◆ cons34

real(c_double), private module_mp_morr_two_moment::cons34
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons35

real(c_double), private module_mp_morr_two_moment::cons35
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons36

real(c_double), private module_mp_morr_two_moment::cons36
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons37

real(c_double), private module_mp_morr_two_moment::cons37
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons38

real(c_double), private module_mp_morr_two_moment::cons38
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons39

real(c_double), private module_mp_morr_two_moment::cons39
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons4

real(c_double), private module_mp_morr_two_moment::cons4
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons40

real(c_double), private module_mp_morr_two_moment::cons40
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons41

real(c_double), private module_mp_morr_two_moment::cons41
private
244  REAL(C_DOUBLE), PRIVATE :: CONS41

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons5

real(c_double), private module_mp_morr_two_moment::cons5
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons6

real(c_double), private module_mp_morr_two_moment::cons6
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons7

real(c_double), private module_mp_morr_two_moment::cons7
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons8

real(c_double), private module_mp_morr_two_moment::cons8
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cons9

real(c_double), private module_mp_morr_two_moment::cons9
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cpw

real(c_double), private module_mp_morr_two_moment::cpw
private
207  REAL(C_DOUBLE), PRIVATE :: CPW ! SPECIFIC HEAT OF LIQUID WATER

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ cs

real(c_double), private module_mp_morr_two_moment::cs
private

Referenced by morr_two_moment_init(), and ERF::WriteSubvolume().

◆ dcs

real(c_double), private module_mp_morr_two_moment::dcs
private
193  REAL(C_DOUBLE), PRIVATE :: DCS ! THRESHOLD SIZE FOR CLOUD ICE AUTOCONVERSION

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ dg

real(c_double), private module_mp_morr_two_moment::dg
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ di

real(c_double), private module_mp_morr_two_moment::di
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ ds

real(c_double), private module_mp_morr_two_moment::ds
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ eci

real(c_double), private module_mp_morr_two_moment::eci
private
204  REAL(C_DOUBLE), PRIVATE :: ECI ! COLLECTION EFFICIENCY, ICE-DROPLET COLLISIONS

Referenced by morr_two_moment_init().

◆ ecr

real(c_double), private module_mp_morr_two_moment::ecr
private
192  REAL(C_DOUBLE), PRIVATE :: ECR ! COLLECTION EFFICIENCY BETWEEN DROPLETS/RAIN AND SNOW/RAIN

Referenced by morr_two_moment_init().

◆ eii

real(c_double), private module_mp_morr_two_moment::eii
private
203  REAL(C_DOUBLE), PRIVATE :: EII ! COLLECTION EFFICIENCY, ICE-ICE COLLISIONS

Referenced by morr_two_moment_init().

◆ epsm

real(c_double), private module_mp_morr_two_moment::epsm
private
219  REAL(C_DOUBLE), PRIVATE :: EPSM ! AEROSOL SOLUBLE FRACTION

Referenced by morr_two_moment_init().

◆ f11

real(c_double), private module_mp_morr_two_moment::f11
private
231  REAL(C_DOUBLE), PRIVATE :: F11 ! CORRECTION FACTOR FOR ACTIVATION, MODE 1

Referenced by morr_two_moment_init().

◆ f12

real(c_double), private module_mp_morr_two_moment::f12
private
232  REAL(C_DOUBLE), PRIVATE :: F12 ! CORRECTION FACTOR FOR ACTIVATION, MODE 1

Referenced by morr_two_moment_init().

◆ f1r

real(c_double), private module_mp_morr_two_moment::f1r
private
198  REAL(C_DOUBLE), PRIVATE :: F1R ! VENTILATION PARAMETER FOR RAIN

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ f1s

real(c_double), private module_mp_morr_two_moment::f1s
private
196  REAL(C_DOUBLE), PRIVATE :: F1S ! VENTILATION PARAMETER FOR SNOW

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ f21

real(c_double), private module_mp_morr_two_moment::f21
private
233  REAL(C_DOUBLE), PRIVATE :: F21 ! CORRECTION FACTOR FOR ACTIVATION, MODE 2

Referenced by morr_two_moment_init().

◆ f22

real(c_double), private module_mp_morr_two_moment::f22
private
234  REAL(C_DOUBLE), PRIVATE :: F22 ! CORRECTION FACTOR FOR ACTIVATION, MODE 2

Referenced by morr_two_moment_init().

◆ f2r

real(c_double), private module_mp_morr_two_moment::f2r
private
199  REAL(C_DOUBLE), PRIVATE :: F2R ! VENTILATION PARAMETER FOR RAIN

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ f2s

real(c_double), private module_mp_morr_two_moment::f2s
private
197  REAL(C_DOUBLE), PRIVATE :: F2S ! VENTILATION PARAMETER FOR SNOW

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ iact

integer, private module_mp_morr_two_moment::iact
private
117  INTEGER, PRIVATE :: IACT

Referenced by morr_two_moment_init(), morr_two_moment_micro(), and mp_morr_two_moment().

◆ ibase

integer, private module_mp_morr_two_moment::ibase
private
155  INTEGER, PRIVATE :: IBASE

Referenced by morr_two_moment_init().

◆ igraup

integer, private module_mp_morr_two_moment::igraup
private
169  INTEGER, PRIVATE :: IGRAUP

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ ihail

integer, private module_mp_morr_two_moment::ihail
private
176  INTEGER, PRIVATE :: IHAIL

Referenced by morr_two_moment_init().

◆ iliq

integer, private module_mp_morr_two_moment::iliq
private
133  INTEGER, PRIVATE :: ILIQ

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ inuc

integer, private module_mp_morr_two_moment::inuc
private
139  INTEGER, PRIVATE :: INUC

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ inum

integer, private module_mp_morr_two_moment::inum
private
124  INTEGER, PRIVATE :: INUM

Referenced by morr_two_moment_init().

◆ isub

integer, private module_mp_morr_two_moment::isub
private
163  INTEGER, PRIVATE :: ISUB

Referenced by morr_two_moment_init().

◆ k1

real(c_double), private module_mp_morr_two_moment::k1
private
212  REAL(C_DOUBLE), PRIVATE :: K1 ! 'K' IN NCCN = CS^K

Referenced by morr_two_moment_init(), and TerrainIF::operator()().

◆ lammaxg

real(c_double), private module_mp_morr_two_moment::lammaxg
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ lammaxi

real(c_double), private module_mp_morr_two_moment::lammaxi
private
236  REAL(C_DOUBLE), PRIVATE :: LAMMAXI,LAMMINI,LAMMAXR,LAMMINR,LAMMAXS,LAMMINS,LAMMAXG,LAMMING

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ lammaxr

real(c_double), private module_mp_morr_two_moment::lammaxr
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ lammaxs

real(c_double), private module_mp_morr_two_moment::lammaxs
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ lamming

real(c_double), private module_mp_morr_two_moment::lamming
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ lammini

real(c_double), private module_mp_morr_two_moment::lammini
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ lamminr

real(c_double), private module_mp_morr_two_moment::lamminr
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ lammins

real(c_double), private module_mp_morr_two_moment::lammins
private

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ ma

real(c_double), private module_mp_morr_two_moment::ma
private
222  REAL(C_DOUBLE), PRIVATE :: MA ! MOLECULAR WEIGHT OF 'AIR' (KG/MOL)

Referenced by morr_two_moment_init(), and reduce_to_max_per_height().

◆ map

real(c_double), private module_mp_morr_two_moment::map
private
221  REAL(C_DOUBLE), PRIVATE :: MAP ! MOLECULAR WEIGHT AEROSOL (KG/MOL)

Referenced by morr_two_moment_init().

◆ mg0

real(c_double), private module_mp_morr_two_moment::mg0
private
195  REAL(C_DOUBLE), PRIVATE :: MG0 ! MASS OF EMBRYO GRAUPEL

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ mi0

real(c_double), private module_mp_morr_two_moment::mi0
private
194  REAL(C_DOUBLE), PRIVATE :: MI0 ! INITIAL SIZE OF NUCLEATED CRYSTAL

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ mmult

real(c_double), private module_mp_morr_two_moment::mmult
private
235  REAL(C_DOUBLE), PRIVATE :: MMULT ! MASS OF SPLINTERED ICE PARTICLE

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ mw

real(c_double), private module_mp_morr_two_moment::mw
private
216  REAL(C_DOUBLE), PRIVATE :: MW ! MOLECULAR WEIGHT WATER (KG/MOL)

Referenced by morr_two_moment_init().

◆ nanew1

real(c_double), private module_mp_morr_two_moment::nanew1
private
227  REAL(C_DOUBLE), PRIVATE :: NANEW1 ! TOTAL AEROSOL CONCENTRATION, MODE 1 (M^-3)

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ nanew2

real(c_double), private module_mp_morr_two_moment::nanew2
private
228  REAL(C_DOUBLE), PRIVATE :: NANEW2 ! TOTAL AEROSOL CONCENTRATION, MODE 2 (M^-3)

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ ndcnst

real(c_double), private module_mp_morr_two_moment::ndcnst
private
127  REAL(C_DOUBLE), PRIVATE :: NDCNST

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ osm

real(c_double), private module_mp_morr_two_moment::osm
private
217  REAL(C_DOUBLE), PRIVATE :: OSM ! OSMOTIC COEFFICIENT

Referenced by morr_two_moment_init().

◆ pi

real(c_double), parameter, private module_mp_morr_two_moment::pi = 3.1415926535897932384626434
private
100  REAL(C_DOUBLE), PARAMETER :: PI = 3.1415926535897932384626434

Referenced by ERF::erf_enforce_hse(), gamma(), morr_two_moment_init(), morr_two_moment_micro(), eb_::EBToPVD::reorder_polygon(), and wrf_gamma().

◆ qsmall

real(c_double), private module_mp_morr_two_moment::qsmall
private
201  REAL(C_DOUBLE), PRIVATE :: QSMALL ! SMALLEST ALLOWED HYDROMETEOR MIXING RATIO

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ rhoa

real(c_double), private module_mp_morr_two_moment::rhoa
private
220  REAL(C_DOUBLE), PRIVATE :: RHOA ! AEROSOL BULK DENSITY (KG/M3)

Referenced by morr_two_moment_init().

◆ rhog

real(c_double), private module_mp_morr_two_moment::rhog
private
189  REAL(C_DOUBLE), PRIVATE :: RHOG ! BULK DENSITY OF GRAUPEL

◆ rhoi

real(c_double), private module_mp_morr_two_moment::rhoi
private
187  REAL(C_DOUBLE), PRIVATE :: RHOI ! BULK DENSITY OF CLOUD ICE

Referenced by morr_two_moment_init().

◆ rhosn

real(c_double), private module_mp_morr_two_moment::rhosn
private
188  REAL(C_DOUBLE), PRIVATE :: RHOSN ! BULK DENSITY OF SNOW

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ rhosu

real(c_double), private module_mp_morr_two_moment::rhosu
private
185  REAL(C_DOUBLE), PRIVATE :: RHOSU ! STANDARD AIR DENSITY AT 850 MB

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ rhow

real(c_double), private module_mp_morr_two_moment::rhow
private
186  REAL(C_DOUBLE), PRIVATE :: RHOW ! DENSITY OF LIQUID WATER

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ rin

real(c_double), private module_mp_morr_two_moment::rin
private
205  REAL(C_DOUBLE), PRIVATE :: RIN ! RADIUS OF CONTACT NUCLEI (M)

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ rm1

real(c_double), private module_mp_morr_two_moment::rm1
private
225  REAL(C_DOUBLE), PRIVATE :: RM1 ! GEOMETRIC MEAN RADIUS, MODE 1 (M)

Referenced by morr_two_moment_init().

◆ rm2

real(c_double), private module_mp_morr_two_moment::rm2
private
226  REAL(C_DOUBLE), PRIVATE :: RM2 ! GEOMETRIC MEAN RADIUS, MODE 2 (M)

Referenced by morr_two_moment_init().

◆ rr

real(c_double), private module_mp_morr_two_moment::rr
private
223  REAL(C_DOUBLE), PRIVATE :: RR ! UNIVERSAL GAS CONSTANT

Referenced by ERF::ErrorEst(), init_zlevels(), morr_two_moment_init(), ERF::WriteMultiLevelPlotfileWithTerrain(), and ERF::WritePlotFile().

◆ sig1

real(c_double), private module_mp_morr_two_moment::sig1
private
229  REAL(C_DOUBLE), PRIVATE :: SIG1 ! STANDARD DEVIATION OF AEROSOL S.D., MODE 1

Referenced by morr_two_moment_init().

◆ sig2

real(c_double), private module_mp_morr_two_moment::sig2
private
230  REAL(C_DOUBLE), PRIVATE :: SIG2 ! STANDARD DEVIATION OF AEROSOL S.D., MODE 2

Referenced by morr_two_moment_init().

◆ vi

real(c_double), private module_mp_morr_two_moment::vi
private
218  REAL(C_DOUBLE), PRIVATE :: VI ! NUMBER OF ION DISSOCIATED IN SOLUTION

Referenced by morr_two_moment_init().

◆ xxx

real(c_double), parameter, private module_mp_morr_two_moment::xxx = 0.9189385332046727417803297
private
101  REAL(C_DOUBLE), PARAMETER :: xxx = 0.9189385332046727417803297