ERF
Energy Research and Forecasting: An Atmospheric Modeling Code
Functions/Subroutines | Variables
module_mp_morr_two_moment Module Reference

Functions/Subroutines

subroutine morr_two_moment_init (morr_rimed_ice, morr_noice)
 
subroutine, public set_morrison_ndcnst (ndcnst_in)
 
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
4107 !----------------------------------------------------------------------
4108 !
4109 ! THIS ROUTINE CALCULATES THE GAMMA FUNCTION FOR A REAL(C_DOUBLE) ARGUMENT X.
4110 ! COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN REFERENCE 1.
4111 ! THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE GAMMA
4112 ! FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS. COEFFICIENTS
4113 ! FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED.
4114 ! THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM REFERENCE 2.
4115 ! THE ACCURACY ACHIEVED DEPENDS ON THE ARITHMETIC SYSTEM, THE
4116 ! COMPILER, THE INTRINSIC FUNCTIONS, AND PROPER SELECTION OF THE
4117 ! MACHINE-DEPENDENT CONSTANTS.
4118 !
4119 !
4120 !*******************************************************************
4121 !*******************************************************************
4122 !
4123 ! EXPLANATION OF MACHINE-DEPENDENT CONSTANTS
4124 !
4125 ! BETA - RADIX FOR THE FLOATING-POINT REPRESENTATION
4126 ! MAXEXP - THE SMALLEST POSITIVE POWER OF BETA THAT OVERFLOWS
4127 ! XBIG - THE LARGEST ARGUMENT FOR WHICH GAMMA(X) IS REPRESENTABLE
4128 ! IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION
4129 ! GAMMA(XBIG) = BETA**MAXEXP
4130 ! XINF - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER;
4131 ! APPROXIMATELY BETA**MAXEXP
4132 ! EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
4133 ! 1.0+EPS .GT. 1.0
4134 ! XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
4135 ! 1/XMININ IS MACHINE REPRESENTABLE
4136 !
4137 ! APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE:
4138 !
4139 ! BETA MAXEXP XBIG
4140 !
4141 ! CRAY-1 (S.P.) 2 8191 966.961
4142 ! CYBER 180/855
4143 ! UNDER NOS (S.P.) 2 1070 177.803
4144 ! IEEE (IBM/XT,
4145 ! SUN, ETC.) (S.P.) 2 128 35.040
4146 ! IEEE (IBM/XT,
4147 ! SUN, ETC.) (D.P.) 2 1024 171.624
4148 ! IBM 3033 (D.P.) 16 63 57.574
4149 ! VAX D-FORMAT (D.P.) 2 127 34.844
4150 ! VAX G-FORMAT (D.P.) 2 1023 171.489
4151 !
4152 ! XINF EPS XMININ
4153 !
4154 ! CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-2466
4155 ! CYBER 180/855
4156 ! UNDER NOS (S.P.) 1.26E+322 3.55E-15 3.14E-294
4157 ! IEEE (IBM/XT,
4158 ! SUN, ETC.) (S.P.) 3.40E+38 1.19E-7 1.18E-38
4159 ! IEEE (IBM/XT,
4160 ! SUN, ETC.) (D.P.) 1.79D+308 2.22D-16 2.23D-308
4161 ! IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-76
4162 ! VAX D-FORMAT (D.P.) 1.70D+38 1.39D-17 5.88D-39
4163 ! VAX G-FORMAT (D.P.) 8.98D+307 1.11D-16 1.12D-308
4164 !
4165 !*******************************************************************
4166 !*******************************************************************
4167 !
4168 ! ERROR RETURNS
4169 !
4170 ! THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR
4171 ! WHEN OVERFLOW WOULD OCCUR. THE COMPUTATION IS BELIEVED
4172 ! TO BE FREE OF UNDERFLOW AND OVERFLOW.
4173 !
4174 !
4175 ! INTRINSIC FUNCTIONS REQUIRED ARE:
4176 !
4177 ! INT, DBLE, EXP, LOG, REAL(C_DOUBLE), SIN
4178 !
4179 !
4180 ! REFERENCES: AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL
4181 ! FUNCTIONS W. J. CODY, LECTURE NOTES IN MATHEMATICS,
4182 ! 506, NUMERICAL ANALYSIS DUNDEE, 1975, G. A. WATSON
4183 ! (ED.), SPRINGER VERLAG, BERLIN, 1976.
4184 !
4185 ! COMPUTER APPROXIMATIONS, HART, ET. AL., WILEY AND
4186 ! SONS, NEW YORK, 1968.
4187 !
4188 ! LATEST MODIFICATION: OCTOBER 12, 1989
4189 !
4190 ! AUTHORS: W. J. CODY AND L. STOLTZ
4191 ! APPLIED MATHEMATICS DIVISION
4192 ! ARGONNE NATIONAL LABORATORY
4193 ! ARGONNE, IL 60439
4194 !
4195 !----------------------------------------------------------------------
4196  implicit none
4197  INTEGER I,N
4198  LOGICAL PARITY
4199  REAL(C_DOUBLE) &
4200  conv,eps,fact,half,one,res,sum,twelve, &
4201  two,x,xbig,xden,xinf,xminin,xnum,y,y1,ysq,z,zero
4202  REAL(C_DOUBLE), DIMENSION(7) :: C
4203  REAL(C_DOUBLE), DIMENSION(8) :: P
4204  REAL(C_DOUBLE), DIMENSION(8) :: Q
4205 !----------------------------------------------------------------------
4206 ! MATHEMATICAL CONSTANTS
4207 !----------------------------------------------------------------------
4208  DATA one,half,twelve,two,zero/1.0e0,0.5e0,12.0e0,2.0e0,0.0e0/
4209 
4210 
4211 !----------------------------------------------------------------------
4212 ! MACHINE DEPENDENT PARAMETERS
4213 !----------------------------------------------------------------------
4214  DATA xbig,xminin,eps/35.040e0,1.18e-38,1.19e-7/,xinf/3.4e38/
4215 !----------------------------------------------------------------------
4216 ! NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX
4217 ! APPROXIMATION OVER (1,2).
4218 !----------------------------------------------------------------------
4219  DATA p/-1.71618513886549492533811e+0,2.47656508055759199108314e+1, &
4220  -3.79804256470945635097577e+2,6.29331155312818442661052e+2, &
4221  8.66966202790413211295064e+2,-3.14512729688483675254357e+4, &
4222  -3.61444134186911729807069e+4,6.64561438202405440627855e+4/
4223  DATA q/-3.08402300119738975254353e+1,3.15350626979604161529144e+2, &
4224  -1.01515636749021914166146e+3,-3.10777167157231109440444e+3, &
4225  2.25381184209801510330112e+4,4.75584627752788110767815e+3, &
4226  -1.34659959864969306392456e+5,-1.15132259675553483497211e+5/
4227 !----------------------------------------------------------------------
4228 ! COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF).
4229 !----------------------------------------------------------------------
4230  DATA c/-1.910444077728e-03,8.4171387781295e-04, &
4231  -5.952379913043012e-04,7.93650793500350248e-04, &
4232  -2.777777777777681622553e-03,8.333333333333333331554247e-02, &
4233  5.7083835261e-03/
4234 !----------------------------------------------------------------------
4235 ! STATEMENT FUNCTIONS FOR CONVERSION BETWEEN INTEGER AND FLOAT
4236 !----------------------------------------------------------------------
4237  conv(i) = real(i)
4238  parity=.false.
4239  fact=one
4240  n=0
4241  y=x
4242  IF(y.LE.zero)THEN
4243 !----------------------------------------------------------------------
4244 ! ARGUMENT IS NEGATIVE
4245 !----------------------------------------------------------------------
4246  y=-x
4247  y1=aint(y)
4248  res=y-y1
4249  IF(res.NE.zero)THEN
4250  IF(y1.NE.aint(y1*half)*two)parity=.true.
4251  fact=-pi/sin(pi*res)
4252  y=y+one
4253  ELSE
4254  res=xinf
4255  GOTO 900
4256  ENDIF
4257  ENDIF
4258 !----------------------------------------------------------------------
4259 ! ARGUMENT IS POSITIVE
4260 !----------------------------------------------------------------------
4261  IF(y.LT.eps)THEN
4262 !----------------------------------------------------------------------
4263 ! ARGUMENT .LT. EPS
4264 !----------------------------------------------------------------------
4265  IF(y.GE.xminin)THEN
4266  res=one/y
4267  ELSE
4268  res=xinf
4269  GOTO 900
4270  ENDIF
4271  ELSEIF(y.LT.twelve)THEN
4272  y1=y
4273  IF(y.LT.one)THEN
4274 !----------------------------------------------------------------------
4275 ! 0.0 .LT. ARGUMENT .LT. 1.0
4276 !----------------------------------------------------------------------
4277  z=y
4278  y=y+one
4279  ELSE
4280 !----------------------------------------------------------------------
4281 ! 1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY
4282 !----------------------------------------------------------------------
4283  n=int(y)-1
4284  y=y-conv(n)
4285  z=y-one
4286  ENDIF
4287 !----------------------------------------------------------------------
4288 ! EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0
4289 !----------------------------------------------------------------------
4290  xnum=zero
4291  xden=one
4292  DO i=1,8
4293  xnum=(xnum+p(i))*z
4294  xden=xden*z+q(i)
4295  END DO
4296  res=xnum/xden+one
4297  IF(y1.LT.y)THEN
4298 !----------------------------------------------------------------------
4299 ! ADJUST RESULT FOR CASE 0.0 .LT. ARGUMENT .LT. 1.0
4300 !----------------------------------------------------------------------
4301  res=res/y1
4302  ELSEIF(y1.GT.y)THEN
4303 !----------------------------------------------------------------------
4304 ! ADJUST RESULT FOR CASE 2.0 .LT. ARGUMENT .LT. 12.0
4305 !----------------------------------------------------------------------
4306  DO i=1,n
4307  res=res*y
4308  y=y+one
4309  END DO
4310  ENDIF
4311  ELSE
4312 !----------------------------------------------------------------------
4313 ! EVALUATE FOR ARGUMENT .GE. 12.0,
4314 !----------------------------------------------------------------------
4315  IF(y.LE.xbig)THEN
4316  ysq=y*y
4317  sum=c(7)
4318  DO i=1,6
4319  sum=sum/ysq+c(i)
4320  END DO
4321  sum=sum/y-y+xxx
4322  sum=sum+(y-half)*log(y)
4323  res=exp(sum)
4324  ELSE
4325  res=xinf
4326  GOTO 900
4327  ENDIF
4328  ENDIF
4329 !----------------------------------------------------------------------
4330 ! FINAL ADJUSTMENTS AND RETURN
4331 !----------------------------------------------------------------------
4332  IF(parity)res=-res
4333  IF(fact.NE.one)res=fact/res
4334  900 gamma=res
4335  RETURN
4336 ! ---------- 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 
)
252 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
253 ! THIS SUBROUTINE INITIALIZES ALL PHYSICAL CONSTANTS AMND PARAMETERS
254 ! NEEDED BY THE MICROPHYSICS SCHEME.
255 ! NEEDS TO BE CALLED AT FIRST TIME STEP, PRIOR TO CALL TO MAIN MICROPHYSICS INTERFACE
256 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
257 
258  IMPLICIT NONE
259 
260  INTEGER, INTENT(IN):: morr_rimed_ice ! RAS
261  INTEGER, INTENT(IN):: morr_noice
262 
263  integer n,i
264 
265  print *,'IN MORR_TWO_MOMENT_INIT ',"with noice = ",morr_noice
266 
267 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
268 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
269 
270 ! THE FOLLOWING PARAMETERS ARE USER-DEFINED SWITCHES AND NEED TO BE
271 ! SET PRIOR TO CODE COMPILATION
272 
273 ! INUM IS AUTOMATICALLY SET TO 0 FOR WRF-CHEM BELOW,
274 ! ALLOWING PREDICTION OF DROPLET CONCENTRATION
275 ! THUS, THIS PARAMETER SHOULD NOT BE CHANGED HERE
276 ! AND SHOULD BE LEFT TO 1
277 
278  inum = 1
279 
280 ! SET CONSTANT DROPLET CONCENTRATION (UNITS OF CM-3)
281 ! IF NO COUPLING WITH WRF-CHEM
282 
283  ndcnst = 250.
284 
285 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
286 ! NOTE, THE FOLLOWING OPTIONS RELATED TO DROPLET ACTIVATION
287 ! (IACT, IBASE, ISUB) ARE NOT AVAILABLE IN CURRENT VERSION
288 ! FOR WRF-CHEM, DROPLET ACTIVATION IS PERFORMED
289 ! IN 'MIX_ACTIVATE', NOT IN MICROPHYSICS SCHEME
290 
291 
292 ! IACT = 1, USE POWER-LAW CCN SPECTRA, NCCN = CS^K
293 ! IACT = 2, USE LOGNORMAL AEROSOL SIZE DIST TO DERIVE CCN SPECTRA
294 
295  iact = 2
296 
297 ! IBASE = 1, NEGLECT DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO
298 ! UNRESOLVED ENTRAINMENT AND MIXING, ACTIVATE
299 ! AT CLOUD BASE OR IN REGION WITH LITTLE CLOUD WATER USING
300 ! NON-EQULIBRIUM SUPERSATURATION ASSUMING NO INITIAL CLOUD WATER,
301 ! IN CLOUD INTERIOR ACTIVATE USING EQUILIBRIUM SUPERSATURATION
302 ! IBASE = 2, ASSUME DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO
303 ! UNRESOLVED ENTRAINMENT AND MIXING DOMINATES,
304 ! ACTIVATE DROPLETS EVERYWHERE IN THE CLOUD USING NON-EQUILIBRIUM
305 ! SUPERSATURATION ASSUMING NO INITIAL CLOUD WATER, BASED ON THE
306 ! LOCAL SUB-GRID AND/OR GRID-SCALE VERTICAL VELOCITY
307 ! AT THE GRID POINT
308 
309 ! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0)
310 
311  ibase = 2
312 
313 ! INCLUDE SUB-GRID VERTICAL VELOCITY (standard deviation of w) IN DROPLET ACTIVATION
314 ! ISUB = 0, INCLUDE SUB-GRID W (RECOMMENDED FOR LOWER RESOLUTION)
315 ! currently, sub-grid w is constant of 0.5 m/s (not coupled with PBL/turbulence scheme)
316 ! ISUB = 1, EXCLUDE SUB-GRID W, ONLY USE GRID-SCALE W
317 
318 ! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0)
319 
320  isub = 0
321 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
322  if(morr_noice .eq. 1) then
323 
324 ! SWITCH FOR LIQUID-ONLY RUN
325 ! ILIQ = 0, INCLUDE ICE
326 ! ILIQ = 1, LIQUID ONLY, NO ICE
327 
328  iliq = 1
329 
330 ! SWITCH FOR ICE NUCLEATION
331 ! INUC = 0, USE FORMULA FROM RASMUSSEN ET AL. 2002 (MID-LATITUDE)
332 ! = 1, USE MPACE OBSERVATIONS (ARCTIC ONLY)
333 
334  inuc = 0
335 
336 ! SWITCH FOR GRAUPEL/HAIL NO GRAUPEL/HAIL
337 ! IGRAUP = 0, INCLUDE GRAUPEL/HAIL
338 ! IGRAUP = 1, NO GRAUPEL/HAIL
339 
340  igraup = 1
341 
342 ! HM ADDED 11/7/07
343 ! SWITCH FOR HAIL/GRAUPEL
344 ! IHAIL = 0, DENSE PRECIPITATING ICE IS GRAUPEL
345 ! IHAIL = 1, DENSE PRECIPITATING ICE IS HAIL
346 ! NOTE ---> RECOMMEND IHAIL = 1 FOR CONTINENTAL DEEP CONVECTION
347 
348  !IHAIL = 0 !changed to namelist option (morr_rimed_ice) by RAS
349  ! Check if namelist option is feasible, otherwise default to graupel - RAS
350  IF (morr_rimed_ice .eq. 1) THEN
351  ihail = 1
352  ELSE
353  ihail = 0
354  ENDIF
355 else
356 
357 ! SWITCH FOR LIQUID-ONLY RUN
358 ! ILIQ = 0, INCLUDE ICE
359 ! ILIQ = 1, LIQUID ONLY, NO ICE
360 
361  iliq = 0
362 
363 ! SWITCH FOR ICE NUCLEATION
364 ! INUC = 0, USE FORMULA FROM RASMUSSEN ET AL. 2002 (MID-LATITUDE)
365 ! = 1, USE MPACE OBSERVATIONS (ARCTIC ONLY)
366 
367  inuc = 0
368 
369 ! SWITCH FOR GRAUPEL/HAIL NO GRAUPEL/HAIL
370 ! IGRAUP = 0, INCLUDE GRAUPEL/HAIL
371 ! IGRAUP = 1, NO GRAUPEL/HAIL
372 
373  igraup = 0
374 
375 ! HM ADDED 11/7/07
376 ! SWITCH FOR HAIL/GRAUPEL
377 ! IHAIL = 0, DENSE PRECIPITATING ICE IS GRAUPEL
378 ! IHAIL = 1, DENSE PRECIPITATING ICE IS HAIL
379 ! NOTE ---> RECOMMEND IHAIL = 1 FOR CONTINENTAL DEEP CONVECTION
380 
381  !IHAIL = 0 !changed to namelist option (morr_rimed_ice) by RAS
382  ! Check if namelist option is feasible, otherwise default to graupel - RAS
383  IF (morr_rimed_ice .eq. 1) THEN
384  ihail = 1
385  ELSE
386  ihail = 0
387  ENDIF
388 endif
389 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
390 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
391 ! SET PHYSICAL CONSTANTS
392 
393 ! FALLSPEED PARAMETERS (V=AD^B)
394  ai = 700.
395  ac = 3.e7
396  as = 11.72
397  ar = 841.99667
398  bi = 1.
399  bc = 2.
400  bs = 0.41
401  br = 0.8
402  IF (ihail.EQ.0) THEN
403  ag = 19.3
404  bg = 0.37
405  ELSE ! (MATSUN AND HUGGINS 1980)
406  ag = 114.5
407  bg = 0.5
408  END IF
409 
410 ! CONSTANTS AND PARAMETERS
411 ! R = 287.15
412 ! RV = 461.5
413 ! CP = 1005.
414  rhosu = 85000./(287.15*273.15)
415  rhow = 997.
416  rhoi = 500.
417  rhosn = 100.
418  IF (ihail.EQ.0) THEN
419  rhog = 400.
420  ELSE
421  rhog = 900.
422  END IF
423  aimm = 0.66
424  bimm = 100.
425  ecr = 1.
426  dcs = 125.e-6
427  mi0 = 4./3.*pi*rhoi*(10.e-6)**3
428  mg0 = 1.6e-10
429  f1s = 0.86
430  f2s = 0.28
431  f1r = 0.78
432 ! F2R = 0.32
433 ! fix 053011
434  f2r = 0.308
435 ! G = 9.806
436 
437  qsmall = 1.d-14
438  print *,'SETTING SMALL TO ',qsmall
439 
440  eii = 0.1
441  eci = 0.7
442 ! HM, ADD FOR V3.2
443 ! hm, 7/23/13
444 ! CPW = 4218.
445  cpw = 4187.
446 
447 ! SIZE DISTRIBUTION PARAMETERS
448 
449  ci = rhoi*pi/6.
450  di = 3.
451  cs = rhosn*pi/6.
452  ds = 3.
453  cg = rhog*pi/6.
454  dg = 3.
455 
456 ! RADIUS OF CONTACT NUCLEI
457  rin = 0.1e-6
458 
459  mmult = 4./3.*pi*rhoi*(5.e-6)**3
460 
461 ! SIZE LIMITS FOR LAMBDA
462 
463  lammaxi = 1./1.e-6
464  lammini = 1./(2.*dcs+100.e-6)
465  lammaxr = 1./20.e-6
466 ! LAMMINR = 1./500.E-6
467  lamminr = 1./2800.e-6
468 
469  lammaxs = 1./10.e-6
470  lammins = 1./2000.e-6
471  lammaxg = 1./20.e-6
472  lamming = 1./2000.e-6
473 
474 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
475 ! note: these parameters only used by the non-wrf-chem version of the
476 ! scheme with predicted droplet number
477 
478 ! CCN SPECTRA FOR IACT = 1
479 
480 ! MARITIME
481 ! MODIFIED FROM RASMUSSEN ET AL. 2002
482 ! NCCN = C*S^K, NCCN IS IN CM-3, S IS SUPERSATURATION RATIO IN %
483 
484  k1 = 0.4
485  c1 = 120.
486 
487 ! CONTINENTAL
488 
489 ! K1 = 0.5
490 ! C1 = 1000.
491 
492 ! AEROSOL ACTIVATION PARAMETERS FOR IACT = 2
493 ! PARAMETERS CURRENTLY SET FOR AMMONIUM SULFATE
494 
495  mw = 0.018
496  osm = 1.
497  vi = 3.
498  epsm = 0.7
499  rhoa = 1777.
500  map = 0.132
501  ma = 0.0284
502 ! hm fix 6/23/16
503 ! RR = 8.3187
504  rr = 8.3145
505  bact = vi*osm*epsm*mw*rhoa/(map*rhow)
506 
507 ! AEROSOL SIZE DISTRIBUTION PARAMETERS CURRENTLY SET FOR MPACE
508 ! (see morrison et al. 2007, JGR)
509 ! MODE 1
510 
511  rm1 = 0.052e-6
512  sig1 = 2.04
513  nanew1 = 72.2e6
514  f11 = 0.5*exp(2.5*(log(sig1))**2)
515  f21 = 1.+0.25*log(sig1)
516 
517 ! MODE 2
518 
519  rm2 = 1.3e-6
520  sig2 = 2.5
521  nanew2 = 1.8e6
522  f12 = 0.5*exp(2.5*(log(sig2))**2)
523  f22 = 1.+0.25*log(sig2)
524 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
525 
526 ! CONSTANTS FOR EFFICIENCY
527 
528  cons1=gamma(1.+ds)*cs
529  cons2=gamma(1.+dg)*cg
530  cons3=gamma(4.+bs)/6.
531  cons4=gamma(4.+br)/6.
532  cons5=gamma(1.+bs)
533  cons6=gamma(1.+br)
534  cons7=gamma(4.+bg)/6.
535  cons8=gamma(1.+bg)
536  cons9=gamma(5./2.+br/2.)
537  cons10=gamma(5./2.+bs/2.)
538  cons11=gamma(5./2.+bg/2.)
539  cons12=gamma(1.+di)*ci
540  cons13=gamma(bs+3.)*pi/4.*eci
541  cons14=gamma(bg+3.)*pi/4.*eci
542  cons15=-1108.*eii*pi**((1.-bs)/3.)*rhosn**((-2.-bs)/3.)/(4.*720.)
543  cons16=gamma(bi+3.)*pi/4.*eci
544  cons17=4.*2.*3.*rhosu*pi*eci*eci*gamma(2.*bs+2.)/(8.*(rhog-rhosn))
545  cons18=rhosn*rhosn
546  cons19=rhow*rhow
547  cons20=20.*pi*pi*rhow*bimm
548  cons21=4./(dcs*rhoi)
549  cons22=pi*rhoi*dcs**3/6.
550  cons23=pi/4.*eii*gamma(bs+3.)
551  cons24=pi/4.*ecr*gamma(br+3.)
552  cons25=pi*pi/24.*rhow*ecr*gamma(br+6.)
553  cons26=pi/6.*rhow
554  cons27=gamma(1.+bi)
555  cons28=gamma(4.+bi)/6.
556  cons29=4./3.*pi*rhow*(25.e-6)**3
557  cons30=4./3.*pi*rhow
558  cons31=pi*pi*ecr*rhosn
559  cons32=pi/2.*ecr
560  cons33=pi*pi*ecr*rhog
561  cons34=5./2.+br/2.
562  cons35=5./2.+bs/2.
563  cons36=5./2.+bg/2.
564  cons37=4.*pi*1.38e-23/(6.*pi*rin)
565  cons38=pi*pi/3.*rhow
566  cons39=pi*pi/36.*rhow*bimm
567  cons40=pi/6.*bimm
568  cons41=pi*pi*ecr*rhow
569 

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

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

Referenced by calc_saturation_vapor_pressure(), and morr_two_moment_micro().

Here is the caller graph for this function:

◆ set_morrison_ndcnst()

subroutine, public module_mp_morr_two_moment::set_morrison_ndcnst ( real(c_double), intent(in)  ndcnst_in)
574 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
575 ! THIS SUBROUTINE SETS THE CONSTANT DROPLET CONCENTRATION (NDCNST)
576 ! ALLOWS RUNTIME CONFIGURATION FROM INPUT FILE
577 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
578  IMPLICIT NONE
579  REAL(C_DOUBLE), INTENT(IN) :: ndcnst_in
580 
581  ndcnst = ndcnst_in
582 

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
181  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
191  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
225  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
182  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
192  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
212  REAL(C_DOUBLE), PRIVATE :: C1 ! 'C' IN NCCN = CS^K (CM-3)

Referenced by SatMethods::Bolton_svp_water(), ComputeStrain_S(), ComputeStrain_T(), DiffusionSrcForState_S(), DiffusionSrcForState_T(), 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
203  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
241  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
242  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
243  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
244  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
245  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
208  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
194  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
205  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
193  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
204  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
220  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
232  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
233  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
199  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
197  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
234  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
235  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
200  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
198  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
118  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
156  INTEGER, PRIVATE :: IBASE

Referenced by morr_two_moment_init().

◆ igraup

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

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ ihail

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

Referenced by morr_two_moment_init().

◆ iliq

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

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ inuc

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

Referenced by morr_two_moment_init(), and morr_two_moment_micro().

◆ inum

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

Referenced by morr_two_moment_init().

◆ isub

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

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

◆ k1

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

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

◆ 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
237  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
223  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
222  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
196  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
195  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
236  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
217  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
228  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
229  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
128  REAL(C_DOUBLE), PRIVATE :: NDCNST

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

◆ osm

real(c_double), private module_mp_morr_two_moment::osm
private
218  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 compute_max_reflectivity_dbz(), 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
202  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
221  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
190  REAL(C_DOUBLE), PRIVATE :: RHOG ! BULK DENSITY OF GRAUPEL

◆ rhoi

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

Referenced by make_sources(), and morr_two_moment_init().

◆ rhosn

real(c_double), private module_mp_morr_two_moment::rhosn
private
189  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
186  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
187  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
206  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
226  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
227  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
224  REAL(C_DOUBLE), PRIVATE :: RR ! UNIVERSAL GAS CONSTANT

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

◆ sig1

real(c_double), private module_mp_morr_two_moment::sig1
private
230  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
231  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
219  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