| blob | bcc1b3cd1662c5a3db4a423018f44e1381b45080 |
1 !__________________________________________________________________________________________
2 ! This module contains the Predicted Particle Property (P3) bulk microphysics scheme. !
3 ! !
4 ! This code was originally written by H. Morrison, MMM Division, NCAR (Dec 2012). !
5 ! Modifications were made by J. Milbrandt, RPN, Environment Canada (July 2014). !
6 ! Subsequent major and minor upgrades have been ongoing. !
7 ! !
8 ! For model-specific aspects/versions, see comments in the interface subroutine(s) in !
9 ! this module (mp_p3_wrapper_wrf, mp_p3_wrapper_gem). !
10 ! !
11 ! For details see: !
12 ! Morrison and Milbrandt (2015) [J. Atmos. Sci., 72, 287-311] - original scheme desc. !
13 ! Milbrandt and Morrison (2016) [J. Atmos. Sci., 73, 975-995] - multi-ice-category !
14 ! Jouan et al. (2020) [W. Forecasting, 35, 2541-2565] - cloud fraction !
15 ! Milbrandt et al. (2021) [J. Atmos. Sci., 78, 439-458] - triple-moment ice !
16 ! !
17 ! For questions or bug reports, please contact: !
18 ! Hugh Morrison (morrison@ucar.edu), or !
19 ! Jason Milbrandt (jason.milbrandt@ec.gc.ca), or !
20 ! Melissa Cholette (melissa.cholette@ec.gc.ca) !
21 !__________________________________________________________________________________________!
22 ! !
23 ! Version: 4.5.2 !
24 ! Last updated: 2023-FEB !
25 !__________________________________________________________________________________________!
27 MODULE microphy_p3
29 #ifdef ECCCGEM
30 use tdpack, only: foew, foewa
31 #endif
33 implicit none
35 private
36 public :: p3_main, polysvp1, p3_init
37 #ifdef ECCCGEM
38 public :: mp_p3_wrapper_gem, p3_phybusinit, p3_lwc, p3_iwc
39 #else
40 public :: mp_p3_wrapper_wrf, mp_p3_wrapper_wrf_2cat
41 #endif
43 integer, parameter, public :: STATUS_ERROR = -1
44 integer, parameter, public :: STATUS_OK = 0
45 integer, save :: global_status = STATUS_OK
47 ! ice microphysics lookup table array dimensions
48 integer, parameter :: isize = 50
49 integer, parameter :: iisize = 25
50 integer, parameter :: zsize = 11 ! size of mu_i array in lookup_table (for 3-moment ice)
51 integer, parameter :: densize = 5
52 integer, parameter :: rimsize = 4
53 integer, parameter :: rcollsize = 30
54 integer, parameter :: tabsize = 14 ! number of quantities used from lookup table
55 integer, parameter :: tabsize_3mom = 15 ! number of quantities used from 3-mom lookup table
56 integer, parameter :: colltabsize = 2 ! number of ice-rain collection quantities used from lookup table
57 integer, parameter :: collitabsize = 2 ! number of ice-ice collection quantities used from lookup table
59 real, parameter :: real_rcollsize = real(rcollsize)
61 ! NOTE: TO DO, MAKE LOOKUP TABLE ARRAYS ALLOCATABLE SO BOTH 2-MOMENT AND 3-MOMENT NOT ALLOCATED
62 real, dimension(densize,rimsize,isize,tabsize) :: itab !ice lookup table values
63 real, dimension(zsize,densize,rimsize,isize,tabsize_3mom) :: itab_3mom !ice lookup table values
65 !ice lookup table values for ice-rain collision/collection
66 real, dimension(densize,rimsize,isize,rcollsize,colltabsize) :: itabcoll
67 real, dimension(zsize,densize,rimsize,isize,rcollsize,colltabsize) :: itabcoll_3mom
69 ! NOTE: TO DO, MAKE LOOKUP TABLE ARRAYS ALLOCATABLE SO MULTICAT NOT ALLOCATED WHEN NCAT = 1
70 ! separated into itabcolli1 and itabcolli2, due to max of 7 dimensional arrays on some FORTRAN compilers
71 real, dimension(iisize,rimsize,densize,iisize,rimsize,densize) :: itabcolli1
72 real, dimension(iisize,rimsize,densize,iisize,rimsize,densize) :: itabcolli2
74 ! integer switch for warm rain autoconversion/accretion schemes
75 integer :: iparam
77 ! number of diagnostic ice-phase hydrometeor types
78 integer, public, parameter :: n_qiType = 6
80 ! droplet spectral shape parameter for mass spectra, used for Seifert and Beheng (2001)
81 ! warm rain autoconversion/accretion option only (iparam = 1)
82 real, dimension(16) :: dnu
84 ! lookup table values for rain shape parameter mu_r
85 real, dimension(150) :: mu_r_table
87 ! lookup table values for rain number- and mass-weighted fallspeeds and ventilation parameters
88 real, dimension(300,10) :: vn_table,vm_table,revap_table
90 real, parameter :: mu_i_max = 20.
92 ! physical and mathematical constants
93 real :: rhosur,rhosui,ar,br,f1r,f2r,ecr,rhow,kr,kc,bimm,aimm,rin,mi0,nccnst, &
94 eci,eri,bcn,cpw,e0,cons1,cons2,cons3,cons4,cons5,cons6,cons7,cons8, &
95 inv_rhow,qsmall,nsmall,bsmall,zsmall,cp,g,rd,rv,ep_2,inv_cp,mw,osm, &
96 vi,epsm,rhoa,map,ma,rr,bact,inv_rm1,inv_rm2,sig1,nanew1,f11,f21,sig2, &
97 nanew2,f12,f22,pi,thrd,sxth,piov3,piov6,rho_rimeMin, &
98 rho_rimeMax,inv_rho_rimeMax,max_total_Ni,dbrk,nmltratio,minVIS, &
99 maxVIS,mu_i_initial,mu_r_constant,inv_Drmax
101 integer :: n_iceCat = -1 !used for GEM interface
103 ! for timing tests
104 real :: t_p3main_start,t_p3main_end, t_sedi_start,t_sedi_end
105 real :: t_p3main_accum = 0.
106 real :: t_sedi_accum = 0.
108 contains
110 !==================================================================================================!
112 subroutine p3_init(lookup_file_dir,nCat,trplMomI,model,stat,abort_on_err)
114 !------------------------------------------------------------------------------------------!
115 ! This subroutine initializes all physical constants and parameters needed by the P3 !
116 ! scheme, including reading in two lookup table files and creating a third. !
117 ! 'P3_INIT' be called at the first model time step, prior to first call to 'P3_MAIN'. !
118 !------------------------------------------------------------------------------------------!
120 #ifdef ECCCGEM
121 use iso_c_binding
122 use rpn_comm_itf_mod
123 #endif
125 implicit none
127 ! Passed arguments:
128 character(len=*), intent(in) :: lookup_file_dir ! directory of the lookup tables (model library)
129 integer, intent(in) :: nCat ! number of free ice categories
130 logical, intent(in) :: trplMomI ! .T.=3-moment / .F.=2-moment (ice)
131 integer, intent(out), optional :: stat ! return status of subprogram
132 logical, intent(in), optional :: abort_on_err ! abort when an error is encountered [.false.]
133 character(len=*), intent(in), optional :: model ! driving model
135 ! Local variables and parameters:
136 logical, save :: is_init = .false.
137 character(len=1024), parameter :: version_p3 = '4.5.2'
138 character(len=1024), parameter :: version_intended_table_1_2mom = '5.4_2momI'
139 character(len=1024), parameter :: version_intended_table_1_3mom = '5.4_3momI'
140 character(len=1024), parameter :: version_intended_table_2 = '5.3'
142 character(len=1024) :: version_header_table_1_2mom
143 character(len=1024) :: version_header_table_1_3mom
144 character(len=1024) :: version_header_table_2
145 character(len=1024) :: lookup_file_1 !lookup table, main
146 character(len=1024) :: lookup_file_2 !lookup table for ice-ice interactions (for nCat>1 only)
147 character(len=1024) :: dumstr,read_path
148 integer :: i,j,ii,jj,kk,jjj,jjj2,jjjj,jjjj2,end_status,zz,procnum,istat,ierr
149 real :: lamr,mu_r,dum,dm,dum1,dum2,dum3,dum4,dum5,dd,amg,vt,dia
150 double precision :: dp_dum1, dp_dum2
151 logical :: err_abort
153 !------------------------------------------------------------------------------------------!
155 read_path = lookup_file_dir ! path for lookup tables from official model library
156 !read_path = '/MY/LOOKUP_TABLE/PATH' ! path for lookup tables from specified location
158 if (trplMomI) then
159 lookup_file_1 = trim(read_path)//'/'//'p3_lookupTable_1.dat-v'//trim(version_intended_table_1_3mom)
160 else
161 lookup_file_1 = trim(read_path)//'/'//'p3_lookupTable_1.dat-v'//trim(version_intended_table_1_2mom)
162 endif
163 lookup_file_2 = trim(read_path)//'/'//'p3_lookupTable_2.dat-v'//trim(version_intended_table_2)
165 !------------------------------------------------------------------------------------------!
167 end_status = STATUS_ERROR
168 err_abort = .false.
169 if (present(abort_on_err)) err_abort = abort_on_err
170 if (is_init) then
171 if (present(stat)) stat = STATUS_OK
172 return
173 endif
175 n_iceCat = nCat !used for GEM interface
177 ! mathematical/optimization constants
178 pi = 3.14159265
179 !pi = acos(-1.)
180 thrd = 1./3.
181 sxth = 1./6.
182 piov3 = pi*thrd
183 piov6 = pi*sxth
185 ! maximum total ice concentration (sum of all categories)
186 max_total_Ni = 2000.e+3 !(m)
188 ! switch for warm-rain parameterization
189 ! = 1 Seifert and Beheng 2001
190 ! = 2 Beheng 1994
191 ! = 3 Khairoutdinov and Kogan 2000
192 ! = 4 Kogan 2013
193 iparam = 3
195 ! droplet concentration (m-3)
196 nccnst = 200.e+6
198 ! parameters for Seifert and Beheng (2001) autoconversion/accretion
199 kc = 9.44e+9
200 kr = 5.78e+3
202 ! physical constants
203 cp = 1005.
204 inv_cp = 1./cp
205 g = 9.816
206 rd = 287.15
207 rv = 461.51
208 ep_2 = 0.622
209 rhosur = 100000./(rd*273.15)
210 rhosui = 60000./(rd*253.15)
211 ar = 841.99667
212 br = 0.8
213 f1r = 0.78
214 f2r = 0.32
215 ecr = 1.
216 rhow = 1000.
217 cpw = 4218.
218 inv_rhow = 1./rhow !inverse of (max.) density of liquid water
219 mu_r_constant = 0. !fixed shape parameter for mu_r
221 ! inv_Drmax = 1./0.0008 ! inverse of maximum allowed rain number-weighted mean diameter (old value)
222 inv_Drmax = 1./0.002 ! inverse of maximum allowed rain number-weighted mean diameter in m
224 ! limits for rime density [kg m-3]
225 rho_rimeMin = 50.
226 rho_rimeMax = 900.
227 inv_rho_rimeMax = 1./rho_rimeMax
229 ! minium allowable prognostic variables
230 qsmall = 1.e-14
231 nsmall = 1.e-16
232 bsmall = qsmall*inv_rho_rimeMax
233 zsmall = 1.e-35
235 ! Bigg (1953)
236 !bimm = 100.
237 !aimm = 0.66
238 ! Barklie and Gokhale (1959)
239 bimm = 2.
240 aimm = 0.65
241 rin = 0.1e-6
242 mi0 = 4.*piov3*900.*1.e-18
244 eci = 0.5
245 eri = 1.
246 bcn = 2.
248 ! mean size for soft lambda_r limiter [microns]
249 dbrk = 600.e-6
250 ! ratio of rain number produced to ice number loss from melting
251 nmltratio = 1.
253 ! mu of initial ice formation by deposition nucleation (or if no ice is present for process group 1)
254 mu_i_initial = 10.
256 ! saturation pressure at T = 0 C
257 e0 = polysvp1(273.15,0)
259 cons1 = piov6*rhow
260 cons2 = 4.*piov3*rhow
261 cons3 = 1./(cons2*(25.e-6)**3)
262 cons4 = 1./(dbrk**3*pi*rhow)
263 cons5 = piov6*bimm
264 cons6 = piov6**2*rhow*bimm
265 cons7 = 4.*piov3*rhow*(1.e-6)**3
266 cons8 = 1./(cons2*(40.e-6)**3)
268 ! aerosol/droplet activation parameters
269 mw = 0.018
270 osm = 1.
271 vi = 3.
272 epsm = 0.9
273 rhoa = 1777.
274 map = 0.132
275 ma = 0.0284
276 rr = 8.3187
277 bact = vi*osm*epsm*mw*rhoa/(map*rhow)
278 ! inv_bact = (map*rhow)/(vi*osm*epsm*mw*rhoa) *** to replace /bact **
280 ! mode 1
281 inv_rm1 = 2.e+7 ! inverse aerosol mean size (m-1)
282 sig1 = 2.0 ! aerosol standard deviation
283 nanew1 = 300.e6 ! aerosol number mixing ratio (kg-1)
284 f11 = 0.5*exp(2.5*(log(sig1))**2)
285 f21 = 1. + 0.25*log(sig1)
287 ! note: currently only set for a single mode, droplet activation code needs to
288 ! be modified to include the second mode
289 ! mode 2
290 inv_rm2 = 7.6923076e+5 ! inverse aerosol mean size (m-1)
291 sig2 = 2.5 ! aerosol standard deviation
292 nanew2 = 0. ! aerosol number mixing ratio (kg-1)
293 f12 = 0.5*exp(2.5*(log(sig2))**2)
294 f22 = 1. + 0.25*log(sig2)
296 minVIS = 1. ! minimum visibility (m)
297 maxVIS = 99.e+3 ! maximum visibility (m)
299 ! parameters for droplet mass spectral shape, used by Seifert and Beheng (2001)
300 ! warm rain scheme only (iparam = 1)
301 dnu(1) = 0.
302 dnu(2) = -0.557
303 dnu(3) = -0.430
304 dnu(4) = -0.307
305 dnu(5) = -0.186
306 dnu(6) = -0.067
307 dnu(7) = 0.050
308 dnu(8) = 0.167
309 dnu(9) = 0.282
310 dnu(10) = 0.397
311 dnu(11) = 0.512
312 dnu(12) = 0.626
313 dnu(13) = 0.739
314 dnu(14) = 0.853
315 dnu(15) = 0.966
316 dnu(16) = 0.966
318 !------------------------------------------------------------------------------------------!
319 ! read in ice microphysics table
321 procnum = 0
323 #ifdef ECCCGEM
324 call rpn_comm_rank(RPN_COMM_GRID,procnum,istat)
325 #endif
327 if (trplMomI) then
328 itabcoll_3mom = 0.
329 else
330 itabcoll = 0.
331 endif
332 if (nCat>1) then
333 itabcolli1 = 0.
334 itabcolli2 = 0.
335 endif
337 IF_PROC0: if (procnum == 0) then
339 print*
340 print*, ' P3 microphysics: v',trim(version_p3)
341 print*, ' P3_INIT (reading/creating lookup tables)'
343 TRIPLE_MOMENT_ICE: if (.not. trplMomI) then
345 print*, ' Reading table 1 [',trim(version_intended_table_1_2mom),'] ...'
347 open(unit=10, file=lookup_file_1, status='old', action='read')
349 !-- check that table version is correct:
350 ! note: to override and use a different lookup table, simply comment out the 'return' below
351 read(10,*) dumstr,version_header_table_1_2mom
352 if (trim(version_intended_table_1_2mom) /= trim(version_header_table_1_2mom)) then
353 print*
354 print*, '*********** WARNING in P3_INIT *************'
355 print*, ' Loading lookupTable_1: v',trim(version_header_table_1_2mom)
356 print*, ' P3 v',trim(version_p3),' is intended to use lookupTable_1: ', &
357 trim(version_intended_table_1_2mom)
358 !print*, ' -- ABORTING -- '
359 print*, '************************************************'
360 print*
361 global_status = STATUS_ERROR
362 if (trim(model) == 'WRF') then
363 print*,'Stopping in P3 init'
364 stop
365 endif
366 endif
368 IF_OK: if (global_status /= STATUS_ERROR) then
370 read(10,*)
371 do jj = 1,densize
372 do ii = 1,rimsize
373 do i = 1,isize
374 ! read(10,*) dum,dum,dum,dum,itab(jj,ii,i, 1),itab(jj,ii,i, 2), &
375 ! itab(jj,ii,i, 3),itab(jj,ii,i, 4),itab(jj,ii,i, 5), &
376 ! itab(jj,ii,i, 6),itab(jj,ii,i, 7),itab(jj,ii,i, 8),dum, &
377 ! itab(jj,ii,i, 9),itab(jj,ii,i,10),itab(jj,ii,i,11),itab(jj,ii,i,12), &
378 ! itab(jj,ii,i,13),itab(jj,ii,i,14)
379 read(10,*) dum,dum,dum, itab(jj,ii,i, 1),itab(jj,ii,i, 2), &
380 itab(jj,ii,i, 3),itab(jj,ii,i, 4),itab(jj,ii,i, 5), &
381 itab(jj,ii,i, 6),itab(jj,ii,i, 7),itab(jj,ii,i, 8), &
382 itab(jj,ii,i, 9),itab(jj,ii,i,10),itab(jj,ii,i,11), &
383 itab(jj,ii,i,12),itab(jj,ii,i,13),itab(jj,ii,i,14)
384 enddo
386 !read in table for ice-rain collection
387 do i = 1,isize
388 do j = 1,rcollsize
389 ! read(10,*) dum,dum,dum,dum,dum,dp_dum1,dp_dum2,dum
390 ! itabcoll(jj,ii,i,j,1) = sngl(dlog10(max(dp_dum1,1.d-90)))
391 ! itabcoll(jj,ii,i,j,2) = sngl(dlog10(max(dp_dum2,1.d-90)))
392 read(10,*) dum,dum,dum, dp_dum1,dp_dum2
393 itabcoll(jj,ii,i,j,1) = dp_dum1
394 itabcoll(jj,ii,i,j,2) = dp_dum2
395 enddo
396 enddo
397 enddo !ii
398 enddo !jj
400 endif IF_OK
401 close(10)
403 if (global_status == STATUS_ERROR) then
404 if (err_abort) then
405 print*,'Stopping in P3 init'
406 flush(6)
407 stop
408 endif
409 return
410 endif
412 else ! TRIPLE_MOMENT_ICE (the following is for trplMomI=.true.)
414 print*, ' Reading table 1 [',trim(version_intended_table_1_3mom),'] ...'
416 open(unit=10,file=lookup_file_1,status='old',iostat=ierr,err=101)
417 101 if (ierr.ne.0) then
418 print*,'Error opening 3-moment lookup table file '//lookup_file_1
419 print*,'Make sure this file is unzipped and then rerun the model.'
420 print*,' '
421 flush(6)
422 stop
423 end if
425 !-- check that table version is correct:
426 ! note: to override and use a different lookup table, simply comment out the 'return' below
427 read(10,*) dumstr,version_header_table_1_3mom
428 if (trim(version_intended_table_1_3mom) /= trim(version_header_table_1_3mom)) then
429 print*
430 print*, '*********** WARNING in P3_INIT *************'
431 print*, ' Loading lookupTable_1: v',trim(version_header_table_1_3mom)
432 print*, ' P3 v',trim(version_p3),' is intended to use lookupTable_1: v', &
433 trim(version_intended_table_1_3mom)
434 !print*, ' -- ABORTING -- '
435 print*, '************************************************'
436 print*
437 global_status = STATUS_ERROR
438 if (trim(model) == 'WRF') then
439 print*,'Stopping in P3 init'
440 stop
441 endif
442 endif
444 read(10,*)
446 do zz = 1,zsize
447 do jj = 1,densize
448 do ii = 1,rimsize
449 do i = 1,isize
450 read(10,*) dum,dum,dum,dum, itab_3mom(zz,jj,ii,i, 1),itab_3mom(zz,jj,ii,i, 2), &
451 itab_3mom(zz,jj,ii,i, 3),itab_3mom(zz,jj,ii,i, 4),itab_3mom(zz,jj,ii,i, 5), &
452 itab_3mom(zz,jj,ii,i, 6),itab_3mom(zz,jj,ii,i, 7),itab_3mom(zz,jj,ii,i, 8), &
453 itab_3mom(zz,jj,ii,i, 9),itab_3mom(zz,jj,ii,i,10),itab_3mom(zz,jj,ii,i,11), &
454 itab_3mom(zz,jj,ii,i,12),itab_3mom(zz,jj,ii,i,13),itab_3mom(zz,jj,ii,i,14), &
455 itab_3mom(zz,jj,ii,i,15)
456 enddo
457 !read in table for ice-rain collection
458 do i = 1,isize
459 do j = 1,rcollsize
460 ! read(10,*) dum,dum,dum,dum,dum,dp_dum1,dp_dum2
461 read(10,*) dum,dum,dum, dp_dum1,dp_dum2
462 itabcoll_3mom(zz,jj,ii,i,j,1) = dp_dum1
463 itabcoll_3mom(zz,jj,ii,i,j,2) = dp_dum2
464 enddo
465 enddo
466 enddo !ii
467 enddo !jj
468 enddo !zz
470 close(10)
472 endif TRIPLE_MOMENT_ICE
474 IF_NCAT: if (nCat>1) then
475 ! read in ice-ice collision lookup table (used for multicategory only)
477 print*, ' Reading table 2 [',trim(version_intended_table_2),'] ...'
478 open(unit=10,file=lookup_file_2,status='old')
480 !--check that table version is correct:
481 read(10,*) dumstr,version_header_table_2
482 if (trim(version_intended_table_2) /= trim(version_header_table_2)) then
483 print*
484 print*, '*********** WARNING in P3_INIT *************'
485 print*, ' Loading lookupTable_2 version: ',trim(version_header_table_2)
486 print*, ' P3 v',trim(version_p3),' is intended to use lookupTable_2: v', &
487 trim(version_intended_table_2)
488 !print*, ' -- ABORTING -- '
489 print*, '************************************************'
490 print*
491 global_status = STATUS_ERROR
492 if (trim(model)=='WRF' .or. trim(model)=='KIN1D') then
493 print*,'Stopping in P3 init'
494 stop
495 endif
496 endif
497 IF_OKB: if (global_status /= STATUS_ERROR) then
498 read(10,*)
500 do i = 1,iisize
501 do jjj = 1,rimsize
502 do jjjj = 1,densize
503 do ii = 1,iisize
504 do jjj2 = 1,rimsize
505 do jjjj2 = 1,densize
506 read(10,*) dum,dum,dum,dum,dum,dum, &
507 itabcolli1(i,jjj,jjjj,ii,jjj2,jjjj2), &
508 itabcolli2(i,jjj,jjjj,ii,jjj2,jjjj2)
509 enddo
510 enddo
511 enddo
512 enddo
513 enddo
514 enddo
515 endif IF_OKB
517 close(unit=10)
519 endif IF_NCAT
521 endif IF_PROC0
523 #ifdef ECCCGEM
524 call rpn_comm_bcast(global_status,1,RPN_COMM_INTEGER,0,RPN_COMM_GRID,istat)
525 #endif
527 if (global_status == STATUS_ERROR) then
528 if (err_abort) then
529 print*,'Stopping in P3 init'
530 flush(6)
531 stop
532 endif
533 return
534 endif
536 #ifdef ECCCGEM
537 if (trplMomI) then
538 call rpn_comm_bcast(itab_3mom,size(itab_3mom),RPN_COMM_REAL,0,RPN_COMM_GRID,istat)
539 call rpn_comm_bcast(itabcoll_3mom,size(itabcoll_3mom),RPN_COMM_REAL,0,RPN_COMM_GRID,istat)
540 else
541 call rpn_comm_bcast(itab,size(itab),RPN_COMM_REAL,0,RPN_COMM_GRID,istat)
542 call rpn_comm_bcast(itabcoll,size(itabcoll),RPN_COMM_REAL,0,RPN_COMM_GRID,istat)
543 endif
544 if (nCat>1) then
545 call rpn_comm_bcast(itabcolli1,size(itabcolli1),RPN_COMM_REAL,0,RPN_COMM_GRID,istat)
546 call rpn_comm_bcast(itabcolli2,size(itabcolli2),RPN_COMM_REAL,0,RPN_COMM_GRID,istat)
547 endif
548 #endif
550 !------------------------------------------------------------------------------------------!
552 ! Generate lookup table for rain shape parameter mu_r
553 ! this is very fast so it can be generated at the start of each run
554 ! make a 150x1 1D lookup table, this is done in parameter
555 ! space of a scaled mean size proportional qr/Nr -- initlamr
557 !print*, ' Generating rain lookup-table ...'
559 !-- for variable mu_r only:
560 ! ! ! do i = 1,150 ! loop over lookup table values
561 ! ! ! initlamr = 1./((real(i)*2.)*1.e-6 + 250.e-6)
562 ! ! !
563 ! ! ! ! iterate to get mu_r
564 ! ! ! ! mu_r-lambda relationship is from Cao et al. (2008), eq. (7)
565 ! ! !
566 ! ! ! ! start with first guess, mu_r = 0
567 ! ! !
568 ! ! ! mu_r = 0.
569 ! ! !
570 ! ! ! do ii=1,50
571 ! ! ! lamr = initlamr*((mu_r+3.)*(mu_r+2.)*(mu_r+1.)/6.)**thrd
572 ! ! !
573 ! ! ! ! new estimate for mu_r based on lambda
574 ! ! ! ! set max lambda in formula for mu_r to 20 mm-1, so Cao et al.
575 ! ! ! ! formula is not extrapolated beyond Cao et al. data range
576 ! ! ! dum = min(20.,lamr*1.e-3)
577 ! ! ! mu_r = max(0.,-0.0201*dum**2+0.902*dum-1.718)
578 ! ! !
579 ! ! ! ! if lambda is converged within 0.1%, then exit loop
580 ! ! ! if (ii.ge.2) then
581 ! ! ! if (abs((lamold-lamr)/lamr).lt.0.001) goto 111
582 ! ! ! end if
583 ! ! !
584 ! ! ! lamold = lamr
585 ! ! !
586 ! ! ! enddo
587 ! ! !
588 ! ! ! 111 continue
589 ! ! !
590 ! ! ! ! assign lookup table values
591 ! ! ! mu_r_table(i) = mu_r
592 ! ! !
593 ! ! ! enddo
594 !==
596 mu_r_table(:) = mu_r_constant
598 !.......................................................................
599 ! Generate lookup table for rain fallspeed and ventilation parameters
600 ! the lookup table is two dimensional as a function of number-weighted mean size
601 ! proportional to qr/Nr and shape parameter mu_r
603 if (procnum == 0) then
604 print*, ' Generating table for rain fallspeed/ventilation parameters ...'
605 endif
607 mu_r_loop: do ii = 1,10
609 !mu_r = real(ii-1) ! values of mu
610 mu_r = mu_r_constant
612 ! loop over number-weighted mean size
613 meansize_loop: do jj = 1,300
615 if (jj.le.20) then
616 dm = (real(jj)*10.-5.)*1.e-6 ! mean size [m]
617 elseif (jj.gt.20) then
618 dm = (real(jj-20)*30.+195.)*1.e-6 ! mean size [m]
619 endif
621 lamr = (mu_r+1)/dm
623 ! do numerical integration over PSD
625 dum1 = 0. ! numerator, number-weighted fallspeed
626 dum2 = 0. ! denominator, number-weighted fallspeed
627 dum3 = 0. ! numerator, mass-weighted fallspeed
628 dum4 = 0. ! denominator, mass-weighted fallspeed
629 dum5 = 0. ! term for ventilation factor in evap
630 dd = 2.
632 ! loop over PSD to numerically integrate number and mass-weighted mean fallspeeds
633 do kk = 1,10000
635 dia = (real(kk)*dd-dd*0.5)*1.e-6 ! size bin [m]
636 amg = piov6*997.*dia**3 ! mass [kg]
637 amg = amg*1000. ! convert [kg] to [g]
639 !get fallspeed as a function of size [m s-1]
640 if (dia*1.e+6.le.134.43) then
641 vt = 4.5795e+3*amg**(2.*thrd)
642 elseif (dia*1.e+6.lt.1511.64) then
643 vt = 4.962e+1*amg**thrd
644 elseif (dia*1.e+6.lt.3477.84) then
645 vt = 1.732e+1*amg**sxth
646 else
647 vt = 9.17
648 endif
650 !note: factor of 4.*mu_r is non-answer changing and only needed to
651 ! prevent underflow/overflow errors, same with 3.*mu_r for dum5
652 dum1 = dum1 + vt*10.**(mu_r*alog10(dia)+4.*mu_r)*exp(-lamr*dia)*dd*1.e-6
653 dum2 = dum2 + 10.**(mu_r*alog10(dia)+4.*mu_r)*exp(-lamr*dia)*dd*1.e-6
654 dum3 = dum3 + vt*10.**((mu_r+3.)*alog10(dia)+4.*mu_r)*exp(-lamr*dia)*dd*1.e-6
655 dum4 = dum4 + 10.**((mu_r+3.)*alog10(dia)+4.*mu_r)*exp(-lamr*dia)*dd*1.e-6
656 dum5 = dum5 + (vt*dia)**0.5*10.**((mu_r+1.)*alog10(dia)+3.*mu_r)*exp(-lamr*dia)*dd*1.e-6
658 enddo ! kk-loop (over PSD)
660 dum2 = max(dum2, 1.e-30) !to prevent divide-by-zero below
661 dum4 = max(dum4, 1.e-30) !to prevent divide-by-zero below
662 dum5 = max(dum5, 1.e-30) !to prevent log10-of-zero below
664 vn_table(jj,ii) = dum1/dum2
665 vm_table(jj,ii) = dum3/dum4
666 revap_table(jj,ii) = 10.**(alog10(dum5)+(mu_r+1.)*alog10(lamr)-(3.*mu_r))
668 enddo meansize_loop
670 enddo mu_r_loop
672 !.......................................................................
674 if (procnum == 0) then
675 print*, ' P3_INIT DONE.'
676 print*
677 endif
679 end_status = STATUS_OK
680 if (present(stat)) stat = end_status
681 is_init = .true.
683 return
685 END subroutine p3_init
687 !==================================================================================================!
688 #ifndef ECCCGEM
690 SUBROUTINE mp_p3_wrapper_wrf(th_3d,qv_3d,qc_3d,qr_3d,qnr_3d, &
691 th_old_3d,qv_old_3d, &
692 pii,p,dz,w,dt,itimestep, &
693 rainnc,rainncv,sr,snownc,snowncv,n_iceCat, &
694 ids, ide, jds, jde, kds, kde , &
695 ims, ime, jms, jme, kms, kme , &
696 its, ite, jts, jte, kts, kte , &
697 diag_zdbz_3d,diag_effc_3d,diag_effi_3d, &
698 diag_vmi_3d,diag_di_3d,diag_rhopo_3d, &
699 qi1_3d,qni1_3d,qir1_3d,qib1_3d,nc_3d,qzi1_3d)
700 ! diag_dhmax_3d,diag_lami_3d,diag_mui_3d)
702 !------------------------------------------------------------------------------------------!
703 ! This subroutine is the main WRF interface with the P3 microphysics scheme. It takes !
704 ! 3D variables form the driving model and passes 2D slabs (i,k) to the main microphysics !
705 ! subroutine ('P3_MAIN') over a j-loop. For each slab, 'P3_MAIN' updates the prognostic !
706 ! variables (hydrometeor variables, potential temperature, and water vapor). The wrapper !
707 ! also updates the accumulated precipitation arrays and then passes back them, the !
708 ! updated 3D fields, and some diagnostic fields to the driver model. !
709 ! !
710 ! Three configurations of the P3 scheme are currently available: !
711 ! 1) specified droplet number (i.e. 1-moment cloud water), 1 ice category !
712 ! 2) predicted droplet number (i.e. 2-moment cloud water), 1 ice category !
713 ! 3) predicted droplet number (i.e. 2-moment cloud water), 2 ice categories !
714 ! 4) predicted droplet number (i.e. 2-moment cloud water), 1 ice catetory, 3-moment ice !
715 ! !
716 ! The 2-moment cloud version is based on a specified aerosol distribution and !
717 ! does not include a subgrid-scale vertical velocity for droplet activation. Hence, !
718 ! this version should only be used for high-resolution simulations that resolve !
719 ! vertical motion driving droplet activation. !
720 ! !
721 !------------------------------------------------------------------------------------------!
723 !--- input:
725 ! pii --> Exner function (nondimensional pressure) (currently not used!)
726 ! p --> pressure (pa)
727 ! dz --> height difference across vertical levels (m)
728 ! w --> vertical air velocity (m/s)
729 ! dt --> time step (s)
730 ! itimestep --> integer time step counter
731 ! n_iceCat --> number of ice-phase categories
734 !--- input/output:
736 ! th_3d --> theta (K)
737 ! qv_3d --> vapor mass mixing ratio (kg/kg)
738 ! qc_3d --> cloud water mass mixing ratio (kg/kg)
739 ! qr_3d --> rain mass mixing ratio (kg/kg)
740 ! qnr_3d --> rain number mixing ratio (#/kg)
741 ! qi1_3d --> total ice mixing ratio (kg/kg)
742 ! qni1_3d --> ice number mixing ratio (#/kg)
743 ! qir1_3d --> rime ice mass mixing ratio (kg/kg)
744 ! qib1_3d --> ice rime volume mixing ratio (m^-3 kg^-1)
745 ! qzi1_3d --> ice rime volume mixing ratio (m^-6 kg^-1)
746 ! nc_3d --> cloud droplet number mixing ratio (#/kg)
748 !--- output:
750 ! rainnc --> accumulated surface precip (mm)
751 ! rainncv --> one time step accumulated surface precip (mm)
752 ! sr --> ice to total surface precip ratio
753 ! snownc --> accumulated surface ice precip (mm)
754 ! snowncv --> one time step accumulated surface ice precip (mm)
755 ! ids...kte --> integer domain/tile bounds
756 ! diag_zdbz_3d --> reflectivity (dBZ)
757 ! diag_effc_3d --> cloud droplet effective radius (m)
758 ! diag_effi_3d --> ice effective radius (m)
759 ! diag_vmi_3d --> mean mass weighted ice fallspeed (m/s)
760 ! diag_di_3d --> mean mass weighted ice size (m)
761 ! diag_rhopo_3d --> mean mass weighted ice density (kg/m3)
763 implicit none
765 !--- arguments:
767 integer, intent(in) :: ids, ide, jds, jde, kds, kde , &
768 ims, ime, jms, jme, kms, kme , &
769 its, ite, jts, jte, kts, kte
770 real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: th_3d,qv_3d,qc_3d,qr_3d, &
771 qnr_3d,diag_zdbz_3d,diag_effc_3d,diag_effi_3d,diag_vmi_3d,diag_di_3d, &
772 diag_rhopo_3d,th_old_3d,qv_old_3d
773 ! real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: diag_dhmax_3d, &
774 ! diag_lami_3d,diag_mui_3d
775 real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: qi1_3d,qni1_3d,qir1_3d, &
776 qib1_3d
777 real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: nc_3d
778 real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qzi1_3d
780 real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: pii,p,dz,w
781 real, dimension(ims:ime, jms:jme), intent(inout) :: RAINNC,RAINNCV,SR,SNOWNC,SNOWNCV
782 real, intent(in) :: dt
783 integer, intent(in) :: itimestep
784 integer, intent(in) :: n_iceCat
786 !--- local variables/parameters:
788 character(len=16), parameter :: model = 'WRF'
790 real, dimension(ims:ime, kms:kme) ::nc,ssat
792 real, dimension(its:ite) :: pcprt_liq,pcprt_sol
793 real :: dum1
794 integer :: i,k,j
795 integer, parameter :: n_diag_3d = 1 ! number of user-defined diagnostic fields
796 integer, parameter :: n_diag_2d = 1 ! number of user-defined diagnostic fields
798 real, dimension(ims:ime, kms:kme, n_diag_3d) :: diag_3d
799 real, dimension(ims:ime, n_diag_2d) :: diag_2d
800 logical :: log_predictNc
801 logical :: log_3momentIce
802 logical, parameter :: debug_on = .false. !switch for internal debug checking
803 logical, parameter :: typeDiags_ON = .false.
804 real, parameter :: clbfact_dep = 1.0 !calibration factor for deposition
805 real, parameter :: clbfact_sub = 1.0 !calibration factor for sublimation
807 ! variables for cloud fraction (currently not used with WRF)
808 logical :: scpf_on ! switch for activation of SCPF scheme
809 real :: scpf_pfrac ! precipitation fraction factor (SCPF)
810 real :: scpf_resfact ! model resolution factor (SCPF)
811 real, dimension(ims:ime, kms:kme) :: cldfrac ! cloud fraction computed by SCPF
813 !------------------------------------------------------------------------------------------!
815 scpf_on=.false. ! cloud fraction version not used with WRF
816 scpf_pfrac=0. ! dummy variable (not used), set to 0
817 scpf_resfact=0. ! dummy variable (not used), set to 0
819 log_predictNc=.false.
820 if (present(nc_3d)) log_predictNc = .true.
822 log_3momentIce=.false.
823 if (present(qzi1_3d)) log_3momentIce = .true.
825 ! convert advected (N*Z)^0.5 to Z for P3 main
826 if (log_3momentIce) then
827 do j = jts,jte
828 do k = kts,kte
829 do i = its,ite
830 if (qni1_3d(i,k,j).ge.qsmall) then
831 qzi1_3d(i,k,j) = qzi1_3d(i,k,j)**2/qni1_3d(i,k,j)
832 else
833 qzi1_3d(i,k,j) = 0.
834 endif
835 enddo
836 enddo
837 enddo
838 endif
839 !.............................................
841 do j = jts,jte ! j loop (north-south)
843 if (log_predictNc) then
844 nc(its:ite,kts:kte)=nc_3d(its:ite,kts:kte,j)
845 ! if Nc is specified then set nc array to zero
846 else
847 nc=0.
848 endif
850 ! note: code for prediction of ssat not currently avaiable, set 2D array to 0
851 ssat=0.
853 if (.not. log_3momentIce) then
854 call P3_MAIN(qc_3d(its:ite,kts:kte,j),nc(its:ite,kts:kte), &
855 qr_3d(its:ite,kts:kte,j),qnr_3d(its:ite,kts:kte,j), &
856 th_old_3d(its:ite,kts:kte,j),th_3d(its:ite,kts:kte,j),qv_old_3d(its:ite,kts:kte,j), &
857 qv_3d(its:ite,kts:kte,j),dt,qi1_3d(its:ite,kts:kte,j), &
858 qir1_3d(its:ite,kts:kte,j),qni1_3d(its:ite,kts:kte,j), &
859 qib1_3d(its:ite,kts:kte,j),ssat(its:ite,kts:kte), &
860 W(its:ite,kts:kte,j),P(its:ite,kts:kte,j), &
861 DZ(its:ite,kts:kte,j),itimestep,pcprt_liq,pcprt_sol,its,ite,kts,kte,n_iceCat, &
862 diag_zdbz_3d(its:ite,kts:kte,j),diag_effc_3d(its:ite,kts:kte,j), &
863 diag_effi_3d(its:ite,kts:kte,j),diag_vmi_3d(its:ite,kts:kte,j), &
864 diag_di_3d(its:ite,kts:kte,j),diag_rhopo_3d(its:ite,kts:kte,j), &
865 n_diag_2d,diag_2d(its:ite,1:n_diag_2d), &
866 n_diag_3d,diag_3d(its:ite,kts:kte,1:n_diag_3d), &
867 log_predictNc,typeDiags_ON,trim(model),clbfact_dep,clbfact_sub,debug_on, &
868 scpf_on,scpf_pfrac,scpf_resfact,cldfrac )!,diag_dhmax=diag_dhmax_3d(its:ite,kts:kte,j), &
869 ! diag_lami=diag_lami_3d(its:ite,kts:kte,j),diag_mui=diag_mui_3d(its:ite,kts:kte,j))
871 else if (log_3momentIce) then
873 call P3_MAIN(qc_3d(its:ite,kts:kte,j),nc(its:ite,kts:kte), &
874 qr_3d(its:ite,kts:kte,j),qnr_3d(its:ite,kts:kte,j), &
875 th_old_3d(its:ite,kts:kte,j),th_3d(its:ite,kts:kte,j),qv_old_3d(its:ite,kts:kte,j), &
876 qv_3d(its:ite,kts:kte,j),dt,qi1_3d(its:ite,kts:kte,j), &
877 qir1_3d(its:ite,kts:kte,j),qni1_3d(its:ite,kts:kte,j), &
878 qib1_3d(its:ite,kts:kte,j),ssat(its:ite,kts:kte), &
879 W(its:ite,kts:kte,j),P(its:ite,kts:kte,j), &
880 DZ(its:ite,kts:kte,j),itimestep,pcprt_liq,pcprt_sol,its,ite,kts,kte,n_iceCat, &
881 diag_zdbz_3d(its:ite,kts:kte,j),diag_effc_3d(its:ite,kts:kte,j), &
882 diag_effi_3d(its:ite,kts:kte,j),diag_vmi_3d(its:ite,kts:kte,j), &
883 diag_di_3d(its:ite,kts:kte,j),diag_rhopo_3d(its:ite,kts:kte,j), &
884 n_diag_2d,diag_2d(its:ite,1:n_diag_2d), &
885 n_diag_3d,diag_3d(its:ite,kts:kte,1:n_diag_3d), &
886 log_predictNc,typeDiags_ON,trim(model),clbfact_dep,clbfact_sub,debug_on, &
887 scpf_on,scpf_pfrac,scpf_resfact,cldfrac,zitot=qzi1_3d(its:ite,kts:kte,j))
888 ! diag_dhmax=diag_dhmax_3d(its:ite,kts:kte,j),diag_lami=diag_lami_3d(its:ite,kts:kte,j), &
889 ! diag_mui=diag_mui_3d(its:ite,kts:kte,j))
890 endif ! 3momentIce
892 !surface precipitation output:
893 dum1 = 1000.*dt
894 RAINNC(its:ite,j) = RAINNC(its:ite,j) + (pcprt_liq(:) + pcprt_sol(:))*dum1 ! conversion from m/s to mm/time step
895 RAINNCV(its:ite,j) = (pcprt_liq(:) + pcprt_sol(:))*dum1 ! conversion from m/s to mm/time step
896 SNOWNC(its:ite,j) = SNOWNC(its:ite,j) + pcprt_sol(:)*dum1 ! conversion from m/s to mm/time step
897 SNOWNCV(its:ite,j) = pcprt_sol(:)*dum1 ! conversion from m/s to mm/time step
898 SR(its:ite,j) = pcprt_sol(:)/(pcprt_liq(:)+pcprt_sol(:)+1.E-12) ! solid-to-total ratio
900 !convert nc array from 2D to 3D if Nc is predicted
901 if (log_predictNc) then
902 nc_3d(its:ite,kts:kte,j)=nc(its:ite,kts:kte)
903 endif
905 !set background effective radii (i.e. with no explicit condensate) to prescribed values:
906 ! where (qc_3d(:,:,j) < 1.e-14) diag_effc_3d(:,:,j) = 10.e-6
907 ! where (qitot < 1.e-14) diag_effi = 25.e-6
909 enddo ! j loop
911 ! convert Z from P3 to (N*Z)^0.5 for advection
912 if (log_3momentIce) then
913 do j = jts,jte
914 do k = kts,kte
915 do i = its,ite
916 if (qni1_3d(i,k,j).ge.qsmall.and.qzi1_3d(i,k,j).ge.1.e-30) then
917 qzi1_3d(i,k,j) = (qzi1_3d(i,k,j)*qni1_3d(i,k,j))**0.5
918 else
919 qzi1_3d(i,k,j) = 0.
920 endif
921 enddo
922 enddo
923 enddo
924 endif
925 !...............................................
927 if (global_status /= STATUS_OK) then
928 print*,'Stopping in P3, problem in P3 main'
929 stop
930 endif
932 END SUBROUTINE mp_p3_wrapper_wrf
934 !------------------------------------------------------------------------------------------!
936 SUBROUTINE mp_p3_wrapper_wrf_2cat(th_3d,qv_3d,qc_3d,qr_3d,qnr_3d, &
937 th_old_3d,qv_old_3d, &
938 pii,p,dz,w,dt,itimestep, &
939 rainnc,rainncv,sr,snownc,snowncv,n_iceCat, &
940 ids, ide, jds, jde, kds, kde , &
941 ims, ime, jms, jme, kms, kme , &
942 its, ite, jts, jte, kts, kte , &
943 diag_zdbz_3d,diag_effc_3d,diag_effi_3d, &
944 diag_vmi_3d,diag_di_3d,diag_rhopo_3d, &
945 diag_vmi2_3d,diag_di2_3d,diag_rhopo2_3d, &
946 qi1_3d,qni1_3d,qir1_3d,qib1_3d, &
947 qi2_3d,qni2_3d,qir2_3d,qib2_3d,nc_3d)
949 !------------------------------------------------------------------------------------------!
950 ! This subroutine is the main WRF interface with the P3 microphysics scheme. It takes !
951 ! 3D variables form the driving model and passes 2D slabs (i,k) to the main microphysics !
952 ! subroutine ('P3_MAIN') over a j-loop. For each slab, 'P3_MAIN' updates the prognostic !
953 ! variables (hydrometeor variables, potential temperature, and water vapor). The wrapper !
954 ! also updates the accumulated precipitation arrays and then passes back them, the !
955 ! updated 3D fields, and some diagnostic fields to the driver model. !
956 ! !
957 !------------------------------------------------------------------------------------------!
959 !--- input:
961 ! pii --> Exner function (nondimensional pressure) (currently not used!)
962 ! p --> pressure (pa)
963 ! dz --> height difference across vertical levels (m)
964 ! w --> vertical air velocity (m/s)
965 ! dt --> time step (s)
966 ! itimestep --> integer time step counter
967 ! n_iceCat --> number of ice-phase categories
970 !--- input/output:
972 ! th_3d --> theta (K)
973 ! qv_3d --> vapor mass mixing ratio (kg/kg)
974 ! qc_3d --> cloud water mass mixing ratio (kg/kg)
975 ! qr_3d --> rain mass mixing ratio (kg/kg)
976 ! qnr_3d --> rain number mixing ratio (#/kg)
977 ! qi1_3d --> total ice mixing ratio category 1 (kg/kg)
978 ! qni1_3d --> ice number mixing ratio category 1 (#/kg)
979 ! qir1_3d --> rime ice mass mixing ratio category 1 (kg/kg)
980 ! qib1_3d --> ice rime volume mixing ratio category 1 (m^-3 kg^-1)
981 ! qi2_3d --> total ice mixing ratio category 2 (kg/kg)
982 ! qni2_3d --> ice number mixing ratio category 2 (#/kg)
983 ! qir2_3d --> rime ice mass mixing ratio category 2 (kg/kg)
984 ! qib2_3d --> ice rime volume mixing ratio category 2 (m^-3 kg^-1)
985 ! nc_3d --> cloud droplet number mixing ratio (#/kg)
987 !--- output:
989 ! rainnc --> accumulated surface precip (mm)
990 ! rainncv --> one time step accumulated surface precip (mm)
991 ! sr --> ice to total surface precip ratio
992 ! snownc --> accumulated surface ice precip (mm)
993 ! snowncv --> one time step accumulated surface ice precip (mm)
994 ! ids...kte --> integer domain/tile bounds
995 ! diag_zdbz_3d --> reflectivity (dBZ)
996 ! diag_effc_3d --> cloud droplet effective radius (m)
997 ! diag_effi_3d --> ice effective radius (m)
998 ! diag_vmi_3d --> mean mass weighted ice fallspeed category 1 (m/s)
999 ! diag_di_3d --> mean mass weighted ice size category 1 (m)
1000 ! diag_rhopo_3d --> mean mass weighted ice density category 1 (kg/m3)
1001 ! diag_vmi2_3d --> mean mass weighted ice fallspeed category 2 (m/s)
1002 ! diag_di2_3d --> mean mass weighted ice size category 2 (m)
1003 ! diag_rhopo2_3d --> mean mass weighted ice density category 2 (kg/m3)
1005 implicit none
1007 !--- arguments:
1009 integer, intent(in) :: ids, ide, jds, jde, kds, kde , &
1010 ims, ime, jms, jme, kms, kme , &
1011 its, ite, jts, jte, kts, kte
1012 real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: th_3d,qv_3d,qc_3d,qr_3d, &
1013 qnr_3d,diag_zdbz_3d,diag_effc_3d,diag_effi_3d,diag_vmi_3d,diag_di_3d, &
1014 diag_rhopo_3d,th_old_3d,qv_old_3d, &
1015 diag_vmi2_3d,diag_di2_3d,diag_rhopo2_3d
1016 real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: qi1_3d,qni1_3d,qir1_3d, &
1017 qib1_3d
1018 real, dimension(ims:ime, kms:kme, jms:jme), intent(inout) :: qi2_3d,qni2_3d, &
1019 qir2_3d,qib2_3d
1020 real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: nc_3d
1022 real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: pii,p,dz,w
1023 real, dimension(ims:ime, jms:jme), intent(inout) :: RAINNC,RAINNCV,SR,SNOWNC,SNOWNCV
1024 real, intent(in) :: dt
1025 integer, intent(in) :: itimestep
1026 integer, intent(in) :: n_iceCat
1028 !--- local variables/parameters:
1030 character(len=16), parameter :: model = 'WRF'
1032 real, dimension(ims:ime, kms:kme) ::nc,ssat
1034 ! note: hard-wired for two ice categories
1035 real, dimension(ims:ime, kms:kme, 2) :: qitot,qirim,nitot,birim,diag_di,diag_vmi, &
1036 diag_rhopo,diag_effi
1038 real, dimension(its:ite) :: pcprt_liq,pcprt_sol
1039 real :: dum1,dum2
1040 integer :: i,k,j
1041 integer, parameter :: n_diag_3d = 1 ! number of user-defined diagnostic fields
1042 integer, parameter :: n_diag_2d = 1 ! number of user-defined diagnostic fields
1044 real, dimension(ims:ime, kms:kme, n_diag_3d) :: diag_3d
1045 real, dimension(ims:ime, n_diag_2d) :: diag_2d
1046 logical :: log_predictNc
1047 logical, parameter :: typeDiags_ON = .false.
1048 logical, parameter :: debug_on = .false. !switch for internal debug checking
1049 real, parameter :: clbfact_dep = 1.0 !calibration factor for deposition
1050 real, parameter :: clbfact_sub = 1.0 !calibration factor for sublimation
1052 ! variables for cloud fraction (currently not used with WRF)
1053 logical :: scpf_on ! switch for activation of SCPF scheme
1054 real :: scpf_pfrac ! precipitation fraction factor (SCPF)
1055 real :: scpf_resfact ! model resolution factor (SCPF)
1056 real, dimension(ims:ime, kms:kme) :: cldfrac ! cloud fraction computed by SCPF
1058 !------------------------------------------------------------------------------------------!
1060 scpf_on=.false. ! cloud fraction version not used with WRF
1061 scpf_pfrac=0. ! dummy variable (not used), set to 0
1062 scpf_resfact=0. ! dummy variable (not used), set to 0
1064 log_predictNc=.false.
1065 if (present(nc_3d)) log_predictNc = .true.
1067 do j = jts,jte ! j loop (north-south)
1069 if (log_predictNc) then
1070 nc(its:ite,kts:kte)=nc_3d(its:ite,kts:kte,j)
1071 ! if Nc is specified then set nc array to zero
1072 else
1073 nc=0.
1074 endif
1076 ! note: code for prediction of ssat not currently avaiable, set 2D array to 0
1077 ssat=0.
1079 !contruct full ice arrays from individual category arrays:
1080 qitot(:,:,1) = qi1_3d(:,:,j)
1081 qirim(:,:,1) = qir1_3d(:,:,j)
1082 nitot(:,:,1) = qni1_3d(:,:,j)
1083 birim(:,:,1) = qib1_3d(:,:,j)
1085 qitot(:,:,2) = qi2_3d(:,:,j)
1086 qirim(:,:,2) = qir2_3d(:,:,j)
1087 nitot(:,:,2) = qni2_3d(:,:,j)
1088 birim(:,:,2) = qib2_3d(:,:,j)
1090 call P3_MAIN(qc_3d(its:ite,kts:kte,j),nc(its:ite,kts:kte), &
1091 qr_3d(its:ite,kts:kte,j),qnr_3d(its:ite,kts:kte,j), &
1092 th_old_3d(its:ite,kts:kte,j),th_3d(its:ite,kts:kte,j),qv_old_3d(its:ite,kts:kte,j), &
1093 qv_3d(its:ite,kts:kte,j),dt,qitot(its:ite,kts:kte,1:n_iceCat), &
1094 qirim(its:ite,kts:kte,1:n_iceCat),nitot(its:ite,kts:kte,1:n_iceCat), &
1095 birim(its:ite,kts:kte,1:n_iceCat),ssat(its:ite,kts:kte), &
1096 W(its:ite,kts:kte,j),P(its:ite,kts:kte,j), &
1097 DZ(its:ite,kts:kte,j),itimestep,pcprt_liq,pcprt_sol,its,ite,kts,kte,n_iceCat, &
1098 diag_zdbz_3d(its:ite,kts:kte,j),diag_effc_3d(its:ite,kts:kte,j), &
1099 diag_effi(its:ite,kts:kte,1:n_iceCat),diag_vmi(its:ite,kts:kte,1:n_iceCat), &
1100 diag_di(its:ite,kts:kte,1:n_iceCat),diag_rhopo(its:ite,kts:kte,1:n_iceCat), &
1101 n_diag_2d,diag_2d(its:ite,1:n_diag_2d), &
1102 n_diag_3d,diag_3d(its:ite,kts:kte,1:n_diag_3d), &
1103 log_predictNc,typeDiags_ON,trim(model),clbfact_dep,clbfact_sub,debug_on, &
1104 scpf_on,scpf_pfrac,scpf_resfact,cldfrac)
1106 !surface precipitation output:
1107 dum1 = 1000.*dt
1108 RAINNC(its:ite,j) = RAINNC(its:ite,j) + (pcprt_liq(:) + pcprt_sol(:))*dum1 ! conversion from m/s to mm/time step
1109 RAINNCV(its:ite,j) = (pcprt_liq(:) + pcprt_sol(:))*dum1 ! conversion from m/s to mm/time step
1110 SNOWNC(its:ite,j) = SNOWNC(its:ite,j) + pcprt_sol(:)*dum1 ! conversion from m/s to mm/time step
1111 SNOWNCV(its:ite,j) = pcprt_sol(:)*dum1 ! conversion from m/s to mm/time step
1112 SR(its:ite,j) = pcprt_sol(:)/(pcprt_liq(:)+pcprt_sol(:)+1.E-12) ! solid-to-total ratio
1114 !convert nc array from 2D to 3D if Nc is predicted
1115 if (log_predictNc) then
1116 nc_3d(its:ite,kts:kte,j)=nc(its:ite,kts:kte)
1117 endif
1119 !set background effective radii (i.e. with no explicit condensate) to prescribed values:
1120 ! where (qc_3d(:,:,j) < 1.e-14) diag_effc_3d(:,:,j) = 10.e-6
1121 ! where (qitot < 1.e-14) diag_effi = 25.e-6
1123 !decompose full ice arrays into individual category arrays:
1124 qi1_3d(its:ite,kts:kte,j) = qitot(its:ite,kts:kte,1)
1125 qir1_3d(its:ite,kts:kte,j) = qirim(its:ite,kts:kte,1)
1126 qni1_3d(its:ite,kts:kte,j) = nitot(its:ite,kts:kte,1)
1127 qib1_3d(its:ite,kts:kte,j) = birim(its:ite,kts:kte,1)
1129 qi2_3d(its:ite,kts:kte,j) = qitot(its:ite,kts:kte,2)
1130 qir2_3d(its:ite,kts:kte,j) = qirim(its:ite,kts:kte,2)
1131 qni2_3d(its:ite,kts:kte,j) = nitot(its:ite,kts:kte,2)
1132 qib2_3d(its:ite,kts:kte,j) = birim(its:ite,kts:kte,2)
1134 diag_vmi_3d(its:ite,kts:kte,j) = diag_vmi(its:ite,kts:kte,1)
1135 diag_di_3d(its:ite,kts:kte,j) = diag_di(its:ite,kts:kte,1)
1136 diag_rhopo_3d(its:ite,kts:kte,j) = diag_rhopo(its:ite,kts:kte,1)
1137 diag_vmi2_3d(its:ite,kts:kte,j) = diag_vmi(its:ite,kts:kte,2)
1138 diag_di2_3d(its:ite,kts:kte,j) = diag_di(its:ite,kts:kte,2)
1139 diag_rhopo2_3d(its:ite,kts:kte,j) = diag_rhopo(its:ite,kts:kte,2)
1141 do i=its,ite
1142 do k=kts,kte
1144 ! for output fallspeed, size, and density, use mass-weighting of categories
1145 ! if ((qitot(i,k,1)+qitot(i,k,2)).ge.qsmall) then
1146 ! diag_vmi_3d(i,k,j) = (diag_vmi(i,k,1)*qitot(i,k,1)+diag_vmi(i,k,2)*qitot(i,k,2))/(qitot(i,k,1)+qitot(i,k,2))
1147 ! diag_di_3d(i,k,j) = (diag_di(i,k,1)*qitot(i,k,1)+diag_di(i,k,2)*qitot(i,k,2))/(qitot(i,k,1)+qitot(i,k,2))
1148 ! diag_rhopo_3d(i,k,j) = (diag_rhopo(i,k,1)*qitot(i,k,1)+diag_rhopo(i,k,2)*qitot(i,k,2))/(qitot(i,k,1)+qitot(i,k,2))
1149 ! else ! set to default values of 0 if ice is not present
1150 ! diag_vmi_3d(i,k,j) = 0.
1151 ! diag_di_3d(i,k,j) = 0.
1152 ! diag_rhopo_3d(i,k,j) = 0.
1153 ! end if
1155 ! for the combined effective radius, we need to approriately weight by mass and projected area
1156 if (qitot(i,k,1).ge.qsmall) then
1157 dum1=qitot(i,k,1)/diag_effi(i,k,1)
1158 else
1159 dum1=0.
1160 end if
1161 if (qitot(i,k,2).ge.qsmall) then
1162 dum2=qitot(i,k,2)/diag_effi(i,k,2)
1163 else
1164 dum2=0.
1165 end if
1166 diag_effi_3d(i,k,j)=25.e-6 ! set to default 25 microns
1167 if (qitot(i,k,1).ge.qsmall.or.qitot(i,k,2).ge.qsmall) then
1168 diag_effi_3d(i,k,j)=(qitot(i,k,1)+qitot(i,k,2))/(dum1+dum2)
1169 end if
1171 end do
1172 end do
1174 enddo ! j loop
1176 if (global_status /= STATUS_OK) then
1177 print*,'Stopping in P3, problem in P3 main'
1178 stop
1179 endif
1181 END SUBROUTINE mp_p3_wrapper_wrf_2cat
1183 #endif
1185 !==================================================================================================!
1186 #ifdef ECCCGEM
1188 function mp_p3_wrapper_gem(ttend,qtend,qctend,qrtend,qitend, &
1189 qvap_m,qvap,temp_m,temp,dt,dt_max,ww,psfc,gztherm,gzmom,sigma,kount,&
1190 trnch,ni,nk,prt_liq,prt_sol,prt_drzl,prt_rain,prt_crys,prt_snow, &
1191 prt_grpl,prt_pell,prt_hail,prt_sndp,diag_Zet,diag_Zec,diag_effc, &
1192 qc,nc,qr,nr,n_diag_2d,diag_2d,n_diag_3d,diag_3d, &
1193 clbfact_dep,clbfact_sub,debug_on,diag_hcb,diag_hsn,diag_vis, &
1194 diag_vis1,diag_vis2,diag_vis3,diag_slw, &
1195 scpf_on,scpf_pfrac,scpf_resfact,cldfrac, &
1196 qi_type_1,qi_type_2,qi_type_3,qi_type_4,qi_type_5,qi_type_6, &
1197 qitot_1,qirim_1,nitot_1,birim_1,diag_effi_1,zitot_1, &
1198 qitot_2,qirim_2,nitot_2,birim_2,diag_effi_2,zitot_2, &
1199 qitot_3,qirim_3,nitot_3,birim_3,diag_effi_3,zitot_3, &
1200 qitot_4,qirim_4,nitot_4,birim_4,diag_effi_4,zitot_4) &
1201 result(end_status)
1203 !------------------------------------------------------------------------------------------!
1204 ! This wrapper subroutine is the main GEM interface with the P3 microphysics scheme. It !
1205 ! prepares some necessary fields (converts temperature to potential temperature, etc.), !
1206 ! passes 2D slabs (i,k) to the main microphysics subroutine ('P3_MAIN') -- which updates !
1207 ! the prognostic variables (hydrometeor variables, temperature, and water vapor) and !
1208 ! computes various diagnostics fields (precipitation rates, reflectivity, etc.) -- and !
1209 ! finally converts the updated potential temperature to temperature. !
1210 !------------------------------------------------------------------------------------------!
1212 implicit none
1214 !----- input/ouput arguments: ------------------------------------------------------------!
1216 integer, intent(in) :: ni ! number of columns in slab -
1217 integer, intent(in) :: nk ! number of vertical levels -
1218 !integer, intent(in) :: n_iceCat ! number of ice categories -
1219 integer, intent(in) :: kount ! time step counter -
1220 integer, intent(in) :: trnch ! number of slice -
1221 integer, intent(in) :: n_diag_2d ! number of 2D diagnostic fields -
1222 integer, intent(in) :: n_diag_3d ! number of 3D diagnostic fields -
1224 real, intent(in) :: dt ! model time step s
1225 real, intent(in) :: dt_max ! maximum timestep for microphysics s
1226 real, intent(in) :: clbfact_dep ! calibration factor for deposition
1227 real, intent(in) :: clbfact_sub ! calibration factor for sublimation
1228 real, intent(inout), dimension(ni,nk) :: qc ! cloud mixing ratio, mass kg kg-1
1229 real, intent(inout), dimension(ni,nk) :: nc ! cloud mixing ratio, number # kg-1
1230 real, intent(inout), dimension(ni,nk) :: qr ! rain mixing ratio, mass kg kg-1
1231 real, intent(inout), dimension(ni,nk) :: nr ! rain mixing ratio, number # kg-1
1233 real, dimension(:,:), pointer, contiguous :: qitot_1 ! ice mixing ratio, mass (total) kg kg-1
1234 real, dimension(:,:), pointer, contiguous :: qirim_1 ! ice mixing ratio, mass (rime) kg kg-1
1235 real, dimension(:,:), pointer, contiguous :: nitot_1 ! ice mixing ratio, number # kg-1
1236 real, dimension(:,:), pointer, contiguous :: birim_1 ! ice mixing ratio, volume m3 kg-1
1237 real, dimension(:,:), pointer, contiguous :: diag_effi_1 ! ice effective radius, (cat 1) m
1238 real, intent(inout), dimension(ni,nk), optional :: zitot_1 ! ice mixing ratio, reflectivity m^6 kg-1
1240 real, dimension(:,:), pointer, contiguous :: qitot_2 ! ice mixing ratio, mass (total) kg kg-1
1241 real, dimension(:,:), pointer, contiguous :: qirim_2 ! ice mixing ratio, mass (rime) kg kg-1
1242 real, dimension(:,:), pointer, contiguous :: nitot_2 ! ice mixing ratio, number # kg-1
1243 real, dimension(:,:), pointer, contiguous :: birim_2 ! ice mixing ratio, volume m3 kg-1
1244 real, dimension(:,:), pointer, contiguous :: diag_effi_2 ! ice effective radius, (cat 2) m
1245 real, intent(inout), dimension(ni,nk), optional :: zitot_2 ! ice mixing ratio, reflectivity m^6 kg-1
1247 real, dimension(:,:), pointer, contiguous :: qitot_3 ! ice mixing ratio, mass (total) kg kg-1
1248 real, dimension(:,:), pointer, contiguous :: qirim_3 ! ice mixing ratio, mass (rime) kg kg-1
1249 real, dimension(:,:), pointer, contiguous :: nitot_3 ! ice mixing ratio, number # kg-1
1250 real, dimension(:,:), pointer, contiguous :: birim_3 ! ice mixing ratio, volume m3 kg-1
1251 real, dimension(:,:), pointer, contiguous :: diag_effi_3 ! ice effective radius, (cat 3) m
1252 real, intent(inout), dimension(ni,nk), optional :: zitot_3 ! ice mixing ratio, reflectivity m^6 kg-1
1254 real, dimension(:,:), pointer, contiguous :: qitot_4 ! ice mixing ratio, mass (total) kg kg-1
1255 real, dimension(:,:), pointer, contiguous :: qirim_4 ! ice mixing ratio, mass (rime) kg kg-1
1256 real, dimension(:,:), pointer, contiguous :: nitot_4 ! ice mixing ratio, number # kg-1
1257 real, dimension(:,:), pointer, contiguous :: birim_4 ! ice mixing ratio, volume m3 kg-1
1258 real, dimension(:,:), pointer, contiguous :: diag_effi_4 ! ice effective radius, (cat 4) m
1259 real, intent(inout), dimension(ni,nk), optional :: zitot_4 ! ice mixing ratio, reflectivity m^6 kg-1
1261 real, intent(out), dimension(ni,nk) :: ttend ! temperature tendency K s-1
1262 real, intent(out), dimension(ni,nk) :: qtend ! moisture tendency kg kg-1 s-1
1263 real, intent(out), dimension(ni,nk) :: qctend ! cloud water tendency kg kg-1 s-1
1264 real, intent(out), dimension(ni,nk) :: qrtend ! cloud water tendency kg kg-1 s-1
1265 real, intent(out), dimension(ni,nk) :: qitend ! total ice tendency kg kg-1 s-1
1267 real, intent(in), dimension(ni,nk) :: qvap_m ! vapor mixing ratio (previous time) kg kg-1
1268 real, intent(inout), dimension(ni,nk) :: qvap ! vapor mixing ratio, mass kg kg-1
1269 real, intent(in), dimension(ni,nk) :: temp_m ! temperature (previous time step) K
1270 real, intent(inout), dimension(ni,nk) :: temp ! temperature K
1271 real, intent(in), dimension(ni) :: psfc ! surface air pressure Pa
1272 real, intent(in), dimension(ni,nk) :: gztherm ! height AGL of thermodynamic levels m
1273 real, intent(in), dimension(ni,nk) :: gzmom ! height AGL of momentum levels m
1274 real, intent(in), dimension(ni,nk) :: sigma ! sigma = p(k,:)/psfc(:)
1275 real, intent(in), dimension(ni,nk) :: ww ! vertical motion m s-1
1276 real, intent(out), dimension(ni) :: prt_liq ! precipitation rate, total liquid m s-1
1277 real, intent(out), dimension(ni) :: prt_sol ! precipitation rate, total solid m s-1
1278 real, intent(out), dimension(ni) :: prt_drzl ! precipitation rate, drizzle m s-1
1279 real, intent(out), dimension(ni) :: prt_rain ! precipitation rate, rain m s-1
1280 real, intent(out), dimension(ni) :: prt_crys ! precipitation rate, ice cystals m s-1
1281 real, intent(out), dimension(ni) :: prt_snow ! precipitation rate, snow m s-1
1282 real, intent(out), dimension(ni) :: prt_grpl ! precipitation rate, graupel m s-1
1283 real, intent(out), dimension(ni) :: prt_pell ! precipitation rate, ice pellets m s-1
1284 real, intent(out), dimension(ni) :: prt_hail ! precipitation rate, hail m s-1
1285 real, intent(out), dimension(ni) :: prt_sndp ! precipitation rate, unmelted snow m s-1
1286 real, intent(out), dimension(ni,nk) :: diag_Zet ! equivalent reflectivity, 3D dBZ
1287 real, intent(out), dimension(ni) :: diag_Zec ! equivalent reflectivity, col-max dBZ
1288 real, intent(out), dimension(ni,nk) :: diag_effc ! effective radius, cloud m
1289 real, intent(out), dimension(ni,n_diag_2d) :: diag_2d ! user-defined 2D diagnostic fields
1290 real, intent(out), dimension(ni,nk,n_diag_3d) :: diag_3d ! user-defined 3D diagnostic fields
1291 !real, intent(out), dimension(ni,nk,n_qiType ):: qi_type ! mass mixing ratio, diag ice type kg kg-1
1293 real, intent(out), dimension(ni,nk) :: qi_type_1 ! small ice crystal mass kg kg-1
1294 real, intent(out), dimension(ni,nk) :: qi_type_2 ! unrimed snow crystal mass kg kg-1
1295 real, intent(out), dimension(ni,nk) :: qi_type_3 ! lightly rimed snow mass kg kg-1
1296 real, intent(out), dimension(ni,nk) :: qi_type_4 ! graupel mass kg kg-1
1297 real, intent(out), dimension(ni,nk) :: qi_type_5 ! hail mass kg kg-1
1298 real, intent(out), dimension(ni,nk) :: qi_type_6 ! ice pellet mass kg kg-1
1300 real, intent(out), dimension(ni) :: diag_hcb ! height of cloud base m
1301 real, intent(out), dimension(ni) :: diag_hsn ! height of snow level m
1302 real, intent(out), dimension(ni,nk) :: diag_vis ! visibility (total) m
1303 real, intent(out), dimension(ni,nk) :: diag_vis1 ! visibility through liquid fog m
1304 real, intent(out), dimension(ni,nk) :: diag_vis2 ! visibility through rain m
1305 real, intent(out), dimension(ni,nk) :: diag_vis3 ! visibility through snow m
1306 real, intent(out), dimension(ni,nk) :: diag_slw ! supercooled LWC kg m-3
1308 logical, intent(in) :: debug_on ! logical switch for internal debug checks
1309 logical, intent(in) :: scpf_on ! switch for activation of SCPF scheme
1310 real, intent(in) :: scpf_pfrac ! precipitation fraction factor (SCPF)
1311 real, intent(in) :: scpf_resfact ! model resolution factor (SCPF)
1312 real, intent(out), dimension(ni,nk) :: cldfrac ! cloud fraction computed by SCPF
1314 !----------------------------------------------------------------------------------------!
1316 !----- local variables and parameters:
1317 real, dimension(ni,nk,n_iceCat) :: qitot ! ice mixing ratio, mass (total) kg kg-1
1318 real, dimension(ni,nk,n_iceCat) :: qirim ! ice mixing ratio, mass (rime) kg kg-1
1319 real, dimension(ni,nk,n_iceCat) :: nitot ! ice mixing ratio, number # kg-1
1320 real, dimension(ni,nk,n_iceCat) :: birim ! ice mixing ratio, volume m3 kg-1
1321 real, dimension(ni,nk,n_iceCat) :: zitot ! ice mixing ratio, reflectivity m6 kg-1
1322 real, dimension(ni,nk,n_iceCat) :: diag_effi ! effective radius, ice m
1323 real, dimension(ni,nk,n_iceCat) :: diag_vmi ! mass-weighted fall speed, ice m s-1 (returned but not used)
1324 real, dimension(ni,nk,n_iceCat) :: diag_di ! mean diameter, ice m (returned but not used)
1325 real, dimension(ni,nk,n_iceCat) :: diag_rhoi ! bulk density, ice kg m-3 (returned but not used)
1327 real, dimension(ni,nk) :: theta_m ! potential temperature (previous step) K
1328 real, dimension(ni,nk) :: qvapm ! qv (previous step) kg kg-1
1329 real, dimension(ni,nk) :: theta ! potential temperature K
1330 real, dimension(ni,nk) :: pres ! pressure Pa
1331 real, dimension(ni,nk) :: DZ ! difference in height between levels m
1332 real, dimension(ni,nk) :: ssat ! supersaturation
1333 real, dimension(ni,nk) :: tmparr_ik ! temporary array (for optimization)
1334 real, dimension(ni,nk) :: qqdelta,ttdelta ! for sub_stepping
1335 real, dimension(ni,nk) :: iwc ! total ice water content
1336 real, dimension(ni,nk) :: temp0, qvap0, qc0, qr0, iwc0 ! incoming state variables
1338 real, dimension(ni,nk,n_qiType) :: qi_type ! diagnostic precipitation types
1340 real, dimension(ni) :: prt_liq_ave,prt_sol_ave,rn1_ave,rn2_ave,sn1_ave, & ! ave pcp rates over full timestep
1341 sn2_ave,sn3_ave,pe1_ave,pe2_ave,snd_ave
1342 real :: dt_mp ! timestep used by microphsyics (for substepping)
1343 real :: tmp1, idt
1345 integer :: i,k,ktop,kbot,kdir,i_strt,k_strt,i_substep,n_substep,end_status,tmpint1
1347 logical :: log_tmp1,log_tmp2,log_trplMomI
1348 logical, parameter :: log_predictNc = .true. ! temporary; to be put as GEM namelist
1349 logical, parameter :: typeDiags_ON = .true. ! switch for hydrometeor/precip type diagnostics
1350 real, parameter :: SMALL_ICE_MASS = 1e-14 ! threshold for very small specific ice content
1352 character(len=16), parameter :: model = 'GEM'
1354 !----------------------------------------------------------------------------------------!
1356 end_status = STATUS_ERROR
1358 tmpint1 = trnch !not used; prevents "variable not used" compiler message
1360 i_strt = 1 ! beginning index of slab
1361 k_strt = 1 ! beginning index of column
1363 ktop = 1 ! k index of top level
1364 kbot = nk ! k index of bottom level
1365 kdir = -1 ! direction of vertical leveling for 1=bottom, nk=top
1367 log_trplMomI = present(zitot_1)
1369 !compute time step and number of steps for substepping
1370 idt = 1./dt
1371 n_substep = int((dt-0.1)/max(0.1,dt_max)) + 1
1372 dt_mp = dt/float(n_substep)
1374 ! Save initial state for tendency calculation and reset
1375 temp0(:,:) = temp(:,:)
1376 qvap0(:,:) = qvap(:,:)
1377 qc0(:,:) = qc(:,:)
1378 qr0(:,:) = qr(:,:)
1379 iwc0(:,:) = qitot_1(:,:)
1380 if (n_iceCat > 1) iwc0(:,:) = iwc0(:,:) + qitot_2(:,:)
1381 if (n_iceCat > 2) iwc0(:,:) = iwc0(:,:) + qitot_3(:,:)
1382 if (n_iceCat > 3) iwc0(:,:) = iwc0(:,:) + qitot_4(:,:)
1384 ! Note qqdelta is converted from specific to mixing ratio
1385 qqdelta = (qvap/(1-qvap)-qvap_m/(1-qvap_m)) / float(n_substep)
1386 ttdelta = (temp-temp_m) / float(n_substep)
1387 ! initialise for the 1st substepping
1388 qvap = qvap_m/(1-qvap_m) ! mixing ratio instead of specific humidity
1389 temp = temp_m
1391 !if (kount == 0) then
1392 if (.false.) then
1393 print*,'Microphysics (MP) substepping:'
1394 print*,' GEM model time step : ',dt
1395 print*,' MP time step : ',dt_mp
1396 print*,' number of MP substeps: ',n_substep
1397 endif
1399 ! note: code for prediction of ssat not currently avaiable, thus array is to 0
1400 ssat = 0.
1402 !air pressure:
1403 do k = kbot,ktop,kdir
1404 pres(:,k)= psfc(:)*sigma(:,k)
1405 enddo
1407 !layer thickness (for sedimentation):
1408 ! do k = kbot,ktop-kdir,kdir
1409 ! DZ(:,k) = gztherm(:,k+kdir) - gztherm(:,k)
1410 ! enddo
1411 ! DZ(:,ktop) = DZ(:,ktop-kdir)
1413 !layer thickness (for sedimentation):
1414 ! note: This is the thickness of the layer "centered" at thermodynamic level k,
1415 ! computed based on the surrounding momentum levels.
1416 do k = kbot-1,ktop,kdir
1417 DZ(:,k) = gzmom(:,k) - gzmom(:,k-kdir)
1418 enddo
1419 DZ(:,kbot) = gzmom(:,kbot)
1421 !compute zitot from advected 'Z' variable (for triple-moment ice):
1422 if (present(zitot_1)) then
1423 where (nitot_1>0.)
1424 zitot_1 = zitot_1**2/nitot_1
1425 elsewhere
1426 zitot_1 = 0.
1427 endwhere
1428 endif
1429 if (present(zitot_2)) then
1430 where (nitot_2>0.)
1431 zitot_2 = zitot_2**2/nitot_2
1432 elsewhere
1433 zitot_2 = 0.
1434 endwhere
1435 endif
1436 if (present(zitot_3)) then
1437 where (nitot_3>0.)
1438 zitot_3 = zitot_3**2/nitot_3
1439 elsewhere
1440 zitot_3 = 0.
1441 endwhere
1442 endif
1443 if (present(zitot_4)) then
1444 where (nitot_4>0.)
1445 zitot_4 = zitot_4**2/nitot_4
1446 elsewhere
1447 zitot_4 = 0.
1448 endwhere
1449 endif
1451 !contruct full ice arrays from individual category arrays:
1452 qitot(:,:,1) = qitot_1(:,:)
1453 qirim(:,:,1) = qirim_1(:,:)
1454 nitot(:,:,1) = nitot_1(:,:)
1455 birim(:,:,1) = birim_1(:,:)
1456 diag_effi(:,:,1) = diag_effi_1(:,:)
1457 if (present(zitot_1)) zitot(:,:,1) = zitot_1(:,:)
1459 if (n_iceCat >= 2) then
1460 qitot(:,:,2) = qitot_2(:,:)
1461 qirim(:,:,2) = qirim_2(:,:)
1462 nitot(:,:,2) = nitot_2(:,:)
1463 birim(:,:,2) = birim_2(:,:)
1464 diag_effi(:,:,2) = diag_effi_2(:,:)
1465 if (present(zitot_2)) zitot(:,:,2) = zitot_2(:,:)
1467 if (n_iceCat >= 3) then
1468 qitot(:,:,3) = qitot_3(:,:)
1469 qirim(:,:,3) = qirim_3(:,:)
1470 nitot(:,:,3) = nitot_3(:,:)
1471 birim(:,:,3) = birim_3(:,:)
1472 diag_effi(:,:,3) = diag_effi_3(:,:)
1473 if (present(zitot_3)) zitot(:,:,3) = zitot_3(:,:)
1475 if (n_iceCat == 4) then
1476 qitot(:,:,4) = qitot_4(:,:)
1477 qirim(:,:,4) = qirim_4(:,:)
1478 nitot(:,:,4) = nitot_4(:,:)
1479 birim(:,:,4) = birim_4(:,:)
1480 diag_effi(:,:,4) = diag_effi_4(:,:)
1481 if (present(zitot_4)) zitot(:,:,4) = zitot_4(:,:)
1482 endif
1483 endif
1484 endif
1486 !--- substepping microphysics
1487 if (n_substep > 1) then
1488 prt_liq_ave(:) = 0.
1489 prt_sol_ave(:) = 0.
1490 rn1_ave(:) = 0.
1491 rn2_ave(:) = 0.
1492 sn1_ave(:) = 0.
1493 sn2_ave(:) = 0.
1494 sn3_ave(:) = 0.
1495 pe1_ave(:) = 0.
1496 pe2_ave(:) = 0.
1497 snd_ave(:) = 0.
1498 endif
1500 tmparr_ik = (1.e+5/pres)**(rd*inv_cp) !for optimization of calc of theta, temp
1502 substep_loop: do i_substep = 1, n_substep
1504 !convert to potential temperature:
1505 qvapm = qvap
1506 qvap = qvap+qqdelta
1507 theta_m = temp*tmparr_ik
1508 temp = temp+ttdelta
1509 theta = temp*tmparr_ik
1511 if (log_trplMomI) then
1512 call p3_main(qc,nc,qr,nr,theta_m,theta,qvapm,qvap,dt_mp,qitot,qirim,nitot,birim, &
1513 ssat,ww,pres,DZ,kount,prt_liq,prt_sol,i_strt,ni,k_strt,nk,n_iceCat, &
1514 diag_Zet,diag_effc,diag_effi,diag_vmi,diag_di,diag_rhoi,n_diag_2d,diag_2d, &
1515 n_diag_3d,diag_3d,log_predictNc,typeDiags_ON,trim(model),clbfact_dep, &
1516 clbfact_sub,debug_on,scpf_on,scpf_pfrac,scpf_resfact,cldfrac,prt_drzl, &
1517 prt_rain,prt_crys,prt_snow,prt_grpl,prt_pell,prt_hail,prt_sndp,qi_type, &
1518 zitot = zitot, &
1519 diag_vis = diag_vis, &
1520 diag_vis1 = diag_vis1, &
1521 diag_vis2 = diag_vis2, &
1522 diag_vis3 = diag_vis3)
1523 else
1524 call p3_main(qc,nc,qr,nr,theta_m,theta,qvapm,qvap,dt_mp,qitot,qirim,nitot,birim, &
1525 ssat,ww,pres,DZ,kount,prt_liq,prt_sol,i_strt,ni,k_strt,nk,n_iceCat, &
1526 diag_Zet,diag_effc,diag_effi,diag_vmi,diag_di,diag_rhoi,n_diag_2d,diag_2d, &
1527 n_diag_3d,diag_3d,log_predictNc,typeDiags_ON,trim(model),clbfact_dep, &
1528 clbfact_sub,debug_on,scpf_on,scpf_pfrac,scpf_resfact,cldfrac,prt_drzl, &
1529 prt_rain,prt_crys,prt_snow,prt_grpl,prt_pell,prt_hail,prt_sndp,qi_type, &
1530 diag_vis = diag_vis, &
1531 diag_vis1 = diag_vis1, &
1532 diag_vis2 = diag_vis2, &
1533 diag_vis3 = diag_vis3)
1534 endif
1536 if (global_status /= STATUS_OK) return
1538 !convert back to temperature:
1539 temp = theta/tmparr_ik !i.e.: temp = theta*(pres*1.e-5)**(rd*inv_cp)
1541 if (n_substep > 1) then
1542 prt_liq_ave(:) = prt_liq_ave(:) + prt_liq(:)
1543 prt_sol_ave(:) = prt_sol_ave(:) + prt_sol(:)
1544 rn1_ave(:) = rn1_ave(:) + prt_drzl(:)
1545 rn2_ave(:) = rn2_ave(:) + prt_rain(:)
1546 sn1_ave(:) = sn1_ave(:) + prt_crys(:)
1547 sn2_ave(:) = sn2_ave(:) + prt_snow(:)
1548 sn3_ave(:) = sn3_ave(:) + prt_grpl(:)
1549 pe1_ave(:) = pe1_ave(:) + prt_pell(:)
1550 pe2_ave(:) = pe2_ave(:) + prt_hail(:)
1551 snd_ave(:) = snd_ave(:) + prt_sndp(:)
1552 endif
1554 enddo substep_loop
1556 ! retransferring mixing ratio to specific humidity (only t* is needed)
1557 qvap = qvap/(1+qvap)
1559 if (n_substep > 1) then
1560 tmp1 = 1./float(n_substep)
1561 prt_liq(:) = prt_liq_ave(:)*tmp1
1562 prt_sol(:) = prt_sol_ave(:)*tmp1
1563 prt_drzl(:) = rn1_ave(:)*tmp1
1564 prt_rain(:) = rn2_ave(:)*tmp1
1565 prt_crys(:) = sn1_ave(:)*tmp1
1566 prt_snow(:) = sn2_ave(:)*tmp1
1567 prt_grpl(:) = sn3_ave(:)*tmp1
1568 prt_pell(:) = pe1_ave(:)*tmp1
1569 prt_hail(:) = pe2_ave(:)*tmp1
1570 prt_sndp(:) = snd_ave(:)*tmp1
1571 endif
1573 !===
1576 !decompose full ice arrays back into individual category arrays:
1577 qitot_1(:,:) = qitot(:,:,1)
1578 qirim_1(:,:) = qirim(:,:,1)
1579 nitot_1(:,:) = nitot(:,:,1)
1580 birim_1(:,:) = birim(:,:,1)
1581 if (present(zitot_1)) zitot_1(:,:) = zitot(:,:,1)
1582 where (qitot_1(:,:) >= SMALL_ICE_MASS)
1583 diag_effi_1(:,:) = diag_effi(:,:,1)
1584 elsewhere
1585 diag_effi_1(:,:) = 0.
1586 endwhere
1588 if (n_iceCat >= 2) then
1589 qitot_2(:,:) = qitot(:,:,2)
1590 qirim_2(:,:) = qirim(:,:,2)
1591 nitot_2(:,:) = nitot(:,:,2)
1592 birim_2(:,:) = birim(:,:,2)
1593 if (present(zitot_2)) zitot_2(:,:) = zitot(:,:,2)
1594 where (qitot_2(:,:) >= SMALL_ICE_MASS)
1595 diag_effi_2(:,:) = diag_effi(:,:,2)
1596 elsewhere
1597 diag_effi_2(:,:) = 0.
1598 endwhere
1600 if (n_iceCat >= 3) then
1601 qitot_3(:,:) = qitot(:,:,3)
1602 qirim_3(:,:) = qirim(:,:,3)
1603 nitot_3(:,:) = nitot(:,:,3)
1604 birim_3(:,:) = birim(:,:,3)
1605 if (present(zitot_3)) zitot_3(:,:) = zitot(:,:,3)
1606 where (qitot_3(:,:) >= SMALL_ICE_MASS)
1607 diag_effi_3(:,:) = diag_effi(:,:,3)
1608 elsewhere
1609 diag_effi_3(:,:) = 0.
1610 endwhere
1612 if (n_iceCat == 4) then
1613 qitot_4(:,:) = qitot(:,:,4)
1614 qirim_4(:,:) = qirim(:,:,4)
1615 nitot_4(:,:) = nitot(:,:,4)
1616 birim_4(:,:) = birim(:,:,4)
1617 if (present(zitot_4)) zitot_4(:,:) = zitot(:,:,4)
1618 where (qitot_4(:,:) >= SMALL_ICE_MASS)
1619 diag_effi_4(:,:) = diag_effi(:,:,4)
1620 elsewhere
1621 diag_effi_4(:,:) = 0.
1622 endwhere
1623 endif
1624 endif
1625 endif
1627 !convert zitot to advected 'Z' variable:
1628 if (present(zitot_1)) zitot_1 = sqrt(nitot_1*zitot_1)
1629 if (present(zitot_2)) zitot_2 = sqrt(nitot_2*zitot_2)
1630 if (present(zitot_3)) zitot_3 = sqrt(nitot_3*zitot_3)
1631 if (present(zitot_4)) zitot_4 = sqrt(nitot_4*zitot_4)
1634 !convert precip rates from volume flux (m s-1) to mass flux (kg m-2 s-1):
1635 ! (since they are computed back to liq-eqv volume flux in s/r 'ccdiagnostics.F90')
1636 prt_liq = prt_liq*1000.
1637 prt_sol = prt_sol*1000.
1639 !--- diagnostics:
1640 diag_hcb(:) = -1.
1641 diag_hsn(:) = -1.
1643 do i = 1,ni
1645 !composite (column-maximum) reflectivity:
1646 diag_Zec(i) = maxval(diag_Zet(i,:))
1648 !diagnostic heights:
1649 log_tmp1 = .false. !cloud base height found
1650 log_tmp2 = .false. !snow level height found
1651 do k = nk,2,-1
1652 !cloud base height:
1653 if (qc(i,k)>1.e-6 .and. .not.log_tmp1) then
1654 diag_hcb(i) = gztherm(i,k)
1655 log_tmp1 = .true.
1656 endif
1657 !snow level height: (height of lowest level with ice) [for n_iceCat=1 only]
1658 if (qitot_1(i,k)>1.e-6 .and. .not.log_tmp2) then
1659 diag_hsn(i) = gztherm(i,k)
1660 log_tmp2 = .true.
1661 endif
1662 enddo
1664 !supercooled LWC:
1665 do k = 1,nk
1666 if (temp(i,k)<273.15) then
1667 tmp1 = pres(i,k)/(287.15*temp(i,k)) !air density
1668 diag_slw(i,k) = tmp1*(qc(i,k)+qr(i,k))
1669 else
1670 diag_slw(i,k) = 0.
1671 endif
1672 enddo
1674 enddo !i-loop
1676 ! Diagnostic ice particle types:
1677 if (n_qiType >= 6) then
1678 qi_type_1 = qi_type(:,:,1) !small ice crystals
1679 qi_type_2 = qi_type(:,:,2) !unrimed snow crystals
1680 qi_type_3 = qi_type(:,:,3) !lightly rimed snow
1681 qi_type_4 = qi_type(:,:,4) !graupel
1682 qi_type_5 = qi_type(:,:,5) !hail
1683 qi_type_6 = qi_type(:,:,6) !ice pellets
1684 else
1685 call physeterror('microphy_p3::mp_p3_wrapper_gem', &
1686 'Insufficient size for qi_type')
1687 return
1688 endif
1690 ! Compute tendencies and reset state
1691 iwc(:,:) = qitot_1(:,:)
1692 if (n_iceCat > 1) iwc(:,:) = iwc(:,:) + qitot_2(:,:)
1693 if (n_iceCat > 2) iwc(:,:) = iwc(:,:) + qitot_3(:,:)
1694 if (n_iceCat > 3) iwc(:,:) = iwc(:,:) + qitot_4(:,:)
1695 ttend(:,:) = (temp(:,:) - temp0(:,:)) * idt
1696 qtend(:,:) = (qvap(:,:) - qvap0(:,:)) * idt
1697 qctend(:,:) = (qc(:,:) - qc0(:,:)) * idt
1698 qrtend(:,:) = (qr(:,:) - qr0(:,:)) * idt
1699 qitend(:,:) = (iwc(:,:) - iwc0(:,:)) * idt
1700 temp(:,:) = temp0(:,:)
1701 qvap(:,:) = qvap0(:,:)
1702 qc(:,:) = qc0(:,:)
1703 qr(:,:) = qr0(:,:)
1705 end_status = STATUS_OK
1706 return
1708 end function mp_p3_wrapper_gem
1710 #endif
1712 !==========================================================================================!
1714 SUBROUTINE compute_SCPF(Qcond,Qprec,Qv,Qsi,Pres,ktop,kbot,kdir,SCF,iSCF,SPF,iSPF, &
1715 SPF_clr,Qv_cld,Qv_clr,cldFrac_on,pfrac,resfact,quick)
1717 !------------------------------------------------------------------------------------------!
1718 ! This subroutine computes the cloud and precipitation fractions. It also provide !
1719 ! in-cloud/clear sky water vapor mixing ratios and the inverse of "cloud" and !
1720 ! precipitation fractions to ease computation in s/r 'p3_main'. It is called 3 times: !
1721 ! !
1722 ! 1. Before microphysics source/sink terms and following updates of grid-mean fields !
1723 ! 2. Before sedimentation !
1724 ! 3. At the end of 'p3_main' (to provide cloud fraction to the driving model !
1725 ! (e.g. for the radiation scheme, diagnostics, etc.) !
1726 ! !
1727 ! For details see: Chosson et al. (2014) [J. Atmos. Sci., 71, 2635-2653] !
1728 ! !
1729 ! NOTES: !
1730 ! 'scpf_resfact' is the user-specified scaled horizontal grid spacing, which allows the !
1731 ! RH threshold to adapt to the model resolution (i.e. to be "scale aware"). !
1732 ! The current recommendation is: scpf_resfact = sqrt(dx/dx_ref). where dx_ref = 12 km !
1733 ! !
1734 !------------------------------------------------------------------------------------------!
1735 ! Version 1: April 2016, Frederick Chosson (ECCC) !
1736 ! This version is not "scale aware" and RHcrit is from Sundqvist RDPS !
1737 ! but without dependency on T (RHcriterion -RHoo- cst in free atm.) !
1738 ! This version have a very low optimisation level !
1739 ! !
1740 ! Version 2: November 2016, Frederick Chosson (ECCC) !
1741 ! add minimum Cloud and Precipitation Fraction to 1% !
1742 ! add maximum Cloud and Precipitation Fraction to 99% !
1743 ! !
1744 ! Version 3: June 2018, Caroline Jouan (ECCC) !
1745 ! Tests in GEM models !
1746 ! !
1747 !------------------------------------------------------------------------------------------!
1749 implicit none
1751 !----- input/ouput arguments: ----------------------------------------------------------!
1752 real, intent(in), dimension(:) :: Qcond ! Condensates mix.ratio that goes in the "Cloudy fraction"
1753 real, intent(in), dimension(:) :: Qprec ! Condensates mix.ratio that goes in the "Precip fraction"
1754 real, intent(in), dimension(:) :: Qv ! Water vapor mix.ratio (grid mean)
1755 real, intent(in), dimension(:) :: Qsi ! Saturation Water vapor mix.ratio w.r.t. ice or liq, dep. on T
1756 real, intent(in), dimension(:) :: pres ! pressure in Pa
1757 real, intent(out), dimension(:) :: SCF,iSCF ! Subgrid "Cloudy" fraction (fraction where RH>100%) and inverse
1758 real, intent(out), dimension(:) :: SPF,iSPF ! Subgrid "Precip" fraction and inverse
1759 real, intent(out), dimension(:) :: SPF_clr ! Subgrid "Precip" fraction in clear sky (not overlap cloud)
1760 real, intent(out), dimension(:) :: Qv_cld ! Water vapor mix.ratio in "Cloudy" fraction
1761 real, intent(out), dimension(:) :: Qv_clr ! Water vapor mix.ratio NOT in "Cloudy" fraction
1762 real, intent(in) :: pfrac ! precipitation fraction factor
1763 real, intent(in) :: resfact ! model resolution factor
1764 integer, intent(in) :: ktop,kbot ! indices of model top and bottom
1765 integer, intent(in) :: kdir ! indice for direction from bottom to top
1766 logical, intent(in) :: quick ! switch if you only need SCF as output, not the rest (3rd call)
1767 logical, intent(in) :: cldFrac_on! switch if you only need SCF or set it to 1.
1770 !----- local variables and parameters: --------------------------------------------------!
1771 real, dimension(size(Qv,dim=1)) :: C ! Total cloud cover form top to level k
1772 real, parameter :: SIG_min = 0.7 ! minimum of sigma level below wich RHoo start to increase
1773 real, parameter :: SIG_max = 0.9 ! maximum of sigma level below wich RHoo stop to increase
1774 real, parameter :: xo = 1.-1.e-6 ! a number very close but less than 1.
1775 real :: RHoo_min ! minimum of relative humidity criterion for dx around 12km
1776 real :: RHoo_max ! maximum of relative humidity criterion for dx around 12km
1777 real :: slope ! scale factor=(RHoo_max-RHoo_min)/(SIG_min-SIG_max)
1778 real :: RHoo ! Relative humidity criterion above which saturation appears
1779 real :: Qtot,DELTA_Qtot ! Total "cloudy" condensate and the half-width of its PDF
1780 real :: D_A_cld2clr ! Area of cloudy precips. that fall in clear air below
1781 real :: D_A_clr2cld ! Area of clear air precips that fall into cloud below
1782 real :: D_C ! Area never concerned by precips from top to level k
1783 real :: SPF_cld ! area of cloudy precips at level k
1784 real :: SPF_cld_k_1 ! area of cloudy precips at level k+kdir (just above)
1785 real :: sigma ! sigma level = P / Psurf with Psurf=P(:,kbot)
1786 real :: tmp7 ! temporary SPF
1787 integer :: k ! vertical loop index
1789 compute_cloud_fraction: if (cldFrac_on) then
1791 ! initialise constants
1792 RHoo_min = 1.-(1.-0.85 )*resfact ! minimum of relative humidity criterion for dx ~ 12 km by default
1793 RHoo_max = 1.-(1.-0.975)*resfact ! maximum of relative humidity criterion for dx ~ 12 km
1794 slope = (RHoo_max-RHoo_min)/(SIG_max-SIG_min)
1796 ! Initiate Cloud fractions overlaps to zero
1797 SCF(:) = 0.; iSCF(:) = 0.; D_A_cld2clr = 0.
1798 D_A_clr2cld = 0.; C(:) = 0.; D_C = 0.
1799 SPF_cld = 0.; SPF_clr(:) = 0.; SPF(:) = 0.
1800 iSPF(:) = 0.; Qv_cld(:) = 0.; Qv_clr(:) = 0.
1801 SPF_cld_k_1 = 0.
1803 Loop_SCPF_k: do k = ktop-kdir,kbot,-kdir
1805 sigma = pres(k)/pres(kbot) ! sigma level
1806 RHoo = RHoo_min + slope*(sigma-SIG_min ) ! critical relative humidity
1807 RHoo = max( RHoo_min, min( RHoo_max, RHoo ) ) ! bounded
1809 !------------------------------------------------------------
1810 ! COMPUTE CLOUD FRACTION AND in-FRACTIONS WATER VAPOR CONTENT
1811 !------------------------------------------------------------
1812 Qtot = Qv(k)+Qcond(k) ! Total "Cloudy" mean water mixing ratio
1813 DELTA_Qtot = Qsi(k)*(1.-RHoo) ! half-width of Qtot subgrid PDF
1814 SCF(k) = 0.5*(Qtot+DELTA_Qtot-QSI(k))/DELTA_Qtot ! subgrid cloud fraction
1816 if (SCF(k) .lt. 0.01 ) then ! minimum allowed Cloud fraction (below it is clear-sky)
1817 SCF(k) = 0. ! inverse of Cloud cover
1818 iSCF(k) = 0. ! inverse of Cloud cover
1819 Qv_cld(k) = 0. ! water vapour mix. ratio in Cloudy part
1820 Qv_clr(k) = Qv(k) ! water vapour mix. ratio in Clear sky part
1821 elseif (SCF(k) .lt. 0.99 ) then
1822 iSCF(k) = 1./SCF(k) ! beware: Could be big!
1823 Qv_cld(k) = 0.5*(Qtot+DELTA_Qtot+QSI(k))-Qcond(k)*iSCF(k)
1824 Qv_clr(k) = 0.5*(Qtot-DELTA_Qtot+QSI(k))
1825 else ! if SCF >= 0.99
1826 SCF(k) = 1.
1827 iSCF(k) = 1.
1828 Qv_cld(k) = Qv(k)
1829 Qv_clr(k) = 0.
1830 endif
1832 !------------------------------------------------------------
1833 ! COMPUTE CLOUD AND PRECIPITATION FRACTIONS OVERLAPS
1834 !------------------------------------------------------------
1835 if (.not. quick) then
1837 ! This is the total max-random cloud-cover from top to level k
1838 C(k) = 1.-(1.-C(k+kdir))*(1.-max(SCF(k),SCF(k+kdir)))/(1.-min(SCF(k+kdir),xo))
1839 ! Change in total cloud-cover: this part is never concerned by precips
1840 D_C = C(k)-C(k+kdir)
1841 ! Cloudy precipitation fraction at level k+kdir (level above)
1842 SPF_cld_k_1 = SPF(k+kdir)-SPF_clr(k+kdir)
1843 ! fraction for which cloudy precip. falls into clear air below
1844 D_A_cld2clr = SPF_cld_k_1 - min(SCF(k)-D_C,SPF_cld_k_1)
1845 ! fraction for which clear-sky precip. falls into cloudy air below
1846 D_A_clr2cld = max(0., min(SPF_clr(k+kdir),SCF(k)-D_C-SCF(k+kdir)) )
1847 ! fraction of cloudy precips at level k
1848 SPF_cld = SPF_cld_k_1 + D_A_clr2cld - D_A_cld2clr
1849 if (SPF_cld .le. 0.) SPF_cld=SCF(k)*Pfrac
1850 ! fraction of clear-sky precips at level k
1851 SPF_clr(k) = SPF_clr(k+kdir) - D_A_clr2cld + D_A_cld2clr
1852 ! if there is no precips set precips areas to zero
1853 tmp7 = (SPF_clr(k)+SPF_cld)
1855 if (tmp7.gt.0.) then
1856 if ((Qprec(k)/tmp7<qsmall ) .or. (Qprec(k+kdir)*iSPF(k+kdir)<qsmall)) then
1857 SPF_cld = SCF(k+kdir)*Pfrac
1858 SPF_clr(k) = 0.
1859 endif
1860 endif
1862 SPF(k) = (SPF_clr(k) + SPF_cld) ! subgrid area of precipitation
1863 if (SPF(k) .ge. 0.01) then
1864 iSPF(k)= 1. / SPF(k) ! inverse of precip fraction
1865 else
1866 if (Qprec(k) .ge. qsmall) then
1867 SPF(k) = max(0.01, SCF(k+kdir)) ! in case of slant-wise rain precipitating
1868 SPF_clr(k) = SPF(k) ! assume at least 1% SPF in clear-sky
1869 iSPF(k) = 1./SPF(k)
1870 else
1871 iSPF(k) = 0.
1872 SPF(k) = 0.
1873 SPF_clr(k) = 0.
1874 endif
1875 endif
1877 endif ! end of IF NOT quick
1879 if ((SCF(k) .lt. 0.01) .and. (Qcond(k) > qsmall) ) then ! avoid bad clipping
1880 SCF(k) = max(0.01, SCF(k+kdir)) ! in case of cloudy species precipitating
1881 iSCF(k) = 1./SCF(k) ! into unsaturated layer
1882 Qv_cld(k) = Qv(k)
1883 Qv_clr(k) = Qv(k)
1884 SPF_clr(k) = max(SPF(k)-SCF(k),0.)
1885 endif
1887 enddo Loop_SCPF_k
1889 else ! compute_cloud_fraction
1891 SCF = 1.
1892 iSCF = 1.
1893 SPF = 1.
1894 iSPF = 1.
1895 SPF_clr = 0.
1896 Qv_cld = Qv
1897 Qv_clr = 0.
1899 endif compute_cloud_fraction
1901 END SUBROUTINE compute_SCPF
1903 !==========================================================================================!
1905 SUBROUTINE p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,nitot,birim,ssat,uzpl, &
1906 pres,dzq,it,prt_liq,prt_sol,its,ite,kts,kte,nCat,diag_ze,diag_effc, &
1907 diag_effi,diag_vmi,diag_di,diag_rhoi,n_diag_2d,diag_2d,n_diag_3d, &
1908 diag_3d,log_predictNc,typeDiags_ON,model,clbfact_dep,clbfact_sub, &
1909 debug_on,scpf_on,scpf_pfrac,scpf_resfact,SCF_out,prt_drzl,prt_rain, &
1910 prt_crys,prt_snow,prt_grpl,prt_pell,prt_hail,prt_sndp,qi_type, &
1911 zitot,diag_vis,diag_vis1,diag_vis2,diag_vis3,diag_dhmax,diag_lami, &
1912 diag_mui)
1914 !----------------------------------------------------------------------------------------!
1915 ! !
1916 ! This is the main subroutine for the P3 microphysics scheme. It is called from the !
1917 ! wrapper subroutine ('MP_P3_WRAPPER') and is passed i,k slabs of all prognostic !
1918 ! variables -- hydrometeor fields, potential temperature, and water vapor mixing ratio. !
1919 ! Microphysical process rates are computed first. These tendencies are then used to !
1920 ! computed updated values of the prognostic variables. The hydrometeor variables are !
1921 ! then updated further due to sedimentation. !
1922 ! !
1923 ! Several diagnostic values are also computed and returned to the wrapper subroutine, !
1924 ! including precipitation rates. !
1925 ! !
1926 !----------------------------------------------------------------------------------------!
1928 implicit none
1930 !----- Input/ouput arguments: ----------------------------------------------------------!
1932 integer, intent(in) :: its,ite ! array bounds (horizontal)
1933 integer, intent(in) :: kts,kte ! array bounds (vertical)
1934 integer, intent(in) :: nCat ! number of ice-phase categories
1935 integer, intent(in) :: n_diag_2d ! number of 2D diagnostic fields
1936 integer, intent(in) :: n_diag_3d ! number of 3D diagnostic fields
1938 real, intent(inout), dimension(its:ite,kts:kte) :: qc ! cloud, mass mixing ratio kg kg-1
1939 ! note: Nc may be specified or predicted (set by log_predictNc)
1940 real, intent(inout), dimension(its:ite,kts:kte) :: nc ! cloud, number mixing ratio # kg-1
1941 real, intent(inout), dimension(its:ite,kts:kte) :: qr ! rain, mass mixing ratio kg kg-1
1942 real, intent(inout), dimension(its:ite,kts:kte) :: nr ! rain, number mixing ratio # kg-1
1943 real, intent(inout), dimension(its:ite,kts:kte,nCat) :: qitot ! ice, total mass mixing ratio kg kg-1
1944 real, intent(inout), dimension(its:ite,kts:kte,nCat) :: qirim ! ice, rime mass mixing ratio kg kg-1
1945 real, intent(inout), dimension(its:ite,kts:kte,nCat) :: nitot ! ice, total number mixing ratio # kg-1
1946 real, intent(inout), dimension(its:ite,kts:kte,nCat) :: birim ! ice, rime volume mixing ratio m3 kg-1
1948 real, intent(inout), dimension(its:ite,kts:kte) :: ssat ! supersaturation (i.e., qv-qvs) kg kg-1
1949 real, intent(inout), dimension(its:ite,kts:kte) :: qv ! water vapor mixing ratio kg kg-1
1950 real, intent(inout), dimension(its:ite,kts:kte) :: th ! potential temperature K
1951 real, intent(inout), dimension(its:ite,kts:kte) :: th_old ! beginning of time step value of theta K
1952 real, intent(inout), dimension(its:ite,kts:kte) :: qv_old ! beginning of time step value of qv kg kg-1
1953 real, intent(in), dimension(its:ite,kts:kte) :: uzpl ! vertical air velocity m s-1
1954 real, intent(in), dimension(its:ite,kts:kte) :: pres ! pressure Pa
1955 real, intent(in), dimension(its:ite,kts:kte) :: dzq ! vertical grid spacing m
1956 real, intent(in) :: dt ! model time step s
1957 real, intent(in) :: clbfact_dep! calibration factor for deposition
1958 real, intent(in) :: clbfact_sub! calibration factor for sublimation
1960 real, intent(out), dimension(its:ite) :: prt_liq ! precipitation rate, liquid m s-1
1961 real, intent(out), dimension(its:ite) :: prt_sol ! precipitation rate, solid m s-1
1962 real, intent(out), dimension(its:ite,kts:kte) :: diag_ze ! equivalent reflectivity dBZ
1963 real, intent(out), dimension(its:ite,kts:kte) :: diag_effc ! effective radius, cloud m
1964 real, intent(out), dimension(its:ite,kts:kte,nCat) :: diag_effi ! effective radius, ice m
1965 real, intent(out), dimension(its:ite,kts:kte,nCat) :: diag_vmi ! mass-weighted fall speed of ice m s-1
1966 real, intent(out), dimension(its:ite,kts:kte,nCat) :: diag_di ! mean diameter of ice m
1967 real, intent(out), dimension(its:ite,kts:kte,nCat) :: diag_rhoi ! bulk density of ice kg m-1
1968 real, intent(out), dimension(its:ite,kts:kte,nCat), optional :: diag_dhmax ! maximum hail size m
1969 real, intent(out), dimension(its:ite,kts:kte,nCat), optional :: diag_lami ! lambda parameter for ice PSD m-1
1970 real, intent(out), dimension(its:ite,kts:kte,nCat), optional :: diag_mui ! mu parameter for ice PSD
1972 !! real, intent(out), dimension(its:ite,kts:kte,nCat), optional :: diag_Dhm ! maximum hail diameter m
1973 real, intent(out), dimension(its:ite,kts:kte), optional :: diag_vis ! visibility (total) m
1974 real, intent(out), dimension(its:ite,kts:kte), optional :: diag_vis1 ! visibility through fog m
1975 real, intent(out), dimension(its:ite,kts:kte), optional :: diag_vis2 ! visibility through rain m
1976 real, intent(out), dimension(its:ite,kts:kte), optional :: diag_vis3 ! visibility through snow m
1977 real, intent(out), dimension(its:ite,n_diag_2d) :: diag_2d ! user-defined 2D diagnostic fields
1978 real, intent(out), dimension(its:ite,kts:kte,n_diag_3d) :: diag_3d ! user-defined 3D diagnostic fields
1980 integer, intent(in) :: it ! time step counter NOTE: starts at 1 for first time step
1982 logical, intent(in) :: log_predictNc ! .T. (.F.) for prediction (specification) of Nc
1983 logical, intent(in) :: typeDiags_ON !for diagnostic hydrometeor/precip rate types
1984 logical, intent(in) :: debug_on !switch for internal debug checks
1985 character(len=*), intent(in) :: model !driving model
1987 real, intent(out), dimension(its:ite), optional :: prt_drzl ! precip rate, drizzle m s-1
1988 real, intent(out), dimension(its:ite), optional :: prt_rain ! precip rate, rain m s-1
1989 real, intent(out), dimension(its:ite), optional :: prt_crys ! precip rate, ice cystals m s-1
1990 real, intent(out), dimension(its:ite), optional :: prt_snow ! precip rate, snow m s-1
1991 real, intent(out), dimension(its:ite), optional :: prt_grpl ! precip rate, graupel m s-1
1992 real, intent(out), dimension(its:ite), optional :: prt_pell ! precip rate, ice pellets m s-1
1993 real, intent(out), dimension(its:ite), optional :: prt_hail ! precip rate, hail m s-1
1994 real, intent(out), dimension(its:ite), optional :: prt_sndp ! precip rate, unmelted snow m s-1
1996 real, intent(out), dimension(its:ite,kts:kte,n_qiType), optional :: qi_type ! mass mixing ratio, diagnosed ice type kg kg-1
1997 real, intent(inout), dimension(its:ite,kts:kte,nCat), optional :: zitot ! ice, reflectivity mixing ratio kg2 kg-1
1999 logical, intent(in) :: scpf_on ! Switch to activate SCPF
2000 real, intent(in) :: scpf_pfrac ! precipitation fraction factor (SCPF)
2001 real, intent(in) :: scpf_resfact ! model resolution factor (SCPF)
2002 real, intent(out), dimension(its:ite,kts:kte) :: SCF_out ! cloud fraction from SCPF
2004 !----- Local variables and parameters: -------------------------------------------------!
2006 real, dimension(its:ite,kts:kte) :: mu_r ! shape parameter of rain
2007 real, dimension(its:ite,kts:kte) :: t ! temperature at the beginning of the microhpysics step [K]
2008 real, dimension(its:ite,kts:kte) :: t_old ! temperature at the beginning of the model time step [K]
2010 ! 2D size distribution and fallspeed parameters:
2012 real, dimension(its:ite,kts:kte) :: lamc
2013 real, dimension(its:ite,kts:kte) :: lamr
2014 real, dimension(its:ite,kts:kte) :: logn0r
2015 real, dimension(its:ite,kts:kte) :: mu_c
2016 !real, dimension(its:ite,kts:kte) :: diag_effr (currently not used)
2017 real, dimension(its:ite,kts:kte) :: nu
2018 real, dimension(its:ite,kts:kte) :: cdist
2019 real, dimension(its:ite,kts:kte) :: cdist1
2020 real, dimension(its:ite,kts:kte) :: cdistr
2021 real, dimension(its:ite,kts:kte) :: Vt_qc
2023 ! liquid-phase microphysical process rates:
2024 ! (all Q process rates in kg kg-1 s-1)
2025 ! (all N process rates in # kg-1)
2027 real :: qrcon ! rain condensation
2028 real :: qcacc ! cloud droplet accretion by rain
2029 real :: qcaut ! cloud droplet autoconversion to rain
2030 real :: ncacc ! change in cloud droplet number from accretion by rain
2031 real :: ncautc ! change in cloud droplet number from autoconversion
2032 real :: ncslf ! change in cloud droplet number from self-collection
2033 real :: nrslf ! change in rain number from self-collection
2034 real :: ncnuc ! change in cloud droplet number from activation of CCN
2035 real :: qccon ! cloud droplet condensation
2036 real :: qcnuc ! activation of cloud droplets from CCN
2037 real :: qrevp ! rain evaporation
2038 real :: qcevp ! cloud droplet evaporation
2039 real :: nrevp ! change in rain number from evaporation
2040 real :: ncautr ! change in rain number from autoconversion of cloud water
2042 ! ice-phase microphysical process rates:
2043 ! (all Q process rates in kg kg-1 s-1)
2044 ! (all N process rates in # kg-1)
2046 real, dimension(nCat) :: qccol ! collection of cloud water by ice
2047 real, dimension(nCat) :: qwgrth ! wet growth rate
2048 real, dimension(nCat) :: qidep ! vapor deposition
2049 real, dimension(nCat) :: qrcol ! collection rain mass by ice
2050 real, dimension(nCat) :: qinuc ! deposition/condensation freezing nuc
2051 real, dimension(nCat) :: nccol ! change in cloud droplet number from collection by ice
2052 real, dimension(nCat) :: nrcol ! change in rain number from collection by ice
2053 real, dimension(nCat) :: ninuc ! change in ice number from deposition/cond-freezing nucleation
2054 real, dimension(nCat) :: qisub ! sublimation of ice
2055 real, dimension(nCat) :: qimlt ! melting of ice
2056 real, dimension(nCat) :: nimlt ! melting of ice
2057 real, dimension(nCat) :: nisub ! change in ice number from sublimation
2058 real, dimension(nCat) :: nislf ! change in ice number from collection within a category
2059 real, dimension(nCat) :: qchetc ! contact freezing droplets
2060 real, dimension(nCat) :: qcheti ! immersion freezing droplets
2061 real, dimension(nCat) :: qrhetc ! contact freezing rain
2062 real, dimension(nCat) :: qrheti ! immersion freezing rain
2063 real, dimension(nCat) :: nchetc ! contact freezing droplets
2064 real, dimension(nCat) :: ncheti ! immersion freezing droplets
2065 real, dimension(nCat) :: nrhetc ! contact freezing rain
2066 real, dimension(nCat) :: nrheti ! immersion freezing rain
2067 real, dimension(nCat) :: nrshdr ! source for rain number from collision of rain/ice above freezing and shedding
2068 real, dimension(nCat) :: qcshd ! source for rain mass due to cloud water/ice collision above freezing and shedding or wet growth and shedding
2069 real, dimension(nCat) :: qrmul ! change in q, ice multiplication from rime-splitnering of rain (not included in the paper)
2070 real, dimension(nCat) :: nimul ! change in Ni, ice multiplication from rime-splintering (not included in the paper)
2071 real, dimension(nCat) :: ncshdc ! source for rain number due to cloud water/ice collision above freezing and shedding (combined with NRSHD in the paper)
2072 real, dimension(nCat) :: rhorime_c ! density of rime (from cloud)
2074 real, dimension(nCat,nCat) :: nicol ! change of N due to ice-ice collision between categories
2075 real, dimension(nCat,nCat) :: qicol ! change of q due to ice-ice collision between categories
2077 logical, dimension(nCat) :: log_wetgrowth
2079 real, dimension(nCat) :: Eii_fact,epsi
2080 real :: eii ! temperature dependent aggregation efficiency
2082 real, dimension(its:ite,kts:kte,nCat) :: diam_ice,rimefraction,rimevolume
2084 real, dimension(its:ite,kts:kte) :: inv_dzq,inv_rho,ze_ice,ze_rain,prec,acn,rho, &
2085 rhofacr,rhofaci,xxls,xxlv,xlf,qvs,qvi,sup,supi,vtrmi1,tmparr1,mflux_r, &
2086 mflux_i,invexn
2088 real, dimension(kts:kte) :: V_qr,V_qit,V_nit,V_nr,V_qc,V_nc,V_zit,flux_qit,flux_qx, &
2089 flux_nx,flux_nit,flux_qir,flux_bir,flux_zit
2091 real, dimension(kts:kte) :: SCF,iSCF,SPF,iSPF,SPF_clr,Qv_cld,Qv_clr
2092 real :: ssat_cld,ssat_clr,ssat_r,supi_cld,sup_cld,sup_r
2094 real :: lammax,lammin,mu,dv,sc,dqsdT,ab,kap,epsr,epsc,xx,aaa,epsilon,sigvl,epsi_tot, &
2095 aact,sm1,sm2,uu1,uu2,dum,dum1,dum2,dumqv,dumqvs,dums,ratio,qsat0,dum3,dum4, &
2096 dum5,dum6,rdumii,rdumjj,dqsidT,abi,dumqvi,rhop,v_impact,ri,iTc,D_c,tmp1, &
2097 tmp2,inv_dum3,odt,oxx,oabi,fluxdiv_qit,fluxdiv_nit,fluxdiv_qir,fluxdiv_bir, &
2098 prt_accum,fluxdiv_qx,fluxdiv_nx,Co_max,dt_sub,fluxdiv_zit,D_new,Q_nuc,N_nuc, &
2099 deltaD_init,dum1c,dum4c,dum5c,dumt,qcon_satadj,qdep_satadj,sources,sinks, &
2100 timeScaleFactor,dt_left,qv_tmp,t_tmp,dum1z
2102 double precision :: tmpdbl1,tmpdbl2,tmpdbl3
2104 integer :: dumi,i,k,ii,iice,iice_dest,dumj,dumii,dumjj,dumzz,tmpint1,ktop,kbot,kdir, &
2105 dumic,dumiic,dumjjc,catcoll,k_qxbot,k_qxtop,k_temp
2107 logical :: log_nucleationPossible,log_hydrometeorsPresent,log_predictSsat, &
2108 log_exitlevel,log_hmossopOn,log_qxpresent,log_3momentIce
2110 ! quantities related to process rates/parameters, interpolated from lookup tables:
2112 real :: f1pr01 ! number-weighted fallspeed
2113 real :: f1pr02 ! mass-weighted fallspeed
2114 real :: f1pr03 ! ice collection within a category
2115 real :: f1pr04 ! collection of cloud water by ice
2116 real :: f1pr05 ! melting
2117 real :: f1pr06 ! effective radius
2118 real :: f1pr07 ! collection of rain number by ice
2119 real :: f1pr08 ! collection of rain mass by ice
2120 real :: f1pr09 ! inverse normalized qsmall (for lambda limiter)
2121 real :: f1pr10 ! inverse normalized qlarge (for lambda limiter)
2122 !real :: f1pr11 ! not used
2123 !real :: f1pr12 ! not used
2124 real :: f1pr13 ! reflectivity
2125 real :: f1pr14 ! melting (ventilation term)
2126 real :: f1pr15 ! mass-weighted mean diameter
2127 real :: f1pr16 ! mass-weighted mean particle density
2128 real :: f1pr17 ! ice-ice category collection change in number
2129 real :: f1pr18 ! ice-ice category collection change in mass
2130 real :: f1pr19 ! reflectivity-weighted fallspeed
2131 !real :: f1pr20 ! not used
2132 !real :: f1pr21 ! not used
2133 real :: f1pr22 ! LAMBDA_i (PSD parameter of ice, cat 1)
2134 real :: f1pr23 ! MU_i (PSD parameter of ice, cat 1)
2136 ! quantities related to diagnostic hydrometeor/precipitation types
2137 real, parameter :: freq3DtypeDiag = 1. !frequency (min) for full-column diagnostics
2138 real, parameter :: thres_raindrop = 100.e-6 !size threshold for drizzle vs. rain
2139 real, dimension(its:ite,kts:kte) :: Q_drizzle,Q_rain
2140 real, dimension(its:ite,kts:kte,nCat) :: Q_crystals,Q_ursnow,Q_lrsnow,Q_grpl,Q_pellets,Q_hail
2141 integer :: ktop_typeDiag
2143 ! to be added as namelist parameters (future)
2144 logical, parameter :: debug_ABORT = .true. !.true. will result in forced abort in s/r 'check_values'
2145 logical :: force_abort
2146 integer :: location_ind !return value of location index from sr/ 'check_values'
2148 ! added for triple moment ice
2149 real :: mu_i !shape parameter for ice
2150 real :: mu_i_new !shape parameter for processes that specify mu_i
2151 real, dimension(nCat) :: dumm0,dumm3
2153 ! add integers for mu_i index
2154 integer :: imu
2155 integer, parameter :: niter_mui = 5 ! number of iterations for find mu for lookup table
2157 !-----------------------------------------------------------------------------------!
2158 ! End of variables/parameters declarations
2159 !-----------------------------------------------------------------------------------!
2161 !-----------------------------------------------------------------------------------!
2162 ! Note, the array 'diag_3d(ni,nk,n_diag_3d)' provides a placeholder to output 3D diagnostic fields.
2163 ! The entire array array is inialized to zero (below). Code can be added to store desired fields
2164 ! by simply adding the appropriate assignment statements. For example, if one wishs to output the
2165 ! rain condensation and evaporation rates, simply add assignments in the appropriate locations.
2166 ! e.g.:
2167 !
2168 ! diag_3d(i,k,1) = qrcon
2169 ! diag_3d(i,k,2) = qrevp
2170 !
2171 ! The fields will automatically be passed to the driving model. In GEM, these arrays can be
2172 ! output by adding 'SS01' and 'SS02' to the model output list.
2173 !
2174 ! Similarly, 'diag_2d(ni,n_diag_2d) is a placeholder to output 2D diagnostic fields.
2175 ! e.g.:
2176 !
2177 ! diag_2d(i,1) = maxval(qr(i,:)) !column-maximum qr
2178 !-----------------------------------------------------------------------------------!
2180 !-----------------------------------------------------------------------------------!
2181 ! The following code blocks can be instered for debugging (all within the main i-loop):
2182 !
2183 ! !-- call to s/r 'check_values' WITHIN k loops:
2184 ! if (debug_on) then
2185 ! tmparr1(i,k) = th(i,k)*(pres(i,k)*1.e-5)**(rd*inv_cp)
2186 ! call check_values(qv(i,k:k),tmparr1(i,k:k),qc(i,k:k),nc(i,k:k),qr(i,k:k),nr(i,k:k), &
2187 ! qitot(i,k:k,:),qirim(i,k:k,:),nitot(i,k:k,:),birim(i,k:k,:),zitot(i,k:k,:),i,it,debug_ABORT,555)
2188 ! if (global_status /= STATUS_OK) return
2189 ! endif
2190 ! !==
2191 !
2192 ! !-- call to s/r 'check_values' OUTSIDE k loops:
2193 ! if (debug_on) then
2194 ! tmparr1(i,:) = th(i,:)*(pres(i,:)*1.e-5)**(rd*inv_cp)
2195 ! call check_values(qv(i,:),tmparr1(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
2196 ! qirim(i,:,:),nitot(i,:,:),birim(i,:,:),zitot(i,:,:),i,it,debug_ABORT,666)
2197 ! if (global_status /= STATUS_OK) return
2198 ! endif
2199 ! !==
2200 !-----------------------------------------------------------------------------------!
2202 ! call cpu_time(t_p3main_start)
2204 tmp1 = uzpl(1,1) !avoids compiler warning for unused variable 'uzpl'
2206 ! direction of vertical leveling:
2207 if (trim(model)=='GEM' .or. trim(model)=='KIN1D') then
2208 ktop = kts !k of top level
2209 kbot = kte !k of bottom level
2210 kdir = -1 !(k: 1=top, nk=bottom)
2211 else
2212 ktop = kte !k of top level
2213 kbot = kts !k of bottom level
2214 kdir = 1 !(k: 1=bottom, nk=top)
2215 endif
2217 if (trim(model)=='GEM') then
2218 if (.not. typeDiags_ON) then
2219 !If typeDiags_ON is .false., uninitialized arrays (prt_drzl, qi_type, etc.) will be passed back.
2220 !(The coding of this will be refined later)
2221 print*, '*** ERROR in P3_MAIN ***'
2222 print*, '* typeDiags_ON must be set to .TRUE. for GEM'
2223 global_status = STATUS_ERROR
2224 return
2225 endif
2226 endif
2229 ! Determine threshold size difference [m] as a function of nCat
2230 ! (used for destination category upon ice initiation)
2231 ! note -- this code could be moved to 'p3_init'
2232 select case (nCat)
2233 case (1)
2234 deltaD_init = 999. !not used if n_iceCat=1 (but should be defined)
2235 case (2)
2236 deltaD_init = 500.e-6
2237 case (3)
2238 deltaD_init = 400.e-6
2239 case (4)
2240 deltaD_init = 235.e-6
2241 case (5)
2242 deltaD_init = 175.e-6
2243 case (6:)
2244 deltaD_init = 150.e-6
2245 end select
2247 ! deltaD_init = 250.e-6 !for testing
2248 ! deltaD_init = dummy_in !temporary; passed in from cld1d
2250 ! Note: Code for prediction of supersaturation is available in current version.
2251 ! In the future 'log_predictSsat' will be a user-defined namelist key.
2252 log_predictSsat = .false.
2254 log_3momentIce = present(zitot)
2256 log_hmossopOn = (nCat.gt.1) !default: off for nCat=1, off for nCat>1
2257 !log_hmossopOn = .true. !switch to have Hallet-Mossop ON
2258 !log_hmossopOn = .false. !switch to have Hallet-Mossop OFF
2260 inv_dzq = 1./dzq ! inverse of thickness of layers
2261 odt = 1./dt ! inverse model time step
2263 ! Compute time scale factor over which to apply soft rain lambda limiter
2264 ! note: '1./max(30.,dt)' = '1.*min(1./30., 1./dt)'
2265 timeScaleFactor = min(1./120., odt)
2267 prt_liq = 0.
2268 prt_sol = 0.
2269 mflux_r = 0.
2270 mflux_i = 0.
2271 prec = 0.
2272 mu_r = 0.
2273 diag_ze = -99.
2274 diam_ice = 0.
2275 rimefraction = 0.
2276 rimevolume = 0.
2277 ze_ice = 1.e-22
2278 ze_rain = 1.e-22
2279 diag_effc = 10.e-6 ! default value
2280 !diag_effr = 25.e-6 ! default value
2281 diag_effi = 25.e-6 ! default value
2282 diag_vmi = 0.
2283 diag_di = 0.
2284 diag_rhoi = 0.
2285 if (present(diag_dhmax)) diag_dhmax = 0.
2286 if (present(diag_lami)) diag_lami = 0.
2287 if (present(diag_mui)) diag_mui = 0.
2288 diag_2d = 0.
2289 diag_3d = 0.
2290 rhorime_c = 400.
2291 !rhorime_r = 400.
2293 tmparr1 = (pres*1.e-5)**(rd*inv_cp)
2294 invexn = 1./tmparr1 !inverse Exner function array
2295 t = th *tmparr1 !compute temperature from theta (value at beginning of microphysics step)
2296 t_old = th_old*tmparr1 !compute temperature from theta (value at beginning of model time step)
2297 qv = max(qv,0.) !clip water vapor to prevent negative values passed in (beginning of microphysics)
2298 !==
2300 !-----------------------------------------------------------------------------------!
2301 i_loop_main: do i = its,ite ! main i-loop (around the entire scheme)
2303 if (debug_on) then
2304 location_ind = 100
2305 force_abort =.false.
2306 if (log_3momentIce) then
2307 call check_values(qv(i,:),T(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
2308 qirim(i,:,:),nitot(i,:,:),birim(i,:,:),i,it,force_abort,location_ind, &
2309 Zitot=zitot(i,:,:))
2310 else
2311 call check_values(qv(i,:),T(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
2312 qirim(i,:,:),nitot(i,:,:),birim(i,:,:),i,it,force_abort,location_ind)
2313 endif
2314 if (global_status /= STATUS_OK) return
2315 endif
2317 log_hydrometeorsPresent = .false.
2318 log_nucleationPossible = .false.
2320 k_loop_1: do k = kbot,ktop,kdir
2322 !calculate some time-varying atmospheric variables
2323 rho(i,k) = pres(i,k)/(rd*t(i,k))
2324 inv_rho(i,k) = 1./rho(i,k)
2325 xxlv(i,k) = 3.1484e6-2370.*273.15 !t(i,k), use constant Lv
2326 xxls(i,k) = xxlv(i,k)+0.3337e6
2327 xlf(i,k) = xxls(i,k)-xxlv(i,k)
2328 ! max statement added below for first calculation when t_old is zero before t_old is set at end of p3 main
2329 qvs(i,k) = qv_sat(max(t_old(i,k),1.),pres(i,k),0)
2330 qvi(i,k) = qv_sat(max(t_old(i,k),1.),pres(i,k),1)
2332 ! if supersaturation is not predicted or during the first time step, then diagnose from qv and T (qvs)
2333 if (.not.(log_predictSsat).or.it.le.1) then
2334 ssat(i,k) = qv_old(i,k)-qvs(i,k)
2335 sup(i,k) = qv_old(i,k)/qvs(i,k)-1.
2336 supi(i,k) = qv_old(i,k)/qvi(i,k)-1.
2337 ! if supersaturation is predicted then diagnose sup and supi from ssat
2338 else if ((log_predictSsat).and.it.gt.1) then
2339 sup(i,k) = ssat(i,k)/qvs(i,k)
2340 supi(i,k) = (ssat(i,k)+qvs(i,k)-qvi(i,k))/qvi(i,k)
2341 endif
2343 rhofacr(i,k) = (rhosur*inv_rho(i,k))**0.54
2344 rhofaci(i,k) = (rhosui*inv_rho(i,k))**0.54
2345 dum = 1.496e-6*t(i,k)**1.5/(t(i,k)+120.) ! this is mu
2346 acn(i,k) = g*rhow/(18.*dum) ! 'a' parameter for droplet fallspeed (Stokes' law)
2348 !specify cloud droplet number (for 1-moment version)
2349 if (.not.(log_predictNc)) then
2350 nc(i,k) = nccnst*inv_rho(i,k)
2351 endif
2353 ! The test below is skipped if SCPF is not used since now, if SCF>0 somewhere, then nucleation is possible.
2354 ! If there is the possibility of nucleation or droplet activation (i.e., if RH is relatively high)
2355 ! then calculate microphysical processes even if there is no existing condensate
2356 ! Note only theta is updated from clipping and not temp, though temp is used for subsequent calculations.
2357 ! This change is tiny and therefore neglected.
2358 if ((t(i,k).lt.273.15 .and. supi(i,k).ge.-0.05) .or. &
2359 (t(i,k).ge.273.15 .and. sup(i,k).ge.-0.05 ) .and. (.not. SCPF_on)) &
2360 log_nucleationPossible = .true.
2362 !--- apply mass clipping if dry and mass is sufficiently small
2363 ! (implying all mass is expected to evaporate/sublimate in one time step)
2365 if (qc(i,k).lt.qsmall .or. (qc(i,k).lt.1.e-8 .and. sup(i,k).lt.-0.1)) then
2366 qv(i,k) = qv(i,k) + qc(i,k)
2367 th(i,k) = th(i,k) - invexn(i,k)*qc(i,k)*xxlv(i,k)*inv_cp
2368 qc(i,k) = 0.
2369 nc(i,k) = 0.
2370 else
2371 log_hydrometeorsPresent = .true. ! updated further down
2372 endif
2374 if (qr(i,k).lt.qsmall .or. (qr(i,k).lt.1.e-8 .and. sup(i,k).lt.-0.1)) then
2375 qv(i,k) = qv(i,k) + qr(i,k)
2376 th(i,k) = th(i,k) - invexn(i,k)*qr(i,k)*xxlv(i,k)*inv_cp
2377 qr(i,k) = 0.
2378 nr(i,k) = 0.
2379 else
2380 log_hydrometeorsPresent = .true. ! updated further down
2381 endif
2383 do iice = 1,nCat
2384 if (qitot(i,k,iice).lt.qsmall .or. (qitot(i,k,iice).lt.1.e-8 .and. &
2385 supi(i,k).lt.-0.1)) then
2386 qv(i,k) = qv(i,k) + qitot(i,k,iice)
2387 th(i,k) = th(i,k) - invexn(i,k)*qitot(i,k,iice)*xxls(i,k)*inv_cp
2388 qitot(i,k,iice) = 0.
2389 nitot(i,k,iice) = 0.
2390 qirim(i,k,iice) = 0.
2391 birim(i,k,iice) = 0.
2392 else
2393 log_hydrometeorsPresent = .true. ! final update
2394 endif
2396 if (qitot(i,k,iice).ge.qsmall .and. qitot(i,k,iice).lt.1.e-8 .and. &
2397 t(i,k).ge.273.15) then
2398 qr(i,k) = qr(i,k) + qitot(i,k,iice)
2399 nr(i,k) = nr(i,k) + nitot(i,k,iice)
2400 th(i,k) = th(i,k) - invexn(i,k)*qitot(i,k,iice)*xlf(i,k)*inv_cp
2401 qitot(i,k,iice) = 0.
2402 nitot(i,k,iice) = 0.
2403 qirim(i,k,iice) = 0.
2404 birim(i,k,iice) = 0.
2405 endif
2407 enddo !iice-loop
2409 !===
2411 enddo k_loop_1
2413 !zero out zitot if there is no qitot for triple moment
2414 if (log_3momentIce) where (qitot(i,:,:).lt.qsmall) zitot(i,:,:) = 0.
2416 if (debug_on) then
2417 location_ind = 200
2418 force_abort =.false.
2419 tmparr1(i,:) = th(i,:)*(pres(i,:)*1.e-5)**(rd*inv_cp)
2420 if (log_3momentIce) then
2421 call check_values(qv(i,:),tmparr1(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
2422 qirim(i,:,:),nitot(i,:,:),birim(i,:,:),i,it,force_abort,location_ind, &
2423 Zitot=zitot(i,:,:))
2424 else
2425 call check_values(qv(i,:),tmparr1(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
2426 qirim(i,:,:),nitot(i,:,:),birim(i,:,:),i,it,force_abort,location_ind)
2427 endif
2428 if (global_status /= STATUS_OK) return
2429 endif
2431 !first call to compute_SCPF
2432 call compute_SCPF(Qc(i,:)+sum(Qitot(i,:,:),dim=2),Qr(i,:),Qv(i,:),Qvi(i,:), &
2433 Pres(i,:),ktop,kbot,kdir,SCF,iSCF,SPF,iSPF,SPF_clr,Qv_cld,Qv_clr, &
2434 SCPF_on,scpf_pfrac,scpf_resfact,quick=.false.)
2436 if ((scpf_ON) .and. (sum(SCF) .ge. 0.01)) log_nucleationPossible = .true.
2438 !jump to end of i-loop if log_nucleationPossible=.false. (i.e. skip everything)
2439 if (.not. (log_nucleationPossible .or. log_hydrometeorsPresent)) goto 333
2441 log_hydrometeorsPresent = .false. ! reset value; used again below
2443 !-- for sedimentation-only tests:
2444 !goto 6969
2445 !==
2447 !------------------------------------------------------------------------------------------!
2448 ! main k-loop (for processes):
2449 k_loop_main: do k = kbot,ktop,kdir
2452 ! if relatively dry and no hydrometeors at this level, skip to end of k-loop (i.e. skip this level)
2453 log_exitlevel = .true.
2454 if (qc(i,k).ge.qsmall .or. qr(i,k).ge.qsmall) log_exitlevel = .false.
2455 do iice = 1,nCat
2456 if (qitot(i,k,iice).ge.qsmall) log_exitlevel = .false.
2457 enddo
2459 !The test below is skipped if SCPF is used since now, if SCF>0 somewhere, then nucleation is possible
2460 if ( ( SCPF_on) .and. log_exitlevel .and. &
2461 (SCF(k).lt.0.01) ) goto 555 !i.e. skip all process rates !%%% FRED TEST NOT SURE
2462 if ( (.not.SCPF_on) .and. log_exitlevel .and. &
2463 ((t(i,k).lt.273.15 .and. supi(i,k).lt.-0.05) .or.&
2464 (t(i,k).ge.273.15 .and. sup(i,k) .lt.-0.05))) goto 555 !i.e. skip all process rates
2466 ! initialize warm-phase process rates
2467 qcacc = 0.; qrevp = 0.; qccon = 0.
2468 qcaut = 0.; qcevp = 0.; qrcon = 0.
2469 ncacc = 0.; ncnuc = 0.; ncslf = 0.
2470 ncautc = 0.; qcnuc = 0.; nrslf = 0.
2471 nrevp = 0.; ncautr = 0.
2473 ! initialize ice-phase process rates
2474 qchetc = 0.; qisub = 0.; nrshdr = 0.
2475 qcheti = 0.; qrcol = 0.; qcshd = 0.
2476 qrhetc = 0.; qimlt = 0.; qccol = 0.
2477 qrheti = 0.; qinuc = 0.; nimlt = 0.
2478 nchetc = 0.; nccol = 0.; ncshdc = 0.
2479 ncheti = 0.; nrcol = 0.; nislf = 0.
2480 nrhetc = 0.; ninuc = 0.; qidep = 0.
2481 nrheti = 0.; nisub = 0.; qwgrth = 0.
2482 qrmul = 0.; nimul = 0.; qicol = 0.
2483 nicol = 0.
2485 log_wetgrowth = .false.
2487 !----------------------------------------------------------------------
2488 predict_supersaturation: if (log_predictSsat) then
2490 ! Adjust cloud water and thermodynamics to prognostic supersaturation
2491 ! following the method in Grabowski and Morrison (2008).
2492 ! Note that the effects of vertical motion are assumed to dominate the
2493 ! production term for supersaturation, and the effects are sub-grid
2494 ! scale mixing and radiation are not explicitly included.
2496 dqsdT = xxlv(i,k)*qvs(i,k)/(rv*t(i,k)*t(i,k))
2497 ab = 1. + dqsdT*xxlv(i,k)*inv_cp
2498 epsilon = (qv(i,k)-qvs(i,k)-ssat(i,k))/ab
2499 epsilon = max(epsilon,-qc(i,k)) ! limit adjustment to available water
2500 ! don't adjust upward if subsaturated
2501 ! otherwise this could result in positive adjustment
2502 ! (spurious generation ofcloud water) in subsaturated conditions
2503 if (ssat(i,k).lt.0.) epsilon = min(0.,epsilon)
2505 ! now do the adjustment
2506 if (abs(epsilon).ge.1.e-15) then
2507 qc(i,k) = qc(i,k)+epsilon
2508 qv(i,k) = qv(i,k)-epsilon
2509 th(i,k) = th(i,k)+epsilon*invexn(i,k)*xxlv(i,k)*inv_cp
2510 ! recalculate variables if there was adjustment
2511 t(i,k) = th(i,k)*(1.e-5*pres(i,k))**(rd*inv_cp)
2512 qvs(i,k) = qv_sat(t(i,k),pres(i,k),0)
2513 qvi(i,k) = qv_sat(t(i,k),pres(i,k),1)
2514 sup(i,k) = qv(i,k)/qvs(i,k)-1.
2515 supi(i,k) = qv(i,k)/qvi(i,k)-1.
2516 ssat(i,k) = qv(i,k)-qvs(i,k)
2517 endif
2519 endif predict_supersaturation
2520 !----------------------------------------------------------------------
2522 ! skip micro process calculations except nucleation/acvtivation if there no hydrometeors are present
2523 log_exitlevel = .true.
2524 if (qc(i,k).ge.qsmall .or. qr(i,k).ge.qsmall) log_exitlevel = .false.
2525 do iice = 1,nCat
2526 if (qitot(i,k,iice).ge.qsmall) log_exitlevel=.false.
2527 enddo
2528 if (log_exitlevel) goto 444 !i.e. skip to nucleation
2530 !time/space varying physical variables
2531 mu = 1.496e-6*t(i,k)**1.5/(t(i,k)+120.)
2532 dv = 8.794e-5*t(i,k)**1.81/pres(i,k)
2533 sc = mu/(rho(i,k)*dv)
2534 dum = 1./(rv*t(i,k)**2)
2535 dqsdT = xxlv(i,k)*qvs(i,k)*dum
2536 dqsidT = xxls(i,k)*qvi(i,k)*dum
2537 ab = 1.+dqsdT*xxlv(i,k)*inv_cp
2538 abi = 1.+dqsidT*xxls(i,k)*inv_cp
2539 kap = 1.414e+3*mu
2540 !very simple temperature dependent aggregation efficiency
2541 ! if (t(i,k).lt.253.15) then
2542 ! eii = 0.1
2543 ! else if (t(i,k).ge.253.15.and.t(i,k).lt.268.15) then
2544 ! eii = 0.1+(t(i,k)-253.15)*0.06 ! linear ramp from 0.1 to 1 between 253.15 and 268.15 K [note: 0.06 = (1./15.)*0.9]
2545 ! else if (t(i,k).ge.268.15) then
2546 ! eii = 1.
2547 ! endif
2548 if (t(i,k).lt.253.15) then
2549 eii = 0.001
2550 else if (t(i,k).ge.253.15.and.t(i,k).lt.273.15) then
2551 eii = 0.001+(t(i,k)-253.15)*(0.3-0.001)/20.
2552 else if (t(i,k).ge.273.15) then
2553 eii = 0.3
2554 endif
2556 call get_cloud_dsd2(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu,lamc(i,k), &
2557 lammin,lammax,cdist(i,k),cdist1(i,k),iSCF(k))
2560 call get_rain_dsd2(qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),cdistr(i,k),logn0r(i,k), &
2561 iSPF(k))
2563 ! initialize inverse supersaturation relaxation timescale for combined ice categories
2564 epsi_tot = 0.
2566 call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k))
2568 iice_loop1: do iice = 1,nCat
2570 qitot_notsmall_1: if (qitot(i,k,iice).ge.qsmall) then
2572 !impose lower limits to prevent taking log of # < 0
2573 nitot(i,k,iice) = max(nitot(i,k,iice),nsmall)
2574 nr(i,k) = max(nr(i,k),nsmall)
2576 !compute mean-mass ice diameters (estimated; rigorous approach to be implemented later)
2577 dum2 = 500. !ice density
2578 diam_ice(i,k,iice) = ((qitot(i,k,iice)*6.)/(nitot(i,k,iice)*dum2*pi))**thrd
2580 call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),birim(i,k,iice),rhop)
2582 call find_lookupTable_indices_1a(dumi,dumjj,dumii,dum1,dum4,dum5,isize, &
2583 rimsize,densize,qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice),rhop)
2585 call find_lookupTable_indices_1b(dumj,dum3,rcollsize,qr(i,k),nr(i,k))
2587 if (.not. log_3momentIce) then
2589 ! call to lookup table interpolation subroutines to get process rates
2590 call access_lookup_table(dumjj,dumii,dumi, 2,dum1,dum4,dum5,f1pr02)
2591 call access_lookup_table(dumjj,dumii,dumi, 3,dum1,dum4,dum5,f1pr03)
2592 call access_lookup_table(dumjj,dumii,dumi, 4,dum1,dum4,dum5,f1pr04)
2593 call access_lookup_table(dumjj,dumii,dumi, 5,dum1,dum4,dum5,f1pr05)
2594 call access_lookup_table(dumjj,dumii,dumi, 7,dum1,dum4,dum5,f1pr09)
2595 call access_lookup_table(dumjj,dumii,dumi, 8,dum1,dum4,dum5,f1pr10)
2596 call access_lookup_table(dumjj,dumii,dumi,10,dum1,dum4,dum5,f1pr14)
2598 ! ice-rain collection processes
2599 if (qr(i,k).ge.qsmall) then
2600 call access_lookup_table_coll(dumjj,dumii,dumj,dumi,1,dum1,dum3,dum4,dum5,f1pr07)
2601 call access_lookup_table_coll(dumjj,dumii,dumj,dumi,2,dum1,dum3,dum4,dum5,f1pr08)
2602 else
2603 f1pr07 = -99. ! log space
2604 f1pr08 = -99. ! log space
2605 endif
2607 else ! 3-moment ice
2609 ! get G indices
2611 !impose lower limits to prevent taking log of # < 0
2612 zitot(i,k,iice) = max(zitot(i,k,iice),zsmall)
2614 dum1z = 6./(200.*pi)*qitot(i,k,iice) !estimate of moment3, as starting point use 200 kg m-3 estimate of bulk density
2616 do imu=1,niter_mui
2617 mu_i = compute_mu_3moment(nitot(i,k,iice),dum1z,zitot(i,k,iice),mu_i_max)
2618 call find_lookupTable_indices_1c(dumzz,dum6,zsize,qitot(i,k,iice),mu_i)
2619 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,12,dum1,dum4,dum5,dum6,f1pr16) ! find actual bulk density
2620 dum1z = 6./(f1pr16*pi)*qitot(i,k,iice) !estimate of moment3
2621 enddo
2623 ! call find_lookupTable_indices_1c(dumzz,dum6,zsize,qitot(i,k,iice),zitot(i,k,iice)) !HM moved to above
2625 ! call to lookup table interpolation subroutines to get process rates
2626 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 2,dum1,dum4,dum5,dum6,f1pr02)
2627 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 3,dum1,dum4,dum5,dum6,f1pr03)
2628 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 4,dum1,dum4,dum5,dum6,f1pr04)
2629 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 5,dum1,dum4,dum5,dum6,f1pr05)
2630 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 7,dum1,dum4,dum5,dum6,f1pr09)
2631 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 8,dum1,dum4,dum5,dum6,f1pr10)
2632 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,10,dum1,dum4,dum5,dum6,f1pr14)
2633 ! call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,12,dum1,dum4,dum5,dum6,f1pr16) !HM moved to above
2635 ! ice-rain collection processes
2636 if (qr(i,k).ge.qsmall) then
2637 call access_lookup_table_coll_3mom(dumzz,dumjj,dumii,dumj,dumi,1,dum1,dum3,dum4,dum5,dum6,f1pr07)
2638 call access_lookup_table_coll_3mom(dumzz,dumjj,dumii,dumj,dumi,2,dum1,dum3,dum4,dum5,dum6,f1pr08)
2639 else
2640 f1pr07 = -99. ! log space
2641 f1pr08 = -99. ! log space
2642 endif
2644 endif !if log_3momentIce
2646 ! adjust Ni if needed to make sure mean size is in bounds (i.e. apply lambda limiters)
2647 ! note: the inv_Qmin (f1pr09) and inv_Qmax (f1pr10) are normalized, thus the
2648 ! max[min] values of nitot are obtained from multiplying these values by qitot.
2649 nitot(i,k,iice) = min(nitot(i,k,iice),f1pr09*qitot(i,k,iice))
2650 nitot(i,k,iice) = max(nitot(i,k,iice),f1pr10*qitot(i,k,iice))
2652 ! adjust Zitot to make sure mu is in bounds
2653 ! note that the Zmax and Zmin are normalized and thus need to be multiplied by existing Q
2654 if (log_3momentIce) then
2655 dum1 = 6./(f1pr16*pi)*qitot(i,k,iice) !estimate of moment3
2656 tmp1 = G_of_mu(0.)
2657 tmp2 = G_of_mu(20.)
2658 zitot(i,k,iice) = min(zitot(i,k,iice),tmp1*dum1**2/nitot(i,k,iice))
2659 zitot(i,k,iice) = max(zitot(i,k,iice),tmp2*dum1**2/nitot(i,k,iice))
2660 endif
2662 ! Determine additional collection efficiency factor to be applied to ice-ice collection.
2663 ! The computed values of qicol and nicol are multipiled by Eii_fact to gradually shut off collection
2664 ! if the ice in iice is highly rimed.
2665 if (qirim(i,k,iice)>0.) then
2666 tmp1 = qirim(i,k,iice)/qitot(i,k,iice) !rime mass fraction
2667 if (tmp1.lt.0.6) then
2668 Eii_fact(iice)=1.
2669 else if (tmp1.ge.0.6.and.tmp1.lt.0.9) then
2670 ! linear ramp from 1 to 0 for Fr between 0.6 and 0.9
2671 Eii_fact(iice) = 1.-(tmp1-0.6)/0.3
2672 else if (tmp1.ge.0.9) then
2673 Eii_fact(iice) = 0.
2674 endif
2675 else
2676 Eii_fact(iice) = 1.
2677 endif
2679 endif qitot_notsmall_1 ! qitot > qsmall
2681 !----------------------------------------------------------------------
2682 ! Begin calculations of microphysical processes
2684 !......................................................................
2685 ! ice processes
2686 !......................................................................
2688 !.......................
2689 ! collection of droplets
2691 ! here we multiply rates by air density, air density fallspeed correction
2692 ! factor, and collection efficiency since these parameters are not
2693 ! included in lookup table calculations
2694 ! for T < 273.15, assume collected cloud water is instantly frozen
2695 ! note 'f1pr' values are normalized, so we need to multiply by N
2697 if (qitot(i,k,iice).ge.qsmall .and. qc(i,k).ge.qsmall .and. t(i,k).le.273.15) then
2698 qccol(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k)
2699 nccol(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k)
2700 endif
2702 ! for T > 273.15, assume cloud water is collected and shed as rain drops
2704 if (qitot(i,k,iice).ge.qsmall .and. qc(i,k).ge.qsmall .and. t(i,k).gt.273.15) then
2705 ! sink for cloud water mass and number, note qcshed is source for rain mass
2706 qcshd(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k)
2707 nccol(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)*iSCF(k)
2708 ! source for rain number, assume 1 mm drops are shed
2709 ncshdc(iice) = qcshd(iice)*1.923e+6
2710 endif
2712 !....................
2713 ! collection of rain
2715 ! here we multiply rates by air density, air density fallspeed correction
2716 ! factor, collection efficiency, and n0r since these parameters are not
2717 ! included in lookup table calculations
2719 ! for T < 273.15, assume all collected rain mass freezes
2720 ! note this is a sink for rain mass and number and a source
2721 ! for ice mass
2723 ! note 'f1pr' values are normalized, so we need to multiply by N
2725 if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15) then
2726 ! qrcol(iice)=f1pr08*logn0r(i,k)*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)
2727 ! nrcol(iice)=f1pr07*logn0r(i,k)*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)
2728 ! note: f1pr08 and logn0r are already calculated as log_10
2729 qrcol(iice) = 10.**(f1pr08+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k))
2730 nrcol(iice) = 10.**(f1pr07+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k))
2731 endif
2733 ! for T > 273.15, assume collected rain number is shed as
2734 ! 1 mm drops
2735 ! note that melting of ice number is scaled to the loss
2736 ! rate of ice mass due to melting
2737 ! collection of rain above freezing does not impact total rain mass
2739 if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).gt.273.15) then
2740 ! rain number sink due to collection
2741 nrcol(iice) = 10.**(f1pr07 + logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k))
2742 ! rain number source due to shedding = collected rain mass/mass of 1 mm drop
2743 dum = 10.**(f1pr08 + logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)*iSCF(k)*(SPF(k)-SPF_clr(k))
2744 ! for now neglect shedding of ice collecting rain above freezing, since snow is
2745 ! not expected to shed in these conditions (though more hevaily rimed ice would be
2746 ! expected to lead to shedding)
2747 ! nrshdr(iice) = dum*1.923e+6 ! 1./5.2e-7, 5.2e-7 is the mass of a 1 mm raindrop
2748 endif
2750 !...................................
2751 ! collection between ice categories
2753 ! iceice_interaction1: if (.false.) then !for testing (to suppress ice-ice interaction)
2754 iceice_interaction1: if (iice.ge.2) then
2756 !note: In this version, lookupTable_2 (LT2, for ice category interactions) is computed for a maximum
2757 ! mean ice size of Dm_max=2000.e-6 m (the old lambda_i limiter); thus it is compatible with
2758 ! use of LT1-v5.2_2momI (with Dm_max=2000.e-6) [i.e. for log_3momentIce=.false.] but not with
2759 ! LT1-v5.3_3momI (with Dm_max=400000.e-6). This means that this version can still be
2760 ! run with the 3momI + nCat>1 configuration, but the ice-ice interactions between different
2761 ! categories (in this 'iceice_interaction1' block) is suppressed.
2762 ! In a forthcoming version, both LT1-2momI and LT2 (and LT1-3momI) will all be computed
2763 ! using the unconstrained size limited (i.e. Dm_max=400000.e-6).
2765 qitot_notsmall: if (qitot(i,k,iice).ge.qsmall) then
2766 catcoll_loop: do catcoll = 1,iice-1
2767 qitotcatcoll_notsmall: if (qitot(i,k,catcoll).ge.qsmall) then
2769 ! first, calculate collection of catcoll category by iice category
2771 call find_lookupTable_indices_2(dumi,dumii,dumjj,dumic,dumiic, &
2772 dumjjc,dum1,dum4,dum5,dum1c,dum4c,dum5c, &
2773 iisize,rimsize,densize, &
2774 qitot(i,k,iice),qitot(i,k,catcoll),nitot(i,k,iice), &
2775 nitot(i,k,catcoll),qirim(i,k,iice),qirim(i,k,catcoll), &
2776 birim(i,k,iice),birim(i,k,catcoll))
2778 call access_lookup_table_colli(dumjjc,dumiic,dumic,dumjj,dumii, &
2779 dumi,1,dum1c,dum4c,dum5c,dum1,dum4,dum5,f1pr17)
2780 call access_lookup_table_colli(dumjjc,dumiic,dumic,dumjj,dumii, &
2781 dumi,2,dum1c,dum4c,dum5c,dum1,dum4,dum5,f1pr18)
2783 ! note: need to multiply by air density, air density fallspeed correction factor,
2784 ! and N of the collectee and collector categories for process rates nicol and qicol,
2785 ! first index is the collectee, second is the collector
2786 nicol(catcoll,iice) = f1pr17*rhofaci(i,k)*rho(i,k)* &
2787 nitot(i,k,catcoll)*nitot(i,k,iice)*iSCF(k)
2788 qicol(catcoll,iice) = f1pr18*rhofaci(i,k)*rho(i,k)* &
2789 nitot(i,k,catcoll)*nitot(i,k,iice)*iSCF(k)
2791 nicol(catcoll,iice) = eii*Eii_fact(iice)*nicol(catcoll,iice)
2792 qicol(catcoll,iice) = eii*Eii_fact(iice)*qicol(catcoll,iice)
2793 nicol(catcoll,iice) = min(nicol(catcoll,iice), nitot(i,k,catcoll)*odt)
2794 qicol(catcoll,iice) = min(qicol(catcoll,iice), qitot(i,k,catcoll)*odt)
2796 ! second, calculate collection of iice category by catcoll category
2798 !needed to force consistency between qirim(catcoll) and birim(catcoll) (not for rhop)
2799 call calc_bulkRhoRime(qitot(i,k,catcoll),qirim(i,k,catcoll),birim(i,k,catcoll),rhop)
2801 call find_lookupTable_indices_2(dumi,dumii,dumjj,dumic,dumiic, &
2802 dumjjc,dum1,dum4,dum5,dum1c,dum4c,dum5c, &
2803 iisize,rimsize,densize, &
2804 qitot(i,k,catcoll),qitot(i,k,iice),nitot(i,k,catcoll), &
2805 nitot(i,k,iice),qirim(i,k,catcoll),qirim(i,k,iice), &
2806 birim(i,k,catcoll),birim(i,k,iice))
2808 call access_lookup_table_colli(dumjjc,dumiic,dumic,dumjj,dumii, &
2809 dumi,1,dum1c,dum4c,dum5c,dum1,dum4,dum5,f1pr17)
2811 call access_lookup_table_colli(dumjjc,dumiic,dumic,dumjj,dumii, &
2812 dumi,2,dum1c,dum4c,dum5c,dum1,dum4,dum5,f1pr18)
2814 nicol(iice,catcoll) = f1pr17*rhofaci(i,k)*rho(i,k)* &
2815 nitot(i,k,iice)*nitot(i,k,catcoll)*iSCF(k)
2816 qicol(iice,catcoll) = f1pr18*rhofaci(i,k)*rho(i,k)* &
2817 nitot(i,k,iice)*nitot(i,k,catcoll)*iSCF(k)
2819 ! note: Eii_fact applied to the collector category
2820 nicol(iice,catcoll) = eii*Eii_fact(catcoll)*nicol(iice,catcoll)
2821 qicol(iice,catcoll) = eii*Eii_fact(catcoll)*qicol(iice,catcoll)
2822 nicol(iice,catcoll) = min(nicol(iice,catcoll),nitot(i,k,iice)*odt)
2823 qicol(iice,catcoll) = min(qicol(iice,catcoll),qitot(i,k,iice)*odt)
2825 endif qitotcatcoll_notsmall
2826 enddo catcoll_loop
2827 endif qitot_notsmall
2829 endif iceice_interaction1
2832 !.............................................
2833 ! self-collection of ice (in a given category)
2835 ! here we multiply rates by collection efficiency, air density,
2836 ! and air density correction factor since these are not included
2837 ! in the lookup table calculations
2838 ! note 'f1pr' values are normalized, so we need to multiply by N
2840 if (qitot(i,k,iice).ge.qsmall) then
2841 nislf(iice) = f1pr03*rho(i,k)*eii*Eii_fact(iice)*rhofaci(i,k)*nitot(i,k,iice)*nitot(i,k,iice)*iSCF(k)
2842 endif
2845 !............................................................
2846 ! melting
2848 ! need to add back accelerated melting due to collection of ice mass by rain (pracsw1)
2849 ! note 'f1pr' values are normalized, so we need to multiply by N
2851 if (qitot(i,k,iice).ge.qsmall .and. t(i,k).gt.273.15) then
2852 qsat0 = 0.622*e0/(pres(i,k)-e0)
2853 ! dum=cpw/xlf(i,k)*(t(i,k)-273.15)*(pracsw1+qcshd(iice))
2854 ! currently enhanced melting from collision is neglected
2855 ! dum=cpw/xlf(i,k)*(t(i,k)-273.15)*(pracsw1)
2856 dum = 0.
2857 ! qimlt(iice)=(f1pr05+f1pr14*sc**0.3333*(rhofaci(i,k)*rho(i,k)/mu)**0.5)* &
2858 ! (t(i,k)-273.15)*2.*pi*kap/xlf(i,k)+dum
2859 ! include RH dependence
2860 qimlt(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*((t(i,k)- &
2861 273.15)*kap-rho(i,k)*xxlv(i,k)*dv*(qsat0-Qv_cld(k)))*2.*pi/xlf(i,k)+ &
2862 dum)*nitot(i,k,iice)
2863 qimlt(iice) = max(qimlt(iice),0.)
2864 nimlt(iice) = qimlt(iice)*(nitot(i,k,iice)/qitot(i,k,iice))
2865 endif
2867 !............................................................
2868 ! calculate wet growth
2870 ! similar to Musil (1970), JAS
2871 ! note 'f1pr' values are normalized, so we need to multiply by N
2873 if (qitot(i,k,iice).ge.qsmall .and. (qc(i,k)+qr(i,k)).ge.1.e-6 .and. t(i,k).lt.273.15) then
2875 qsat0 = 0.622*e0/(pres(i,k)-e0)
2876 qwgrth(iice) = ((f1pr05 + f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)* &
2877 2.*pi*(rho(i,k)*xxlv(i,k)*dv*(qsat0-Qv_cld(k))-(t(i,k)-273.15)* &
2878 kap)/(xlf(i,k)+cpw*(t(i,k)-273.15)))*nitot(i,k,iice)
2879 qwgrth(iice) = max(qwgrth(iice),0.)
2880 !calculate shedding for wet growth
2881 dum = max(0.,(qccol(iice)+qrcol(iice))-qwgrth(iice))
2882 if (dum.ge.1.e-10) then
2883 nrshdr(iice) = nrshdr(iice) + dum*1.923e+6 ! 1/5.2e-7, 5.2e-7 is the mass of a 1 mm raindrop
2884 if ((qccol(iice)+qrcol(iice)).ge.1.e-10) then
2885 dum1 = 1./(qccol(iice)+qrcol(iice))
2886 qcshd(iice) = qcshd(iice) + dum*qccol(iice)*dum1
2887 qccol(iice) = qccol(iice) - dum*qccol(iice)*dum1
2888 qrcol(iice) = qrcol(iice) - dum*qrcol(iice)*dum1
2889 endif
2890 ! densify due to wet growth
2891 log_wetgrowth(iice) = .true.
2892 endif
2894 endif
2897 !-----------------------------
2898 ! calcualte total inverse ice relaxation timescale combined for all ice categories
2899 ! note 'f1pr' values are normalized, so we need to multiply by N
2900 if (qitot(i,k,iice).ge.qsmall .and. t(i,k).lt.273.15) then
2901 epsi(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*2.*pi* &
2902 rho(i,k)*dv)*nitot(i,k,iice)
2903 epsi_tot = epsi_tot + epsi(iice)
2904 else
2905 epsi(iice) = 0.
2906 endif
2909 !.........................
2910 ! calculate rime density
2912 ! FUTURE: Add source term for birim (=qccol/rhorime_c) so that all process rates calculations
2913 ! are done together, before conservation.
2915 ! NOTE: Tc (ambient) is assumed for the surface temperature. Technically,
2916 ! we should diagose graupel surface temperature from heat balance equation.
2917 ! (but the ambient temperature is a reasonable approximation; tests show
2918 ! very little sensitivity to different assumed values, Milbrandt and Morrison 2012).
2920 ! Compute rime density: (based on parameterization of Cober and List, 1993 [JAS])
2921 ! for simplicty use mass-weighted ice and droplet/rain fallspeeds
2923 ! if (qitot(i,k,iice).ge.qsmall .and. t(i,k).lt.273.15) then
2924 ! NOTE: condition applicable for cloud only; modify when rain is added back
2925 if (qccol(iice).ge.qsmall .and. t(i,k).lt.273.15) then
2927 ! get mass-weighted mean ice fallspeed
2928 vtrmi1(i,k) = f1pr02*rhofaci(i,k)
2929 iTc = 1./min(-0.001,t(i,k)-273.15)
2931 ! cloud:
2932 if (qc(i,k).ge.qsmall) then
2933 ! droplet fall speed
2934 ! (use Stokes' formulation (thus use analytic solution)
2935 Vt_qc(i,k) = acn(i,k)*gamma(4.+bcn+mu_c(i,k))/(lamc(i,k)**bcn*gamma(mu_c(i,k)+4.))
2936 ! use mass-weighted mean size
2937 D_c = (mu_c(i,k)+4.)/lamc(i,k)
2938 V_impact = abs(vtrmi1(i,k)-Vt_qc(i,k))
2939 Ri = -(0.5e+6*D_c)*V_impact*iTc
2940 ! Ri = max(1.,min(Ri,8.))
2941 Ri = max(1.,min(Ri,12.))
2942 if (Ri.le.8.) then
2943 rhorime_c(iice) = (0.051 + 0.114*Ri - 0.0055*Ri**2)*1000.
2944 else
2945 ! for Ri > 8 assume a linear fit between 8 and 12,
2946 ! rhorime = 900 kg m-3 at Ri = 12
2947 ! this is somewhat ad-hoc but allows a smoother transition
2948 ! in rime density up to wet growth
2949 rhorime_c(iice) = 611.+72.25*(Ri-8.)
2950 endif
2952 endif !if qc>qsmall
2954 ! rain:
2955 ! assume rime density for rain collecting ice is 900 kg/m3
2956 ! if (qr(i,k).ge.qsmall) then
2957 ! D_r = (mu_r(i,k)+1.)/lamr(i,k)
2958 ! V_impact = abs(vtrmi1(i,k)-Vt_qr(i,k))
2959 ! Ri = -(0.5e+6*D_r)*V_impact*iTc
2960 ! Ri = max(1.,min(Ri,8.))
2961 ! rhorime_r(iice) = (0.051 + 0.114*Ri - 0.0055*Ri*Ri)*1000.
2962 ! else
2963 ! rhorime_r(iice) = 400.
2964 ! endif
2966 else
2967 rhorime_c(iice) = 400.
2968 ! rhorime_r(iice) = 400.
2969 endif ! qi > qsmall and T < 273.15
2971 !--------------------
2972 enddo iice_loop1
2973 !--------------------
2975 !............................................................
2976 ! contact and immersion freezing droplets
2978 ! contact freezing currently turned off
2979 ! dum=7.37*t(i,k)/(288.*10.*pres(i,k))/100.
2980 ! dap=4.*pi*1.38e-23*t(i,k)*(1.+dum/rin)/ &
2981 ! (6.*pi*rin*mu)
2982 ! nacnt=exp(-2.80+0.262*(273.15-t(i,k)))*1000.
2984 if (qc(i,k).ge.qsmall .and. t(i,k).le.269.15) then
2985 ! qchetc(iice) = pi*pi/3.*Dap*Nacnt*rhow*cdist1(i,k)*gamma(mu_c(i,k)+5.)/lamc(i,k)**4
2986 ! nchetc(iice) = 2.*pi*Dap*Nacnt*cdist1(i,k)*gamma(mu_c(i,k)+2.)/lamc(i,k)
2987 ! for future: calculate gamma(mu_c+4) in one place since its used multiple times
2988 dum = (1./lamc(i,k))**3
2989 ! qcheti(iice_dest) = cons6*cdist1(i,k)*gamma(7.+pgam(i,k))*exp(aimm*(273.15-t(i,k)))*dum**2
2990 ! ncheti(iice_dest) = cons5*cdist1(i,k)*gamma(pgam(i,k)+4.)*exp(aimm*(273.15-t(i,k)))*dum
2992 ! Q_nuc = cons6*cdist1(i,k)*gamma(7.+mu_c(i,k))*exp(aimm*(273.15-t(i,k)))*dum**2
2993 ! N_nuc = cons5*cdist1(i,k)*gamma(mu_c(i,k)+4.)*exp(aimm*(273.15-t(i,k)))*dum
2994 tmp1 = cdist1(i,k)*exp(aimm*(273.15-t(i,k)))
2995 Q_nuc = cons6*gamma(7.+mu_c(i,k))*tmp1*dum**2
2996 N_nuc = cons5*gamma(mu_c(i,k)+4.)*tmp1*dum
2997 ! tmpdbl1 = dexp(dble(aimm*(273.15-t(i,k))))
2998 ! tmpdbl2 = dble(dum)
2999 ! Q_nuc = cons6*cdist1(i,k)*gamma(7.+mu_c(i,k))*tmpdbl1*tmpdbl2**2
3000 ! N_nuc = cons5*cdist1(i,k)*gamma(mu_c(i,k)+4.)*tmpdbl1*tmpdbl2
3003 if (nCat>1) then
3004 !determine destination ice-phase category:
3005 dum1 = 900. !density of new ice
3006 D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd
3007 call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest)
3009 if (global_status /= STATUS_OK) return
3010 else
3011 iice_dest = 1
3012 endif
3013 qcheti(iice_dest) = Q_nuc
3014 ncheti(iice_dest) = N_nuc
3015 endif
3017 !............................................................
3018 ! immersion freezing of rain
3019 ! for future: get rid of log statements below for rain freezing
3021 if (qr(i,k)*iSPF(k).ge.qsmall.and.t(i,k).le.269.15) then
3023 ! Q_nuc = cons6*exp(log(cdistr(i,k))+log(gamma(7.+mu_r(i,k)))-6.*log(lamr(i,k)))*exp(aimm*(273.15-t(i,k)))*SPF(k)
3024 ! N_nuc = cons5*exp(log(cdistr(i,k))+log(gamma(mu_r(i,k)+4.))-3.*log(lamr(i,k)))*exp(aimm*(273.15-t(i,k)))*SPF(k)
3025 tmpdbl1 = dexp(dble(log(cdistr(i,k))+log(gamma(7.+mu_r(i,k)))-6.*log(lamr(i,k))))
3026 tmpdbl2 = dexp(dble(log(cdistr(i,k))+log(gamma(mu_r(i,k)+4.))-3.*log(lamr(i,k))))
3027 tmpdbl3 = dexp(dble(aimm*(273.15-t(i,k))))
3028 Q_nuc = cons6*sngl(tmpdbl1*tmpdbl3)*SPF(k)
3029 N_nuc = cons5*sngl(tmpdbl2*tmpdbl3)*SPF(k)
3031 if (nCat>1) then
3032 !determine destination ice-phase category:
3033 dum1 = 900. !density of new ice
3034 D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd
3035 call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new, &
3036 deltaD_init,iice_dest)
3037 if (global_status /= STATUS_OK) return
3038 else
3039 iice_dest = 1
3040 endif
3041 qrheti(iice_dest) = Q_nuc
3042 nrheti(iice_dest) = N_nuc
3043 endif
3046 !......................................
3047 ! rime splintering (Hallet-Mossop 1974)
3049 rimesplintering_on: if (log_hmossopOn) then
3051 if (nCat>1) then
3052 !determine destination ice-phase category
3053 D_new = 10.e-6 !assumes ice crystals from rime splintering are tiny
3054 call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest)
3055 if (global_status /= STATUS_OK) return
3056 else
3057 iice_dest = 1
3058 endif
3060 iice_loop_HM: do iice = 1,nCat
3062 ! rime splintering occurs from accretion by large ice, assume a threshold
3063 ! mean mass size of 4 mm (ad-hoc, could be modified)
3064 if (qitot(i,k,iice).ge.qsmall.and.diam_ice(i,k,iice).ge.4000.e-6 &
3065 .and. (qccol(iice).gt.0. .or. qrcol(iice).gt.0.)) then
3067 if (t(i,k).gt.270.15) then
3068 dum = 0.
3069 elseif (t(i,k).le.270.15 .and. t(i,k).gt.268.15) then
3070 dum = (270.15-t(i,k))*0.5
3071 elseif (t(i,k).le.268.15 .and. t(i,k).ge.265.15) then
3072 dum = (t(i,k)-265.15)*thrd
3073 elseif (t(i,k).lt.265.15) then
3074 dum = 0.
3075 endif
3077 !rime splintering from riming of cloud droplets
3078 ! dum1 = 35.e+4*qccol(iice)*dum*1000. ! 1000 is to convert kg to g
3079 ! dum2 = dum1*piov6*900.*(10.e-6)**3 ! assume 10 micron splinters
3080 ! qccol(iice) = qccol(iice)-dum2 ! subtract splintering from rime mass transfer
3081 ! if (qccol(iice) .lt. 0.) then
3082 ! dum2 = qccol(iice)
3083 ! qccol(iice) = 0.
3084 ! endif
3085 ! qcmul(iice_dest) = qcmul(iice_dest)+dum2
3086 ! nimul(iice_dest) = nimul(iice_dest)+dum2/(piov6*900.*(10.e-6)**3)
3088 !rime splintering from riming of large drops (> 25 microns diameter)
3089 !for simplicitly it is assumed that all accreted rain contributes to splintering,
3090 !but accreted cloud water does not - hence why the code is commented out above
3091 dum1 = 35.e+4*qrcol(iice)*dum*1000. ! 1000 is to convert kg to g
3092 dum2 = dum1*piov6*900.*(10.e-6)**3 ! assume 10 micron splinters
3093 qrcol(iice) = qrcol(iice)-dum2 ! subtract splintering from rime mass transfer
3094 if (qrcol(iice) .lt. 0.) then
3095 dum2 = qrcol(iice)+dum2
3096 qrcol(iice) = 0.
3097 endif
3099 qrmul(iice_dest) = qrmul(iice_dest) + dum2
3100 nimul(iice_dest) = nimul(iice_dest) + dum2/(piov6*900.*(10.e-6)**3)
3102 endif
3104 enddo iice_loop_HM
3106 endif rimesplintering_on
3109 !....................................................
3110 ! condensation/evaporation and deposition/sublimation
3111 ! (use semi-analytic formulation)
3113 !calculate rain evaporation including ventilation
3114 if (qr(i,k)*iSPF(k).ge.qsmall) then
3115 call find_lookupTable_indices_3(dumii,dumjj,dum1,rdumii,rdumjj,inv_dum3,mu_r(i,k),lamr(i,k))
3116 !interpolate value at mu_r
3117 dum1 = revap_table(dumii,dumjj)+(rdumii-real(dumii))* &
3118 (revap_table(dumii+1,dumjj)-revap_table(dumii,dumjj))
3119 !interoplate value at mu_r+1
3120 dum2 = revap_table(dumii,dumjj+1)+(rdumii-real(dumii))* &
3121 (revap_table(dumii+1,dumjj+1)-revap_table(dumii,dumjj+1))
3122 !final interpolation
3123 dum = dum1+(rdumjj-real(dumjj))*(dum2-dum1)
3125 epsr = 2.*pi*cdistr(i,k)*rho(i,k)*dv*(f1r*gamma(mu_r(i,k)+2.)/(lamr(i,k)) &
3126 +f2r*(rho(i,k)/mu)**0.5*sc**thrd*dum)
3127 else
3128 epsr = 0.
3129 endif
3131 if (qc(i,k).ge.qsmall) then
3132 epsc = 2.*pi*rho(i,k)*dv*cdist(i,k)
3133 else
3134 epsc = 0.
3135 endif
3137 if (t(i,k).lt.273.15) then
3138 oabi = 1./abi
3139 xx = epsc + epsr + epsi_tot*(1.+xxls(i,k)*inv_cp*dqsdT)*oabi
3140 else
3141 xx = epsc + epsr
3142 endif
3144 dumqvi = qvi(i,k) !no modification due to latent heating
3145 !----
3146 ! ! ! modify due to latent heating from riming rate
3147 ! ! ! - currently this is done by simple linear interpolation
3148 ! ! ! between conditions for dry and wet growth --> in wet growth it is assumed
3149 ! ! ! that particle surface temperature is at 0 C and saturation vapor pressure
3150 ! ! ! is that with respect to liquid. This simple treatment could be improved in the future.
3151 ! ! if (qwgrth(iice).ge.1.e-20) then
3152 ! ! dum = (qccol(iice)+qrcol(iice))/qwgrth(iice)
3153 ! ! else
3154 ! ! dum = 0.
3155 ! ! endif
3156 ! ! dumqvi = qvi(i,k) + dum*(qvs(i,k)-qvi(i,k))
3157 ! ! dumqvi = min(qvs(i,k),dumqvi)
3158 !====
3161 ! 'A' term including ice (Bergeron process)
3162 ! note: qv and T tendencies due to mixing and radiation are
3163 ! currently neglected --> assumed to be much smaller than cooling
3164 ! due to vertical motion which IS included
3166 ! The equivalent vertical velocity is set to be consistent with dT/dt
3167 ! since -g/cp*dum = dT/dt therefore dum = -cp/g*dT/dt
3168 ! note this formulation for dT/dt is not exact since pressure
3169 ! may change and t and t_old were both diagnosed using the current pressure
3170 ! errors from this assumption are small
3171 dum = -cp/g*(t(i,k)-t_old(i,k))*odt
3173 ! dum = qvs(i,k)*rho(i,k)*g*uzpl(i,k)/max(1.e-3,(pres(i,k)-polysvp1(t(i,k),0)))
3175 if (t(i,k).lt.273.15) then
3176 aaa = (qv(i,k)-qv_old(i,k))*odt - dqsdT*(-dum*g*inv_cp)-(qvs(i,k)-dumqvi)* &
3177 (1.+xxls(i,k)*inv_cp*dqsdT)*oabi*epsi_tot
3178 else
3179 aaa = (qv(i,k)-qv_old(i,k))*odt - dqsdT*(-dum*g*inv_cp)
3180 endif
3182 xx = max(1.e-20,xx) ! set lower bound on xx to prevent division by zero
3183 oxx = 1./xx
3185 if (.not. scpf_ON) then
3186 ssat_cld = ssat(i,k)
3187 ssat_r = ssat(i,k)
3188 sup_cld = sup(i,k)
3189 sup_r = sup(i,k)
3190 supi_cld = supi(i,k)
3191 else
3192 ssat_cld = Qv_cld(k) - qvs(i,k) !in-cloud sub/sur-saturation w.r.t. liq
3193 ssat_clr = Qv_clr(k) - qvs(i,k) !clear-sky sub/sur-saturation w.r.t. liq
3194 !mix of in-cloud/clearsky sub/sur-saturation w.r.t. liqfor rain:
3195 ssat_r = ssat_cld*(SPF(k)-SPF_clr(k))+ssat_clr*SPF_clr(k)
3196 sup_r = ssat_r /qvs(i,k)
3197 sup_cld = ssat_cld /qvs(i,k) !in-cloud sub/sur-saturation w.r.t. liq in %
3198 supi_cld = Qv_cld(k)/qvi(i,k)-1.!in-cloud sub/sur-saturation w.r.t. ice in %
3199 endif
3201 if (qc(i,k).ge.qsmall) &
3202 qccon = (aaa*epsc*oxx+(ssat_cld*SCF(k)-aaa*oxx)*odt*epsc*oxx*(1.-sngl(dexp(-dble(xx*dt)))))/ab
3203 if (qr(i,k).ge.qsmall) &
3204 qrcon = (aaa*epsr*oxx+(ssat_r*SPF(k)-aaa*oxx)*odt*epsr*oxx*(1.-sngl(dexp(-dble(xx*dt)))))/ab
3206 !evaporate instantly for very small water contents
3207 if (sup_cld.lt.-0.001 .and. qc(i,k).lt.1.e-12) qccon = -qc(i,k)*odt
3208 if (sup_r .lt.-0.001 .and. qr(i,k).lt.1.e-12) qrcon = -qr(i,k)*odt
3210 if (qccon.lt.0.) then
3211 qcevp = -qccon
3212 qccon = 0.
3213 else
3214 qccon = min(qccon, qv(i,k)*odt)
3215 endif
3217 if (qrcon.lt.0.) then
3218 qrevp = -qrcon
3219 nrevp = qrevp*(nr(i,k)/qr(i,k))
3220 !nrevp = nrevp*exp(-0.2*mu_r(i,k)) !add mu dependence [Seifert (2008), neglecting size dependence]
3221 qrcon = 0.
3222 else
3223 qrcon = min(qrcon, qv(i,k)*odt)
3224 endif
3226 iice_loop_depsub: do iice = 1,nCat
3228 if (qitot(i,k,iice).ge.qsmall.and.t(i,k).lt.273.15) then
3229 !note: diffusional growth/decay rate: (stored as 'qidep' temporarily; may go to qisub below)
3230 qidep(iice) = (aaa*epsi(iice)*oxx+(ssat_cld*SCF(k)-aaa*oxx)*odt*epsi(iice)*oxx* &
3231 (1.-sngl(dexp(-dble(xx*dt)))))*oabi+(qvs(i,k)-dumqvi)*epsi(iice)*oabi
3232 endif
3234 !for very small ice contents in dry air, sublimate all ice instantly
3235 if (supi_cld.lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12) &
3236 qidep(iice) = -qitot(i,k,iice)*odt
3238 !note: 'clbfact_dep' and 'clbfact_sub' calibration factors for ice deposition and sublimation
3239 ! These are adjustable ad hoc factors used to increase or decrease deposition and/or
3240 ! sublimation rates. The representation of the ice capacitances are highly simplified
3241 ! and the appropriate values in the diffusional growth equation are uncertain.
3243 if (qidep(iice).lt.0.) then
3244 !note: limit to saturation adjustment (for dep and subl) is applied later
3245 qisub(iice) = -qidep(iice)
3246 qisub(iice) = qisub(iice)*clbfact_sub
3247 qisub(iice) = min(qisub(iice), qitot(i,k,iice)*odt)
3248 nisub(iice) = qisub(iice)*(nitot(i,k,iice)/qitot(i,k,iice))
3249 qidep(iice) = 0.
3250 else
3251 qidep(iice) = qidep(iice)*clbfact_dep
3252 qidep(iice) = min(qidep(iice), qv(i,k)*odt)
3253 endif
3255 enddo iice_loop_depsub
3257 444 continue
3260 !................................................................
3261 ! deposition/condensation-freezing nucleation
3262 ! (allow ice nucleation if T < -15 C and > 5% ice supersaturation)
3264 if (.not. scpf_ON) then
3265 sup_cld = sup(i,k)
3266 supi_cld = supi(i,k)
3267 else
3268 supi_cld= Qv_cld(k)/qvi(i,k)-1.!in-cloud sub/sur-saturation w.r.t. ice in %
3269 sup_cld = Qv_cld(k)/qvs(i,k)-1.!in-cloud sub/sur-saturation w.r.t. liq in %
3270 endif
3272 if (t(i,k).lt.258.15 .and. supi_cld.ge.0.05) then
3273 ! dum = exp(-0.639+0.1296*100.*supi(i,k))*1000.*inv_rho(i,k) !Meyers et al. (1992)
3274 dum = 0.005*exp(0.304*(273.15-t(i,k)))*1000.*inv_rho(i,k) !Cooper (1986)
3275 ! dum = 0.005*dexp(dble(0.304*(273.15-t(i,k))))*1000.*inv_rho(i,k) !Cooper (1986)
3276 dum = min(dum,100.e3*inv_rho(i,k)*SCF(k))
3277 N_nuc = max(0.,(dum-sum(nitot(i,k,:)))*odt)
3279 if (N_nuc.ge.1.e-20) then
3280 Q_nuc = max(0.,(dum-sum(nitot(i,k,:)))*mi0*odt)
3281 if (nCat>1) then
3282 !determine destination ice-phase category:
3283 dum1 = 900. !density of new ice
3284 D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd
3285 call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest)
3286 if (global_status /= STATUS_OK) return
3287 else
3288 iice_dest = 1
3289 endif
3290 qinuc(iice_dest) = Q_nuc
3291 ninuc(iice_dest) = N_nuc
3292 endif
3293 endif
3296 !.................................................................
3297 ! droplet activation
3299 ! for specified Nc, make sure droplets are present if conditions are supersaturated
3300 ! note that this is also applied at the first time step
3301 ! this is not applied at the first time step, since saturation adjustment is applied at the first step
3303 if (.not.(log_predictNc).and.sup_cld.gt.1.e-6.and.it.gt.1) then
3304 dum = nccnst*inv_rho(i,k)*cons7-qc(i,k)
3305 dum = max(0.,dum*iSCF(k)) ! in-cloud value
3306 dumqvs = qv_sat(t(i,k),pres(i,k),0)
3307 dqsdT = xxlv(i,k)*dumqvs/(rv*t(i,k)*t(i,k))
3308 ab = 1. + dqsdT*xxlv(i,k)*inv_cp
3309 dum = max(0.,min(dum,(Qv_cld(k)-dumqvs)/ab)) ! limit overdepletion of supersaturation
3310 qcnuc = dum*odt*SCF(k)
3311 endif
3313 if (log_predictNc) then
3314 ! for predicted Nc, calculate activation explicitly from supersaturation
3315 ! note that this is also applied at the first time step
3316 if (sup_cld.gt.1.e-6) then
3317 dum1 = 1./bact**0.5
3318 sigvl = 0.0761 - 1.55e-4*(t(i,k)-273.15)
3319 aact = 2.*mw/(rhow*rr*t(i,k))*sigvl
3320 sm1 = 2.*dum1*(aact*thrd*inv_rm1)**1.5
3321 sm2 = 2.*dum1*(aact*thrd*inv_rm2)**1.5
3322 uu1 = 2.*log(sm1/sup_cld)/(4.242*log(sig1))
3323 uu2 = 2.*log(sm2/sup_cld)/(4.242*log(sig2))
3324 dum1 = nanew1*0.5*(1.-derf(uu1)) ! activated number in kg-1 mode 1
3325 dum2 = nanew2*0.5*(1.-derf(uu2)) ! activated number in kg-1 mode 2
3326 ! make sure this value is not greater than total number of aerosol
3327 dum2 = min((nanew1+nanew2),dum1+dum2)
3328 dum2 = (dum2-nc(i,k)*iSCF(k))*odt*SCF(k)
3329 dum2 = max(0.,dum2)
3330 ncnuc = dum2
3331 ! don't include mass increase from droplet activation during first time step
3332 ! since this is already accounted for by saturation adjustment below
3333 if (it.le.1) then
3334 qcnuc = 0.
3335 else
3336 qcnuc = ncnuc*cons7
3337 endif
3338 endif
3339 endif
3342 !................................................................
3343 ! saturation adjustment to get initial cloud water
3345 ! This is only called once at the beginning of the simulation
3346 ! to remove any supersaturation in the intial conditions
3348 if (it.le.1) then
3349 dumt = th(i,k)*(pres(i,k)*1.e-5)**(rd*inv_cp)
3350 dumqv = Qv_cld(k)
3351 dumqvs = qv_sat(dumt,pres(i,k),0)
3352 dums = dumqv-dumqvs
3353 qccon = dums/(1.+xxlv(i,k)**2*dumqvs/(cp*rv*dumt**2))*odt*SCF(k)
3354 qccon = max(0.,qccon)
3355 if (qccon.le.1.e-7) qccon = 0.
3356 endif
3359 !................................................................
3360 ! autoconversion
3362 qc_not_small_1: if (qc(i,k)*iSCF(k).ge.1.e-8) then
3364 if (iparam.eq.1) then
3366 !Seifert and Beheng (2001)
3367 dum = 1.-qc(i,k)*iSCF(k)/(qc(i,k)*iSCF(k)+qr(i,k)*iSPF(k)*(SPF(k)-SPF_clr(k)))
3368 dum1 = 600.*dum**0.68*(1.-dum**0.68)**3
3369 qcaut = kc*1.9230769e-5*(nu(i,k)+2.)*(nu(i,k)+4.)/(nu(i,k)+1.)**2* &
3370 (rho(i,k)*qc(i,k)*iSCF(k)*1.e-3)**4/ &
3371 (rho(i,k)*nc(i,k)*iSCF(k)*1.e-6)**2*(1.+ &
3372 dum1/(1.-dum)**2)*1000.*inv_rho(i,k)*SCF(k)
3373 ncautc = qcaut*7.6923076e+9
3375 elseif (iparam.eq.2) then
3377 !Beheng (1994)
3378 if (nc(i,k)*iSCF(k)*rho(i,k)*1.e-6 .lt. 100.) then
3379 qcaut = 6.e+28*inv_rho(i,k)*mu_c(i,k)**(-1.7)*(1.e-6*rho(i,k)* &
3380 nc(i,k)*iSCF(k))**(-3.3)*(1.e-3*rho(i,k)*qc(i,k)*iSCF(k))**(4.7) &
3381 *SCF(k)
3382 else
3383 !2D interpolation of tabled logarithmic values
3384 dum = 41.46 + (nc(i,k)*iSCF(k)*1.e-6*rho(i,k)-100.)*(37.53-41.46)*5.e-3
3385 dum1 = 39.36 + (nc(i,k)*iSCF(k)*1.e-6*rho(i,k)-100.)*(30.72-39.36)*5.e-3
3386 qcaut = dum+(mu_c(i,k)-5.)*(dum1-dum)*0.1
3387 ! 1000/rho is for conversion from g cm-3/s to kg/kg
3388 qcaut = exp(qcaut)*(1.e-3*rho(i,k)*qc(i,k)*iSCF(k))**4.7*1000.*inv_rho(i,k)*SCF(k)
3389 ! qcaut = dexp(dble(qcaut))*(1.e-3*rho(i,k)*qc(i,k)*iSCF(k))**4.7*1000.* &
3390 ! inv_rho(i,k)*SCF(k)
3391 endif
3392 ncautc = 7.7e+9*qcaut
3394 elseif (iparam.eq.3) then
3396 !Khroutdinov and Kogan (2000)
3397 dum = qc(i,k)*iSCF(k)
3398 qcaut = 1350.*dum**2.47*(nc(i,k)*iSCF(k)*1.e-6*rho(i,k))**(-1.79)*SCF(k)
3399 ! note: ncautr is change in Nr; ncautc is change in Nc
3400 ncautr = qcaut*cons3
3401 ncautc = qcaut*nc(i,k)/qc(i,k)
3403 elseif (iparam.eq.4) then
3405 !Kogan (2013)
3406 dum = qc(i,k)*iSCF(k)
3407 qcaut = 7.98e10*dum**4.22*(nc(i,k)*iSCF(k)*1.e-6*rho(i,k))**(-3.01)*SCF(k)
3408 ncautr = qcaut*cons8
3409 ncautc = qcaut*nc(i,k)/qc(i,k)
3411 endif
3413 if (qcaut .eq.0.) ncautc = 0.
3414 if (ncautc.eq.0.) qcaut = 0.
3416 endif qc_not_small_1
3418 !............................
3419 ! self-collection of droplets
3421 if (qc(i,k).ge.qsmall) then
3423 if (iparam.eq.1) then
3424 !Seifert and Beheng (2001)
3425 ncslf = -kc*(1.e-3*rho(i,k)*qc(i,k)*iSCF(k))**2*(nu(i,k)+2.)/(nu(i,k)+1.)* &
3426 1.e+6*inv_rho(i,k)*SCF(k)+ncautc
3427 elseif (iparam.eq.2) then
3428 !Beheng (994)
3429 ncslf = -5.5e+16*inv_rho(i,k)*mu_c(i,k)**(-0.63)*(1.e-3*rho(i,k)*qc(i,k)*iSCF(k))**2*SCF(k)
3430 elseif (iparam.eq.3.or.iparam.eq.4) then
3431 !Khroutdinov and Kogan (2000)
3432 ncslf = 0.
3433 endif
3435 endif
3437 !............................
3438 ! accretion of cloud by rain
3440 if (qr(i,k).ge.qsmall .and. qc(i,k).ge.qsmall) then
3442 if (iparam.eq.1) then
3443 !Seifert and Beheng (2001)
3444 dum2 = (SPF(k)-SPF_clr(k)) !in-cloud Precipitation fraction
3445 dum = 1.-qc(i,k)*iSCF(k)/(qc(i,k)*iSCF(k)+qr(i,k)*iSPF(k))
3446 dum1 = (dum/(dum+5.e-4))**4
3447 qcacc = kr*rho(i,k)*0.001*qc(i,k)*iSCF(k)*qr(i,k)*iSPF(k)*dum1*dum2
3448 ncacc = qcacc*rho(i,k)*0.001*(nc(i,k)*rho(i,k)*1.e-6)/(qc(i,k)*rho(i,k)* & !note: (nc*iSCF)/(qc*iSCF) = nc/qc
3449 0.001)*1.e+6*inv_rho(i,k)
3450 elseif (iparam.eq.2) then
3451 !Beheng (994)
3452 dum2 = (SPF(k)-SPF_clr(k)) !in-cloud Precipitation fraction
3453 dum = (qc(i,k)*iSCF(k)*qr(i,k)*iSPF(k))
3454 qcacc = 6.*rho(i,k)*dum*dum2
3455 ncacc = qcacc*rho(i,k)*1.e-3*(nc(i,k)*rho(i,k)*1.e-6)/(qc(i,k)*rho(i,k)* & !note: (nc*iSCF)/(qc*iSCF) = nc/qc
3456 1.e-3)*1.e+6*inv_rho(i,k)
3457 elseif (iparam.eq.3) then
3458 !Khroutdinov and Kogan (2000)
3459 dum2 = (SPF(k)-SPF_clr(k)) !in-cloud Precipitation fraction
3460 qcacc = 67.*(qc(i,k)*iSCF(k)*qr(i,k)*iSPF(k))**1.15 *dum2
3461 ncacc = qcacc*nc(i,k)/qc(i,k)
3462 elseif (iparam.eq.4) then
3463 !Kogan (2013)
3464 dum2 = (SPF(k)-SPF_clr(k)) !in-cloud Precipitation fraction
3465 qcacc = 8.53*(qc(i,k)*iSCF(k))**1.05*(qr(i,k)*iSPF(k))**0.98 *dum2
3466 ncacc = qcacc*nc(i,k)/qc(i,k)
3467 endif
3469 if (qcacc.eq.0.) ncacc = 0.
3470 if (ncacc.eq.0.) qcacc = 0.
3472 endif
3474 !.....................................
3475 ! self-collection and breakup of rain
3476 ! (breakup following modified Verlinde and Cotton scheme)
3478 if (qr(i,k).ge.qsmall) then
3480 ! include breakup
3481 dum1 = 280.e-6
3482 nr(i,k) = max(nr(i,k),nsmall)
3483 ! use mass-mean diameter (do this by using
3484 ! the old version of lambda w/o mu dependence)
3485 ! note there should be a factor of 6^(1/3), but we
3486 ! want to keep breakup threshold consistent so 'dum'
3487 ! is expressed in terms of lambda rather than mass-mean D
3488 dum2 = (qr(i,k)/(pi*rhow*nr(i,k)))**thrd
3489 if (dum2.lt.dum1) then
3490 dum = 1.
3491 else if (dum2.ge.dum1) then
3492 dum = 2.-exp(2300.*(dum2-dum1))
3493 ! dum = 2.-dexp(dble(2300.*(dum2-dum1)))
3494 endif
3496 if (iparam.eq.1.) then
3497 nrslf = dum*kr*1.e-3*qr(i,k)*iSPF(k)*nr(i,k)*iSPF(k)*rho(i,k)*SPF(k)
3498 elseif (iparam.eq.2 .or. iparam.eq.3) then
3499 nrslf = dum*5.78*nr(i,k)*iSPF(k)*qr(i,k)*iSPF(k)*rho(i,k)*SPF(k)
3500 elseif (iparam.eq.4) then
3501 nrslf = dum*205.*(qr(i,k)*iSPF(k))**1.55*(nr(i,k)*1.e-6*rho(i,k)*iSPF(k))**0.6*1.e6/rho(i,k)*SPF(k) ! 1.e6 converts cm-3 to m-3
3502 endif
3504 endif
3507 !.................................................................
3508 ! conservation of mass
3509 !
3510 ! The microphysical process rates are computed above, based on the environmental conditions.
3511 ! The rates are adjusted here (where necessary) such that the sum of the sinks of mass cannot
3512 ! be greater than the sum of the sources, thereby resulting in overdepletion.
3514 !Limit total condensation (incl. activation) and evaporation to saturation adjustment
3515 dumqvs = qv_sat(t(i,k),pres(i,k),0)
3516 qcon_satadj = (Qv_cld(k)-dumqvs)/(1.+xxlv(i,k)**2*dumqvs/(cp*rv*t(i,k)**2))*odt*SCF(k)
3518 tmp1 = qccon+qrcon+qcnuc
3519 if (tmp1>0. .and. qcon_satadj<0.) then
3520 qccon = 0.
3521 qrcon = 0.
3522 qcnuc = 0.
3523 ncnuc = 0.
3524 else
3525 if (tmp1.gt.0. .and. tmp1.gt.qcon_satadj) then
3526 ratio = max(0.,qcon_satadj)/tmp1
3527 ratio = min(1.,ratio)
3528 qccon = qccon*ratio
3529 qrcon = qrcon*ratio
3530 qcnuc = qcnuc*ratio
3531 ncnuc = ncnuc*ratio
3532 elseif (qcevp+qrevp.gt.0.) then
3533 ratio = max(0.,-qcon_satadj)/(qcevp+qrevp)
3534 ratio = min(1.,ratio)
3535 qcevp = qcevp*ratio
3536 qrevp = qrevp*ratio
3537 nrevp = nrevp*ratio
3538 endif
3539 endif
3541 !Limit total deposition (incl. nucleation) and sublimation to saturation adjustment
3542 qv_tmp = Qv_cld(k) + (-qcnuc-qccon-qrcon+qcevp+qrevp)*dt !qv after cond/evap
3543 t_tmp = t(i,k) + (qcnuc+qccon+qrcon-qcevp-qrevp)*xxlv(i,k)*inv_cp*dt !T after cond/evap
3544 dumqvi = qv_sat(t_tmp,pres(i,k),1)
3545 qdep_satadj = (qv_tmp-dumqvi)/(1.+xxls(i,k)**2*dumqvi/(cp*rv*t_tmp**2))*odt*SCF(k)
3547 tmp1 = sum(qidep)+sum(qinuc)
3548 if (tmp1>0. .and. qdep_satadj<0.) then
3549 qidep = 0.
3550 qinuc = 0.
3551 ninuc = 0.
3552 else
3553 if (tmp1.gt.0. .and. tmp1.gt.qdep_satadj) then
3554 ratio = max(0.,qdep_satadj)/tmp1
3555 ratio = min(1.,ratio)
3556 qidep = qidep*ratio
3557 qinuc = qinuc*ratio
3558 ninuc = ninuc*ratio
3559 endif
3560 do iice = 1,nCat
3561 dum = max(qisub(iice),1.e-20)
3562 qisub(iice) = qisub(iice)*min(1.,max(0.,-qdep_satadj)/max(sum(qisub), 1.e-20)) !optimized (avoids IF(qisub.gt.0.) )
3563 nisub(iice) = nisub(iice)*min(1.,qisub(iice)/dum)
3564 enddo
3565 !qchetc = qchetc*min(1.,qc(i,k)*odt/max(sum(qchetc),1.e-20)) !currently not used
3566 !qrhetc = qrhetc*min(1.,qr(i,k)*odt/max(sum(qrhetc),1.e-20)) !currently not used
3567 endif
3570 ! cloud
3571 sinks = (qcaut+qcacc+sum(qccol)+qcevp+sum(qchetc)+sum(qcheti)+sum(qcshd))*dt
3572 sources = qc(i,k) + (qccon+qcnuc)*dt
3573 if (sinks.gt.sources .and. sinks.ge.1.e-20) then
3574 ratio = sources/sinks
3575 qcaut = qcaut*ratio
3576 qcacc = qcacc*ratio
3577 qcevp = qcevp*ratio
3578 qccol = qccol*ratio
3579 qcheti = qcheti*ratio
3580 qcshd = qcshd*ratio
3581 !if (log_predictNc) then
3582 ! note: the conditional is present for strict code logic but commented for efficiency
3583 ! (4 multiplications, even if values are not used [if log_predictNc=.false.], are cheaper than one IF)
3584 ncautc = ncautc*ratio
3585 ncacc = ncacc*ratio
3586 nccol = nccol*ratio
3587 ncheti = ncheti*ratio
3588 !nchetc = nchetc*ratio
3589 !endif
3590 endif
3592 ! rain
3593 sinks = (qrevp+sum(qrcol)+sum(qrhetc)+sum(qrheti)+sum(qrmul))*dt
3594 sources = qr(i,k) + (qrcon+qcaut+qcacc+sum(qimlt)+sum(qcshd))*dt
3595 if (sinks.gt.sources .and. sinks.ge.1.e-20) then
3596 ratio = sources/sinks
3597 qrevp = qrevp*ratio
3598 qrcol = qrcol*ratio
3599 qrheti = qrheti*ratio
3600 qrmul = qrmul*ratio
3601 nrevp = nrevp*ratio
3602 nrcol = nrcol*ratio
3603 nrheti = nrheti*ratio
3604 !qrhetc = qrhetc*ratio
3605 !nrhetc = nrhetc*ratio
3606 endif
3608 ! ice
3609 do iice = 1,nCat
3610 sinks = (qisub(iice)+qimlt(iice))*dt
3611 sources = qitot(i,k,iice) + (qidep(iice)+qinuc(iice)+qrcol(iice)+qccol(iice)+ &
3612 qrhetc(iice)+qrheti(iice)+qchetc(iice)+qcheti(iice)+qrmul(iice))*dt
3613 do catcoll = 1,nCat
3614 !category interaction leading to source for iice category
3615 sources = sources + qicol(catcoll,iice)*dt
3616 !category interaction leading to sink for iice category
3617 sinks = sinks + qicol(iice,catcoll)*dt
3618 enddo
3619 if (sinks.gt.sources .and. sinks.ge.1.e-20) then
3620 ratio = sources/sinks
3621 qisub(iice) = qisub(iice)*ratio
3622 qimlt(iice) = qimlt(iice)*ratio
3623 nisub(iice) = nisub(iice)*ratio
3624 nimlt(iice) = nimlt(iice)*ratio
3625 do catcoll = 1,nCat
3626 qicol(iice,catcoll) = qicol(iice,catcoll)*ratio
3627 nicol(iice,catcoll) = nicol(iice,catcoll)*ratio
3628 enddo
3629 endif
3630 enddo !iice-loop
3632 ! vapor
3633 sinks = (qccon+qrcon+qcnuc+sum(qidep)+sum(qinuc))*dt
3634 sources = qv(i,k) + (qcevp+qrevp+sum(qisub))*dt
3635 if (sinks.gt.sources .and. sinks.ge.1.e-20) then
3636 ratio = sources/sinks
3637 qccon = qccon*ratio
3638 qrcon = qrcon*ratio
3639 qcnuc = qcnuc*ratio
3640 qidep = qidep*ratio
3641 qinuc = qinuc*ratio
3642 ninuc = ninuc*ratio
3643 ncnuc = ncnuc*ratio
3644 endif
3646 !------------------------------------------------------------------------------------------!
3647 ! Update ice reflectivity
3649 ! At this point, we have the values of prognostic variables at beginning of time step,
3650 ! the value of all process rates for qitot and nitot
3652 update_refl_processes: if (log_3momentIce) then
3654 iice_loop_z1: do iice = 1,nCat
3656 !---- Group 1 process rates (assume mu_i does not change)
3657 !
3658 ! upated value of zitot is computed for these processes
3660 !-- compute "updated" values of qitot and nitot (used here only)
3661 ! NOTE: must add qicol in line below for combining 3-moment with multi-cat P3
3662 dumm3(iice) = qitot(i,k,iice) + ( qidep(iice)+qrcol(iice)+qccol(iice)+ &
3663 qrmul(iice)-qisub(iice)-qimlt(iice) )*dt
3664 ! NOTE: must add nicol in line below for combining 3-moment with multi-cat P3
3665 dumm0(iice) = nitot(i,k,iice) + (-nimlt(iice)-nisub(iice)+nimul(iice)-nislf(iice) )*dt
3667 enddo iice_loop_z1
3668 !====
3669 iice_loop_z2: do iice = 1,nCat
3671 !update further due to category interactions:
3672 do catcoll = 1,nCat
3673 dumm3(catcoll) = dumm3(catcoll) - qicol(catcoll,iice)*dt
3674 dumm3(iice) = dumm3(iice) + qicol(catcoll,iice)*dt
3675 dumm0(catcoll) = dumm0(catcoll) - nicol(catcoll,iice)*dt
3676 enddo ! catcoll loop
3678 if (dumm3(iice).ge.qsmall) then
3680 !estimate moment3 from updated qitot (dum2).
3681 if (qitot(i,k,iice).ge.qsmall) then
3682 !need to use mean ice density (f1pr16) from beginning of step, since the updated value is not available
3683 dumm3(iice) = 6./(f1pr16*pi)*dumm3(iice)
3684 else
3685 !if there is no existing ice, assume an ice density of 900 kg m-3
3686 dumm3(iice) = 6./(900.*pi)*dumm3(iice)
3687 endif
3689 !solve or assign for mu_i (to be used to compute updated zitot)
3690 if (qitot(i,k,iice).ge.qsmall) then
3691 !solve for mu_i from values of mom0,mom3,mom6 at beginning of time step
3692 dum1 = 6./(f1pr16*pi)*qitot(i,k,iice) !estimate of moment3
3693 mu_i = compute_mu_3moment(nitot(i,k,iice),dum1,zitot(i,k,iice),mu_i_max)
3694 else
3695 !no ice present, therefore assign an initial value
3696 mu_i = mu_i_initial
3697 endif
3699 !compute zitot as a function of (old) mu_i and the "updated" moment_0 (dumm0) and moment_3 (dumm3)
3700 zitot(i,k,iice) = G_of_mu(mu_i)*dumm3(iice)**2/max(dumm0(iice),nsmall)
3702 else
3703 zitot(i,k,iice) = 0.
3704 endif
3706 !====
3708 !---- Group 2 (initiation processes, where mu_i for the new ice resulting from that process (only) is assigned
3709 ! note: mu_i_new is the mu_i associated with the new added ice for that process
3711 !proceses with rain freezing:
3712 tmp2 = nrhetc(iice) + nrheti(iice) !moment_0 tendency
3713 if (tmp2.ge.qsmall) then
3714 tmp1 = (qrhetc(iice) + qrheti(iice))*6./(900.*pi) !estimate of moment_3 tendency
3715 mu_i_new = mu_r(i,k)
3716 zitot(i,k,iice) = zitot(i,k,iice) + G_of_mu(mu_i_new)*tmp1**2/tmp2*dt
3717 endif
3719 !proceses with cloud freezing:
3720 tmp2 = nchetc(iice) + ncheti(iice) !moment_0 tendency
3721 if (tmp2.ge.qsmall) then
3722 tmp1 = (qchetc(iice) + qcheti(iice))*6./(900.*pi) !estimate of moment_3 tendency
3723 mu_i_new = mu_c(i,k)
3724 zitot(i,k,iice) = zitot(i,k,iice) + G_of_mu(mu_i_new)*tmp1**2/tmp2*dt
3725 endif
3727 !proceses of deposition nucleation
3728 tmp2 = ninuc(iice) !moment_0 tendency
3729 if (tmp2.ge.qsmall) then
3730 tmp1 = qinuc(iice)*6./(900.*pi) !estimate of moment_3 tendency
3731 mu_i_new = mu_i_initial !estimated assigned value
3732 zitot(i,k,iice) = zitot(i,k,iice) + G_of_mu(mu_i_new)*tmp1**2/tmp2*dt
3733 endif
3735 !====
3737 !---- Group 3 -- processes that we know how to do formally
3738 ! FUTURE. e.g. diffusional growth, riming, drop freezing
3739 !====
3741 end do iice_loop_z2
3743 endif update_refl_processes
3745 ! at this point, zitot has been completely updated due to all process rates (except sedimentation)
3747 !======================================================================================!
3750 !---------------------------------------------------------------------------------
3751 ! update prognostic microphysics and thermodynamics variables
3752 !---------------------------------------------------------------------------------
3754 !-- ice-phase dependent processes:
3756 iice_loop2: do iice = 1,nCat
3758 ! compute fractions before update (assumed constant during ice-ice coll.)
3759 if (qitot(i,k,iice).ge.qsmall) then
3760 tmp1 = 1./qitot(i,k,iice)
3761 rimevolume(i,k,iice) = birim(i,k,iice)*tmp1
3762 rimefraction(i,k,iice) = qirim(i,k,iice)*tmp1
3763 endif
3765 enddo iice_loop2
3767 iice_loop3: do iice = 1,nCat
3769 qc(i,k) = qc(i,k) + (-qchetc(iice)-qcheti(iice)-qccol(iice)-qcshd(iice))*dt
3770 if (log_predictNc) then
3771 nc(i,k) = nc(i,k) + (-nccol(iice)-nchetc(iice)-ncheti(iice))*dt
3772 endif
3774 qr(i,k) = qr(i,k) + (-qrcol(iice)+qimlt(iice)-qrhetc(iice)-qrheti(iice)+ &
3775 qcshd(iice)-qrmul(iice))*dt
3776 ! apply factor to source for rain number from melting of ice, (ad-hoc
3777 ! but accounts for rapid evaporation of small melting ice particles)
3778 nr(i,k) = nr(i,k) + (-nrcol(iice)-nrhetc(iice)-nrheti(iice)+nmltratio*nimlt(iice)+ &
3779 nrshdr(iice)+ncshdc(iice))*dt
3781 ! if (qitot(i,k,iice).ge.qsmall) then
3782 ! add sink terms, assume density stays constant for sink terms
3783 birim(i,k,iice) = birim(i,k,iice) - ((qisub(iice)+qimlt(iice))*dt* &
3784 rimevolume(i,k,iice))
3785 qirim(i,k,iice) = qirim(i,k,iice) - ((qisub(iice)+qimlt(iice))*dt* &
3786 rimefraction(i,k,iice))
3787 qitot(i,k,iice) = qitot(i,k,iice) - (qisub(iice)+qimlt(iice))*dt
3788 ! endif
3790 dum = (qrcol(iice)+qccol(iice)+qrhetc(iice)+qrheti(iice)+ &
3791 qchetc(iice)+qcheti(iice)+qrmul(iice))*dt
3792 qitot(i,k,iice) = qitot(i,k,iice) + (qidep(iice)+qinuc(iice))*dt + dum
3793 qirim(i,k,iice) = qirim(i,k,iice) + dum
3794 birim(i,k,iice) = birim(i,k,iice) + (qrcol(iice)*inv_rho_rimeMax+qccol(iice)/ &
3795 rhorime_c(iice)+(qrhetc(iice)+qrheti(iice)+qchetc(iice)+ &
3796 qcheti(iice)+qrmul(iice))*inv_rho_rimeMax)*dt
3797 nitot(i,k,iice) = nitot(i,k,iice) + (ninuc(iice)-nimlt(iice)-nisub(iice)- &
3798 nislf(iice)+nrhetc(iice)+nrheti(iice)+nchetc(iice)+ &
3799 ncheti(iice)+nimul(iice))*dt
3801 if (nCat.gt.1) then
3802 interactions_loop: do catcoll = 1,nCat
3803 diff_categories: if (iice.ne.catcoll) then
3804 ! add ice-ice category interaction collection tendencies
3805 ! note: nicol is a sink for the collectee category, but NOT a source for collector
3806 ! modify rime mass and density, assume collection does not modify rime mass
3807 ! fraction or density of the collectee, consistent with the assumption that
3808 ! these are constant over the PSD
3809 if (qitot(i,k,catcoll).ge.qsmall) then
3810 !source for collector category
3811 qirim(i,k,iice) = qirim(i,k,iice)+qicol(catcoll,iice)*dt* &
3812 rimefraction(i,k,catcoll)
3813 birim(i,k,iice) = birim(i,k,iice)+qicol(catcoll,iice)*dt* &
3814 rimevolume(i,k,catcoll)
3815 !sink for collectee category
3816 qirim(i,k,catcoll) = qirim(i,k,catcoll)-qicol(catcoll,iice)*dt* &
3817 rimefraction(i,k,catcoll)
3818 birim(i,k,catcoll) = birim(i,k,catcoll)-qicol(catcoll,iice)*dt* &
3819 rimevolume(i,k,catcoll)
3820 endif
3821 qitot(i,k,catcoll) = qitot(i,k,catcoll) - qicol(catcoll,iice)*dt
3822 nitot(i,k,catcoll) = nitot(i,k,catcoll) - nicol(catcoll,iice)*dt
3823 qitot(i,k,iice) = qitot(i,k,iice) + qicol(catcoll,iice)*dt
3825 endif diff_categories
3826 enddo interactions_loop ! catcoll loop
3827 endif
3829 if (qirim(i,k,iice).lt.0.) then
3830 qirim(i,k,iice) = 0.
3831 birim(i,k,iice) = 0.
3832 endif
3834 ! densify ice during wet growth (assume total soaking)
3835 if (log_wetgrowth(iice)) then
3836 qirim(i,k,iice) = qitot(i,k,iice)
3837 birim(i,k,iice) = qirim(i,k,iice)*inv_rho_rimeMax
3838 endif
3840 ! densify rimed ice during melting (tend rime density towards solid ice [917 kg m-3])
3841 if (qitot(i,k,iice).ge.qsmall .and. birim(i,k,iice).ge.bsmall .and. qimlt(iice)>0.) then
3842 tmp1 = qirim(i,k,iice)/birim(i,k,iice) ! rho_i before densification
3843 tmp2 = qitot(i,k,iice) + qimlt(iice)*dt ! qitot before melting (but after all other updates)
3844 birim(i,k,iice) = qirim(i,k,iice)/(tmp1+(917.-tmp1)*qimlt(iice)*dt/tmp2)
3845 endif
3847 ! densify in above freezing conditions and melting
3848 ! -- future work --
3849 ! Ideally, this will be treated with the predicted liquid fraction in ice.
3850 ! Alternatively, it can be simplified by tending qirim -- qitot
3851 ! and birim such that rho_rim (qirim/birim) --> rho_liq during melting.
3852 ! ==
3854 qv(i,k) = qv(i,k) + (-qidep(iice)+qisub(iice)-qinuc(iice))*dt
3856 ! Update theta. Note temperature is not updated here even though it is used below for
3857 ! the homogeneous freezing threshold. This is done for simplicity - the error will be
3858 ! very small and the homogeneous temp. freezing threshold is approximate anyway.
3859 th(i,k) = th(i,k) + invexn(i,k)*((qidep(iice)-qisub(iice)+qinuc(iice))* &
3860 xxls(i,k)*inv_cp +(qrcol(iice)+qccol(iice)+qchetc(iice)+ &
3861 qcheti(iice)+qrhetc(iice)+qrheti(iice)+ &
3862 qrmul(iice)-qimlt(iice))* &
3863 xlf(i,k)*inv_cp)*dt
3865 enddo iice_loop3
3866 !==
3868 !-- warm-phase only processes:
3869 qc(i,k) = qc(i,k) + (-qcacc-qcaut+qcnuc+qccon-qcevp)*dt
3870 qr(i,k) = qr(i,k) + (qcacc+qcaut+qrcon-qrevp)*dt
3872 if (log_predictNc) then
3873 nc(i,k) = nc(i,k) + (-ncacc-ncautc+ncslf+ncnuc)*dt
3874 else
3875 nc(i,k) = nccnst*inv_rho(i,k)
3876 endif
3877 if (iparam.eq.1 .or. iparam.eq.2) then
3878 nr(i,k) = nr(i,k) + (0.5*ncautc-nrslf-nrevp)*dt
3879 else
3880 nr(i,k) = nr(i,k) + (ncautr-nrslf-nrevp)*dt
3881 endif
3883 qv(i,k) = qv(i,k) + (-qcnuc-qccon-qrcon+qcevp+qrevp)*dt
3884 th(i,k) = th(i,k) + invexn(i,k)*((qcnuc+qccon+qrcon-qcevp-qrevp)*xxlv(i,k)* &
3885 inv_cp)*dt
3886 !==
3888 ! clipping for small hydrometeor values
3889 if (qc(i,k).lt.qsmall) then
3890 qv(i,k) = qv(i,k) + qc(i,k)
3891 th(i,k) = th(i,k) - invexn(i,k)*qc(i,k)*xxlv(i,k)*inv_cp
3892 qc(i,k) = 0.
3893 nc(i,k) = 0.
3894 else
3895 log_hydrometeorsPresent = .true.
3896 endif
3898 if (qr(i,k).lt.qsmall) then
3899 qv(i,k) = qv(i,k) + qr(i,k)
3900 th(i,k) = th(i,k) - invexn(i,k)*qr(i,k)*xxlv(i,k)*inv_cp
3901 qr(i,k) = 0.
3902 nr(i,k) = 0.
3903 else
3904 log_hydrometeorsPresent = .true.
3905 endif
3907 do iice = 1,nCat
3908 if (qitot(i,k,iice).lt.qsmall) then
3909 qv(i,k) = qv(i,k) + qitot(i,k,iice)
3910 th(i,k) = th(i,k) - invexn(i,k)*qitot(i,k,iice)*xxls(i,k)*inv_cp
3911 qitot(i,k,iice) = 0.
3912 nitot(i,k,iice) = 0.
3913 qirim(i,k,iice) = 0.
3914 birim(i,k,iice) = 0.
3915 else
3916 log_hydrometeorsPresent = .true.
3917 endif
3918 enddo !iice-loop
3920 qv(i,k) = max(0., qv(i,k))
3921 call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k))
3923 !---------------------------------------------------------------------------------
3925 555 continue
3927 enddo k_loop_main
3929 !-- for sedimentation-only tests:
3930 ! 6969 continue
3931 ! log_hydrometeorsPresent = .true.
3932 !==
3934 !......................................
3935 ! zero out zitot if there is no qitot for triple moment
3936 if (log_3momentIce) then
3937 do iice = 1,nCat
3938 do k = kbot,ktop,kdir
3939 if (qitot(i,k,iice).lt.qsmall) zitot(i,k,iice) = 0.
3940 enddo
3941 enddo
3942 endif
3943 !.......................................
3946 !NOTE: At this point, it is possible to have negative (but small) nc, nr, nitot. This is not
3947 ! a problem; those values get clipped to zero or assigned a minumum value in the sedimentation
3948 ! section, immediately below (if necessary). Similarly, for 3-moment-ice it is possible at this
3949 ! point to have zitot=0 but qitot slightly larger than qsmall; in sedimentation non-zero zitot
3950 ! is computed (if necessary) by applying the constraints on mu_i.
3952 if (debug_on) then
3953 location_ind = 300
3954 force_abort = debug_ABORT
3955 tmparr1(i,:) = th(i,:)*(pres(i,:)*1.e-5)**(rd*inv_cp)
3956 if (log_3momentIce) then
3957 call check_values(qv(i,:),tmparr1(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
3958 qirim(i,:,:),nitot(i,:,:),birim(i,:,:),i,it,force_abort,location_ind, &
3959 Zitot=zitot(i,:,:))
3960 else
3961 call check_values(qv(i,:),tmparr1(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
3962 qirim(i,:,:),nitot(i,:,:),birim(i,:,:),i,it,force_abort,location_ind)
3963 endif
3964 if (global_status /= STATUS_OK) return
3965 endif
3967 !second call to compute_SCPF
3968 call compute_SCPF(Qc(i,:)+sum(Qitot(i,:,:),dim=2),Qr(i,:),Qv(i,:),Qvi(i,:), &
3969 Pres(i,:),ktop,kbot,kdir,SCF,iSCF,SPF,iSPF,SPF_clr,Qv_cld,Qv_clr, &
3970 SCPF_on,scpf_pfrac,scpf_resfact,quick=.false.)
3972 if (.not. log_hydrometeorsPresent) goto 333
3974 !------------------------------------------------------------------------------------------!
3975 ! End of main microphysical processes section
3976 !==========================================================================================!
3978 !==========================================================================================!
3979 ! Sedimentation:
3981 !------------------------------------------------------------------------------------------!
3982 ! Cloud sedimentation: (adaptivive substepping)
3984 log_qxpresent = .false.
3985 k_qxtop = kbot
3987 !find top, determine qxpresent
3988 do k = ktop,kbot,-kdir
3989 if (qc(i,k)*iSCF(k).ge.qsmall) then
3990 log_qxpresent = .true.
3991 k_qxtop = k
3992 exit
3993 endif
3994 enddo
3996 qc_present: if (log_qxpresent) then
3998 dt_left = dt !time remaining for sedi over full model (mp) time step
3999 prt_accum = 0. !precip rate for individual category
4001 !find bottom
4002 do k = kbot,k_qxtop,kdir
4003 if (qc(i,k)*iSCF(k).ge.qsmall) then
4004 k_qxbot = k
4005 exit
4006 endif
4007 enddo
4009 two_moment: if (log_predictNc) then !2-moment cloud:
4011 substep_sedi_c2: do while (dt_left.gt.1.e-4)
4013 Co_max = 0.
4014 V_qc(:) = 0.
4015 V_nc(:) = 0.
4017 kloop_sedi_c2: do k = k_qxtop,k_qxbot,-kdir
4019 if (qc(i,k)*iSCF(k)>qsmall) then
4020 call get_cloud_dsd2(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu, &
4021 lamc(i,k),lammin,lammax,tmp1,tmp2,iSCF(k))
4022 dum = 1./lamc(i,k)**bcn
4023 V_qc(k) = acn(i,k)*gamma(4.+bcn+mu_c(i,k))*dum/(gamma(mu_c(i,k)+4.))
4024 V_nc(k) = acn(i,k)*gamma(1.+bcn+mu_c(i,k))*dum/(gamma(mu_c(i,k)+1.))
4025 endif
4027 Co_max = max(Co_max, V_qc(k)*dt_left*inv_dzq(i,k))
4029 enddo kloop_sedi_c2
4031 !-- compute dt_sub
4032 tmpint1 = int(Co_max+1.) !number of substeps remaining if dt_sub were constant
4033 dt_sub = min(dt_left, dt_left/float(tmpint1))
4035 if (k_qxbot.eq.kbot) then
4036 k_temp = k_qxbot
4037 else
4038 k_temp = k_qxbot-kdir
4039 endif
4041 !-- calculate fluxes
4042 do k = k_temp,k_qxtop,kdir
4043 flux_qx(k) = V_qc(k)*qc(i,k)*rho(i,k)
4044 flux_nx(k) = V_nc(k)*nc(i,k)*rho(i,k)
4045 enddo
4047 !accumulated precip during time step
4048 if (k_qxbot.eq.kbot) prt_accum = prt_accum + flux_qx(kbot)*dt_sub
4049 !or, optimized: prt_accum = prt_accum - (k_qxbot.eq.kbot)*dt_sub
4051 !-- for top level only (since flux is 0 above)
4052 k = k_qxtop
4053 fluxdiv_qx = -flux_qx(k)*inv_dzq(i,k)
4054 fluxdiv_nx = -flux_nx(k)*inv_dzq(i,k)
4055 qc(i,k) = qc(i,k) + fluxdiv_qx*dt_sub*inv_rho(i,k)
4056 nc(i,k) = nc(i,k) + fluxdiv_nx*dt_sub*inv_rho(i,k)
4058 do k = k_qxtop-kdir,k_temp,-kdir
4059 fluxdiv_qx = (flux_qx(k+kdir) - flux_qx(k))*inv_dzq(i,k)
4060 fluxdiv_nx = (flux_nx(k+kdir) - flux_nx(k))*inv_dzq(i,k)
4061 qc(i,k) = qc(i,k) + fluxdiv_qx*dt_sub*inv_rho(i,k)
4062 nc(i,k) = nc(i,k) + fluxdiv_nx*dt_sub*inv_rho(i,k)
4063 enddo
4065 dt_left = dt_left - dt_sub !update time remaining for sedimentation
4066 if (k_qxbot.ne.kbot) k_qxbot = k_qxbot - kdir
4068 enddo substep_sedi_c2
4070 else !1-moment cloud:
4072 substep_sedi_c1: do while (dt_left.gt.1.e-4)
4074 Co_max = 0.
4075 V_qc(:) = 0.
4077 kloop_sedi_c1: do k = k_qxtop,k_qxbot,-kdir
4079 if (qc(i,k)*iSCF(k)>qsmall) then
4080 call get_cloud_dsd2(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu, &
4081 lamc(i,k),lammin,lammax,tmp1,tmp2,iSCF(k))
4082 dum = 1./lamc(i,k)**bcn
4083 V_qc(k) = acn(i,k)*gamma(4.+bcn+mu_c(i,k))*dum/(gamma(mu_c(i,k)+4.))
4084 endif
4086 Co_max = max(Co_max, V_qc(k)*dt_left*inv_dzq(i,k))
4088 enddo kloop_sedi_c1
4090 tmpint1 = int(Co_max+1.) !number of substeps remaining if dt_sub were constant
4091 dt_sub = min(dt_left, dt_left/float(tmpint1))
4093 if (k_qxbot.eq.kbot) then
4094 k_temp = k_qxbot
4095 else
4096 k_temp = k_qxbot-kdir
4097 endif
4099 do k = k_temp,k_qxtop,kdir
4100 flux_qx(k) = V_qc(k)*qc(i,k)*rho(i,k)
4101 enddo
4103 !accumulated precip during time step
4104 if (k_qxbot.eq.kbot) prt_accum = prt_accum + flux_qx(kbot)*dt_sub
4106 !-- for top level only (since flux is 0 above)
4107 k = k_qxtop
4108 fluxdiv_qx = -flux_qx(k)*inv_dzq(i,k)
4109 qc(i,k) = qc(i,k) + fluxdiv_qx*dt_sub*inv_rho(i,k)
4111 do k = k_qxtop-kdir,k_temp,-kdir
4112 fluxdiv_qx = (flux_qx(k+kdir) - flux_qx(k))*inv_dzq(i,k)
4113 qc(i,k) = qc(i,k) + fluxdiv_qx*dt_sub*inv_rho(i,k)
4114 enddo
4116 dt_left = dt_left - dt_sub !update time remaining for sedimentation
4117 if (k_qxbot.ne.kbot) k_qxbot = k_qxbot - kdir
4119 enddo substep_sedi_c1
4121 ENDIF two_moment
4123 prt_liq(i) = prt_accum*inv_rhow*odt !note, contribution from rain is added below
4125 endif qc_present
4128 !------------------------------------------------------------------------------------------!
4129 ! Rain sedimentation: (adaptivive substepping)
4131 log_qxpresent = .false.
4132 k_qxtop = kbot
4134 !find top, determine qxpresent
4135 do k = ktop,kbot,-kdir
4136 if (qr(i,k)*iSPF(k).ge.qsmall) then
4137 log_qxpresent = .true.
4138 k_qxtop = k
4139 exit
4140 endif !
4141 enddo
4143 qr_present: if (log_qxpresent) then
4145 dt_left = dt !time remaining for sedi over full model (mp) time step
4146 prt_accum = 0. !precip rate for individual category
4148 !find bottom
4149 do k = kbot,k_qxtop,kdir
4150 if (qr(i,k)*iSPF(k).ge.qsmall) then
4151 k_qxbot = k
4152 exit
4153 endif
4154 enddo
4156 substep_sedi_r: do while (dt_left.gt.1.e-4)
4158 Co_max = 0.
4159 V_qr(:) = 0.
4160 V_nr(:) = 0.
4162 kloop_sedi_r1: do k = k_qxtop,k_qxbot,-kdir
4164 qr_not_small_1: if (qr(i,k)*iSPF(k)>qsmall) then
4166 !Compute Vq, Vn:
4167 nr(i,k) = max(nr(i,k),nsmall)
4168 call get_rain_dsd2(qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),cdistr(i,k), &
4169 logn0r(i,k),iSPF(k))
4171 call find_lookupTable_indices_3(dumii,dumjj,dum1,rdumii,rdumjj,inv_dum3, &
4172 mu_r(i,k),lamr(i,k))
4173 !mass-weighted fall speed:
4174 dum1 = vm_table(dumii,dumjj)+(rdumii-real(dumii))* &
4175 (vm_table(dumii+1,dumjj)-vm_table(dumii,dumjj)) !at mu_r
4176 dum2 = vm_table(dumii,dumjj+1)+(rdumii-real(dumii))* &
4177 (vm_table(dumii+1,dumjj+1)-vm_table(dumii,dumjj+1)) !at mu_r+1
4179 V_qr(k) = dum1 + (rdumjj-real(dumjj))*(dum2-dum1) !interpolated
4180 V_qr(k) = V_qr(k)*rhofacr(i,k) !corrected for air density
4182 ! number-weighted fall speed:
4183 dum1 = vn_table(dumii,dumjj)+(rdumii-real(dumii))* &
4184 (vn_table(dumii+1,dumjj)-vn_table(dumii,dumjj)) !at mu_r
4185 dum2 = vn_table(dumii,dumjj+1)+(rdumii-real(dumii))* &
4186 (vn_table(dumii+1,dumjj+1)-vn_table(dumii,dumjj+1)) !at mu_r+1
4188 V_nr(k) = dum1+(rdumjj-real(dumjj))*(dum2-dum1) !interpolated
4189 V_nr(k) = V_nr(k)*rhofacr(i,k) !corrected for air density
4191 endif qr_not_small_1
4193 Co_max = max(Co_max, V_qr(k)*dt_left*inv_dzq(i,k))
4194 ! Co_max = max(Co_max, max(V_nr(k),V_qr(k))*dt_left*inv_dzq(i,k))
4196 enddo kloop_sedi_r1
4198 !-- compute dt_sub
4199 tmpint1 = int(Co_max+1.) !number of substeps remaining if dt_sub were constant
4200 dt_sub = min(dt_left, dt_left/float(tmpint1))
4202 if (k_qxbot.eq.kbot) then
4203 k_temp = k_qxbot
4204 else
4205 k_temp = k_qxbot-kdir
4206 endif
4208 !-- calculate fluxes
4209 do k = k_temp,k_qxtop,kdir
4210 flux_qx(k) = V_qr(k)*qr(i,k)*rho(i,k)
4211 flux_nx(k) = V_nr(k)*nr(i,k)*rho(i,k)
4212 mflux_r(i,k) = flux_qx(k) !store mass flux for use in visibility diagnostic)
4213 enddo
4215 !accumulated precip during time step
4216 if (k_qxbot.eq.kbot) prt_accum = prt_accum + flux_qx(kbot)*dt_sub
4217 !or, optimized: prt_accum = prt_accum - (k_qxbot.eq.kbot)*dt_sub
4219 !--- for top level only (since flux is 0 above)
4220 k = k_qxtop
4221 !- compute flux divergence
4222 fluxdiv_qx = -flux_qx(k)*inv_dzq(i,k)
4223 fluxdiv_nx = -flux_nx(k)*inv_dzq(i,k)
4224 !- update prognostic variables
4225 qr(i,k) = qr(i,k) + fluxdiv_qx*dt_sub*inv_rho(i,k)
4226 nr(i,k) = nr(i,k) + fluxdiv_nx*dt_sub*inv_rho(i,k)
4228 do k = k_qxtop-kdir,k_temp,-kdir
4229 !-- compute flux divergence
4230 fluxdiv_qx = (flux_qx(k+kdir) - flux_qx(k))*inv_dzq(i,k)
4231 fluxdiv_nx = (flux_nx(k+kdir) - flux_nx(k))*inv_dzq(i,k)
4232 !-- update prognostic variables
4233 qr(i,k) = qr(i,k) + fluxdiv_qx*dt_sub*inv_rho(i,k)
4234 nr(i,k) = nr(i,k) + fluxdiv_nx*dt_sub*inv_rho(i,k)
4235 enddo
4237 dt_left = dt_left - dt_sub !update time remaining for sedimentation
4238 if (k_qxbot.ne.kbot) k_qxbot = k_qxbot - kdir
4239 !or, optimzed: k_qxbot = k_qxbot +(k_qxbot.eq.kbot)*kdir
4241 enddo substep_sedi_r
4243 prt_liq(i) = prt_liq(i) + prt_accum*inv_rhow*odt
4245 endif qr_present
4248 !------------------------------------------------------------------------------------------!
4249 ! Ice sedimentation: (adaptivive substepping)
4251 iice_loop_sedi_ice: do iice = 1,nCat
4253 log_qxpresent = .false. !note: this applies to ice category 'iice' only
4254 k_qxtop = kbot
4256 !find top, determine qxpresent
4257 do k = ktop,kbot,-kdir
4258 if (qitot(i,k,iice).ge.qsmall) then
4259 log_qxpresent = .true.
4260 k_qxtop = k
4261 exit
4262 endif !
4263 enddo !k-loop
4265 qi_present: if (log_qxpresent) then
4267 dt_left = dt !time remaining for sedi over full model (mp) time step
4268 prt_accum = 0. !precip rate for individual category
4270 !find bottom
4271 do k = kbot,k_qxtop,kdir
4272 if (qitot(i,k,iice).ge.qsmall) then
4273 k_qxbot = k
4274 exit
4275 endif
4276 enddo
4278 three_moment_ice_1: if (.not. log_3momentIce) then
4280 substep_sedi_i1: do while (dt_left.gt.1.e-4)
4282 Co_max = 0.
4283 V_qit(:) = 0.
4284 V_nit(:) = 0.
4286 kloop_sedi_i1: do k = k_qxtop,k_qxbot,-kdir
4288 !-- compute Vq, Vn (get values from lookup table)
4289 qi_notsmall_i1: if (qitot(i,k,iice).ge.qsmall) then
4291 !--Compute Vq, Vn:
4292 nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) !impose lower limits to prevent log(<0)
4293 call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),birim(i,k,iice),rhop)
4294 call find_lookupTable_indices_1a(dumi,dumjj,dumii,dum1,dum4,dum5, &
4295 isize,rimsize,densize,qitot(i,k,iice),nitot(i,k,iice), &
4296 qirim(i,k,iice),rhop)
4297 call access_lookup_table(dumjj,dumii,dumi, 1,dum1,dum4,dum5,f1pr01)
4298 call access_lookup_table(dumjj,dumii,dumi, 2,dum1,dum4,dum5,f1pr02)
4299 call access_lookup_table(dumjj,dumii,dumi, 7,dum1,dum4,dum5,f1pr09)
4300 call access_lookup_table(dumjj,dumii,dumi, 8,dum1,dum4,dum5,f1pr10)
4301 !-impose mean ice size bounds (i.e. apply lambda limiters)
4302 nitot(i,k,iice) = min(nitot(i,k,iice),f1pr09*qitot(i,k,iice))
4303 nitot(i,k,iice) = max(nitot(i,k,iice),f1pr10*qitot(i,k,iice))
4304 V_qit(k) = f1pr02*rhofaci(i,k) !mass-weighted fall speed (with density factor)
4305 V_nit(k) = f1pr01*rhofaci(i,k) !number-weighted fall speed (with density factor)
4306 !==
4308 endif qi_notsmall_i1
4310 Co_max = max(Co_max, V_qit(k)*dt_left*inv_dzq(i,k))
4312 enddo kloop_sedi_i1
4314 !-- compute dt_sub
4315 tmpint1 = int(Co_max+1.) !number of substeps remaining if dt_sub were constant
4316 dt_sub = min(dt_left, dt_left/float(tmpint1))
4318 if (k_qxbot.eq.kbot) then
4319 k_temp = k_qxbot
4320 else
4321 k_temp = k_qxbot-kdir
4322 endif
4324 !-- calculate fluxes
4325 do k = k_temp,k_qxtop,kdir
4326 flux_qit(k) = V_qit(k)*qitot(i,k,iice)*rho(i,k)
4327 flux_nit(k) = V_nit(k)*nitot(i,k,iice)*rho(i,k)
4328 flux_qir(k) = V_qit(k)*qirim(i,k,iice)*rho(i,k)
4329 flux_bir(k) = V_qit(k)*birim(i,k,iice)*rho(i,k)
4330 mflux_i(i,k) = flux_qit(k) !store mass flux for use in visibility diagnostic)
4331 enddo
4333 !accumulated precip during time step
4334 if (k_qxbot.eq.kbot) prt_accum = prt_accum + flux_qit(kbot)*dt_sub
4335 !or, optimized: prt_accum = prt_accum - (k_qxbot.eq.kbot)*dt_sub
4337 !--- for top level only (since flux is 0 above)
4338 k = k_qxtop
4339 !-- compute flux divergence
4340 fluxdiv_qit = -flux_qit(k)*inv_dzq(i,k)
4341 fluxdiv_qir = -flux_qir(k)*inv_dzq(i,k)
4342 fluxdiv_bir = -flux_bir(k)*inv_dzq(i,k)
4343 fluxdiv_nit = -flux_nit(k)*inv_dzq(i,k)
4344 !-- update prognostic variables
4345 qitot(i,k,iice) = qitot(i,k,iice) + fluxdiv_qit*dt_sub*inv_rho(i,k)
4346 qirim(i,k,iice) = qirim(i,k,iice) + fluxdiv_qir*dt_sub*inv_rho(i,k)
4347 birim(i,k,iice) = birim(i,k,iice) + fluxdiv_bir*dt_sub*inv_rho(i,k)
4348 nitot(i,k,iice) = nitot(i,k,iice) + fluxdiv_nit*dt_sub*inv_rho(i,k)
4350 do k = k_qxtop-kdir,k_temp,-kdir
4351 !-- compute flux divergence
4352 fluxdiv_qit = (flux_qit(k+kdir) - flux_qit(k))*inv_dzq(i,k)
4353 fluxdiv_qir = (flux_qir(k+kdir) - flux_qir(k))*inv_dzq(i,k)
4354 fluxdiv_bir = (flux_bir(k+kdir) - flux_bir(k))*inv_dzq(i,k)
4355 fluxdiv_nit = (flux_nit(k+kdir) - flux_nit(k))*inv_dzq(i,k)
4356 !-- update prognostic variables
4357 qitot(i,k,iice) = qitot(i,k,iice) + fluxdiv_qit*dt_sub*inv_rho(i,k)
4358 qirim(i,k,iice) = qirim(i,k,iice) + fluxdiv_qir*dt_sub*inv_rho(i,k)
4359 birim(i,k,iice) = birim(i,k,iice) + fluxdiv_bir*dt_sub*inv_rho(i,k)
4360 nitot(i,k,iice) = nitot(i,k,iice) + fluxdiv_nit*dt_sub*inv_rho(i,k)
4361 enddo
4363 dt_left = dt_left - dt_sub !update time remaining for sedimentation
4364 if (k_qxbot.ne.kbot) k_qxbot = k_qxbot - kdir
4365 !or, optimzed: k_qxbot = k_qxbot +(k_qxbot.eq.kbot)*kdir
4367 enddo substep_sedi_i1
4368 ! .............................................................................................................
4369 else ! three_moment_ice_1
4371 substep_sedi_i2: do while (dt_left.gt.1.e-4)
4373 Co_max = 0.
4374 V_qit(:) = 0.
4375 V_nit(:) = 0.
4376 V_zit(:) = 0.
4378 kloop_sedi_i2: do k = k_qxtop,k_qxbot,-kdir
4380 !-- compute Vq, Vn (get values from lookup table)
4381 qi_notsmall_i2: if (qitot(i,k,iice).ge.qsmall) then
4383 !--Compute Vq, Vn:
4384 nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) !impose lower limits to prevent log(<0)
4385 call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),birim(i,k,iice),rhop)
4387 call find_lookupTable_indices_1a(dumi,dumjj,dumii,dum1,dum4,dum5, &
4388 isize,rimsize,densize,qitot(i,k,iice),nitot(i,k,iice), &
4389 qirim(i,k,iice),rhop)
4391 ! get Z_norm indices
4393 !impose lower limits to prevent taking log of # < 0
4394 zitot(i,k,iice) = max(zitot(i,k,iice),zsmall)
4396 dum1z = 6./(200.*pi)*qitot(i,k,iice) !estimate of moment3, as starting point use 200 kg m-3 estimate of bulk density
4398 do imu=1,niter_mui
4399 mu_i = compute_mu_3moment(nitot(i,k,iice),dum1z,zitot(i,k,iice),mu_i_max)
4400 call find_lookupTable_indices_1c(dumzz,dum6,zsize,qitot(i,k,iice),mu_i)
4401 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,12,dum1,dum4,dum5,dum6,f1pr16) ! find actual bulk density
4402 dum1z = 6./(f1pr16*pi)*qitot(i,k,iice) !estimate of moment3
4403 enddo
4405 !call find_lookupTable_indices_1c(dumzz,dum6,zsize,qitot(i,k,iice),zitot(i,k,iice)) !HM moved to above
4407 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 1,dum1,dum4,dum5,dum6,f1pr01)
4408 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 2,dum1,dum4,dum5,dum6,f1pr02)
4409 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 7,dum1,dum4,dum5,dum6,f1pr09)
4410 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 8,dum1,dum4,dum5,dum6,f1pr10)
4411 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,13,dum1,dum4,dum5,dum6,f1pr19)
4413 !impose mean ice size bounds (i.e. apply lambda limiters)
4414 nitot(i,k,iice) = min(nitot(i,k,iice),f1pr09*qitot(i,k,iice))
4415 nitot(i,k,iice) = max(nitot(i,k,iice),f1pr10*qitot(i,k,iice))
4417 V_qit(k) = f1pr02*rhofaci(i,k) !mass-weighted fall speed (with density factor)
4418 V_nit(k) = f1pr01*rhofaci(i,k) !number-weighted fall speed (with density factor)
4419 V_zit(k) = f1pr19*rhofaci(i,k) !reflectivity-weighted fall speed (with density factor)
4421 endif qi_notsmall_i2
4423 ! use V_zit for calculating sub-stepping since it is larger than V_qit
4424 Co_max = max(Co_max, V_zit(k)*dt_left*inv_dzq(i,k))
4426 enddo kloop_sedi_i2
4428 !-- compute dt_sub
4429 tmpint1 = int(Co_max+1.) !number of substeps remaining if dt_sub were constant
4430 dt_sub = min(dt_left, dt_left/float(tmpint1))
4432 if (k_qxbot.eq.kbot) then
4433 k_temp = k_qxbot
4434 else
4435 k_temp = k_qxbot-kdir
4436 endif
4438 !-- calculate fluxes
4439 do k = k_temp,k_qxtop,kdir
4440 flux_qit(k) = V_qit(k)*qitot(i,k,iice)*rho(i,k)
4441 flux_nit(k) = V_nit(k)*nitot(i,k,iice)*rho(i,k)
4442 flux_qir(k) = V_qit(k)*qirim(i,k,iice)*rho(i,k)
4443 flux_bir(k) = V_qit(k)*birim(i,k,iice)*rho(i,k)
4444 flux_zit(k) = V_zit(k)*zitot(i,k,iice)*rho(i,k)
4445 mflux_i(i,k) = flux_qit(k) !store mass flux for use in visibility diagnostic)
4446 enddo
4448 !accumulated precip during time step
4449 if (k_qxbot.eq.kbot) prt_accum = prt_accum + flux_qit(kbot)*dt_sub
4450 !or, optimized: prt_accum = prt_accum - (k_qxbot.eq.kbot)*dt_sub
4452 !--- for top level only (since flux is 0 above)
4453 k = k_qxtop
4454 !-- compute flux divergence
4455 fluxdiv_qit = -flux_qit(k)*inv_dzq(i,k)
4456 fluxdiv_qir = -flux_qir(k)*inv_dzq(i,k)
4457 fluxdiv_bir = -flux_bir(k)*inv_dzq(i,k)
4458 fluxdiv_nit = -flux_nit(k)*inv_dzq(i,k)
4459 fluxdiv_zit = -flux_zit(k)*inv_dzq(i,k)
4460 !-- update prognostic variables
4461 qitot(i,k,iice) = qitot(i,k,iice) + fluxdiv_qit*dt_sub*inv_rho(i,k)
4462 qirim(i,k,iice) = qirim(i,k,iice) + fluxdiv_qir*dt_sub*inv_rho(i,k)
4463 birim(i,k,iice) = birim(i,k,iice) + fluxdiv_bir*dt_sub*inv_rho(i,k)
4464 nitot(i,k,iice) = nitot(i,k,iice) + fluxdiv_nit*dt_sub*inv_rho(i,k)
4465 zitot(i,k,iice) = zitot(i,k,iice) + fluxdiv_zit*dt_sub*inv_rho(i,k)
4468 do k = k_qxtop-kdir,k_temp,-kdir
4469 !-- compute flux divergence
4470 fluxdiv_qit = (flux_qit(k+kdir) - flux_qit(k))*inv_dzq(i,k)
4471 fluxdiv_qir = (flux_qir(k+kdir) - flux_qir(k))*inv_dzq(i,k)
4472 fluxdiv_bir = (flux_bir(k+kdir) - flux_bir(k))*inv_dzq(i,k)
4473 fluxdiv_nit = (flux_nit(k+kdir) - flux_nit(k))*inv_dzq(i,k)
4474 fluxdiv_zit = (flux_zit(k+kdir) - flux_zit(k))*inv_dzq(i,k)
4475 !-- update prognostic variables
4476 qitot(i,k,iice) = qitot(i,k,iice) + fluxdiv_qit*dt_sub*inv_rho(i,k)
4477 qirim(i,k,iice) = qirim(i,k,iice) + fluxdiv_qir*dt_sub*inv_rho(i,k)
4478 birim(i,k,iice) = birim(i,k,iice) + fluxdiv_bir*dt_sub*inv_rho(i,k)
4479 nitot(i,k,iice) = nitot(i,k,iice) + fluxdiv_nit*dt_sub*inv_rho(i,k)
4480 zitot(i,k,iice) = zitot(i,k,iice) + fluxdiv_zit*dt_sub*inv_rho(i,k)
4481 enddo
4483 dt_left = dt_left - dt_sub !update time remaining for sedimentation
4484 if (k_qxbot.ne.kbot) k_qxbot = k_qxbot - kdir
4485 !or, optimzed: k_qxbot = k_qxbot +(k_qxbot.eq.kbot)*kdir
4487 enddo substep_sedi_i2
4489 endif three_moment_ice_1
4491 prt_sol(i) = prt_sol(i) + prt_accum*inv_rhow*odt
4493 endif qi_present
4495 enddo iice_loop_sedi_ice !iice-loop
4497 !------------------------------------------------------------------------------------------!
4499 ! note: This debug check is commented since small negative qx,nx values are possible here
4500 ! (but get adjusted below). If uncommented, caution in interpreting results.
4501 !
4502 ! if (debug_on) then
4503 ! location_ind = 600
4504 ! force_abort = debug_ABORT
4505 ! if (log_3momentIce) then
4506 ! call check_values(qv(i,:),T(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
4507 ! qirim(i,:,:),nitot(i,:,:),birim(i,:,:),i,it,force_abort,location_ind, &
4508 ! Zitot=zitot(i,:,:))
4509 ! else
4510 ! call check_values(qv(i,:),T(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
4511 ! qirim(i,:,:),nitot(i,:,:),birim(i,:,:),i,it,force_abort,location_ind)
4512 ! endif
4513 ! if (global_status /= STATUS_OK) return
4514 ! endif
4516 !------------------------------------------------------------------------------------------!
4517 ! End of sedimentation section
4518 !==========================================================================================!
4520 !third and last call to compute_SCPF
4521 call compute_SCPF(Qc(i,:)+sum(Qitot(i,:,:),dim=2),Qr(i,:),Qv(i,:),Qvi(i,:), &
4522 Pres(i,:),ktop,kbot,kdir,SCF,iSCF,SPF,iSPF,SPF_clr,Qv_cld,Qv_clr, &
4523 SCPF_on,scpf_pfrac,scpf_resfact,quick=.true.)
4525 !.......................................
4526 ! homogeneous freezing of cloud and rain
4528 k_loop_fz: do k = kbot,ktop,kdir
4530 ! compute mean-mass ice diameters (estimated; rigorous approach to be implemented later)
4531 diam_ice(i,k,:) = 0.
4532 do iice = 1,nCat
4533 if (qitot(i,k,iice).ge.qsmall) then
4534 dum1 = max(nitot(i,k,iice),nsmall)
4535 dum2 = 500. !ice density
4536 diam_ice(i,k,iice) = ((qitot(i,k,iice)*6.)/(dum1*dum2*pi))**thrd
4537 endif
4538 enddo !iice loop
4540 qc_not_small_2: if (qc(i,k).ge.qsmall .and. t(i,k).lt.233.15) then
4542 Q_nuc = qc(i,k)
4543 nc(i,k) = max(nc(i,k),nsmall)
4544 N_nuc = nc(i,k)
4546 if (nCat>1) then
4547 !determine destination ice-phase category:
4548 dum1 = 900. !density of new ice
4549 D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd
4550 call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init, &
4551 iice_dest)
4552 if (global_status /= STATUS_OK) return
4553 else
4554 iice_dest = 1
4555 endif
4557 qirim(i,k,iice_dest) = qirim(i,k,iice_dest) + Q_nuc
4558 qitot(i,k,iice_dest) = qitot(i,k,iice_dest) + Q_nuc
4559 birim(i,k,iice_dest) = birim(i,k,iice_dest) + Q_nuc*inv_rho_rimeMax
4560 nitot(i,k,iice_dest) = nitot(i,k,iice_dest) + N_nuc
4561 !Z-tendency for triple-moment ice
4562 ! note: this could be optimized by moving this conditional block outside of loop k_loop_fz
4563 ! (would need to save values of iice_dest -- ditto for homo freezing of rain)
4564 if (log_3momentIce .and. N_nuc.ge.nsmall) then
4565 tmp1 = Q_nuc*6./(900.*pi) !estimate of moment_3 tendency
4566 call get_cloud_dsd2(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu,lamc(i,k), &
4567 lammin,lammax,cdist(i,k),cdist1(i,k),iSCF(k))
4568 mu_i_new = mu_c(i,k)
4569 zitot(i,k,iice_dest) = zitot(i,k,iice_dest) + G_of_mu(mu_i_new)*tmp1**2/N_nuc
4570 endif ! log_3momentice
4571 ! update theta. Note temperature is NOT updated here, but currently not used after
4572 th(i,k) = th(i,k) + invexn(i,k)*Q_nuc*xlf(i,k)*inv_cp
4573 qc(i,k) = 0. != qc(i,k) - Q_nuc
4574 nc(i,k) = 0. != nc(i,k) - N_nuc
4576 endif qc_not_small_2
4578 qr_not_small_2: if (qr(i,k).ge.qsmall .and. t(i,k).lt.233.15) then
4580 Q_nuc = qr(i,k)
4581 nr(i,k) = max(nr(i,k),nsmall)
4582 N_nuc = nr(i,k)
4583 if (nCat>1) then
4584 !determine destination ice-phase category:
4585 dum1 = 900. !density of new ice
4586 D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd
4587 call icecat_destination(qitot(i,k,:)*iSCF(k),diam_ice(i,k,:),D_new,deltaD_init,iice_dest)
4588 if (global_status /= STATUS_OK) return
4589 else
4590 iice_dest = 1
4591 endif
4593 qirim(i,k,iice_dest) = qirim(i,k,iice_dest) + Q_nuc
4594 qitot(i,k,iice_dest) = qitot(i,k,iice_dest) + Q_nuc
4595 birim(i,k,iice_dest) = birim(i,k,iice_dest) + Q_nuc*inv_rho_rimeMax
4596 nitot(i,k,iice_dest) = nitot(i,k,iice_dest) + N_nuc
4597 ! z tendency for triple moment ice
4598 if (log_3momentIce .and. N_nuc.ge.qsmall) then
4599 tmp1 = Q_nuc*6./(900.*pi) !estimate of moment_3 tendency
4600 mu_i_new = mu_r(i,k)
4601 zitot(i,k,iice_dest) = zitot(i,k,iice_dest) + G_of_mu(mu_i_new)*tmp1**2/N_nuc
4602 endif ! log_3momentice
4603 ! update theta. Note temperature is NOT updated here, but currently not used after
4604 th(i,k) = th(i,k) + invexn(i,k)*Q_nuc*xlf(i,k)*inv_cp
4605 qr(i,k) = 0. ! = qr(i,k) - Q_nuc
4606 nr(i,k) = 0. ! = nr(i,k) - N_nuc
4608 endif qr_not_small_2
4610 enddo k_loop_fz
4612 !..............................................
4613 ! Merge ice categories with similar properties (based on specified similarly condition)
4615 multicat: if (nCat.gt.1) then
4616 ! multicat: if (.FALSE.) then ! for testing
4618 !step 1: adjustments and calculation of mean diameters
4619 k_loop_check_before_merge: do k = kbot,ktop,kdir
4620 iice_loop_check_before_merge: do iice = 1,nCat
4621 qi_not_small_merge: if (qitot(i,k,iice).ge.qsmall) then
4623 nitot(i,k,iice) = max(nitot(i,k,iice),nsmall) !impose limit to prevent taking log of # < 0
4624 call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),birim(i,k,iice),rhop)
4626 if (.not. log_3momentIce) then
4628 call find_lookupTable_indices_1a(dumi,dumjj,dumii,dum1,dum4,dum5,isize, &
4629 rimsize,densize,qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice), &
4630 rhop)
4631 call access_lookup_table(dumjj,dumii,dumi,11,dum1,dum4,dum5,f1pr15)
4633 else ! triple moment ice
4635 call find_lookupTable_indices_1a(dumi,dumjj,dumii,dum1,dum4,dum5,isize, &
4636 rimsize,densize,qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice), &
4637 rhop)
4638 zitot(i,k,iice) = max(zitot(i,k,iice),zsmall) !impose limit to prevent taking log of # < 0
4639 dum1z = 6./(200.*pi)*qitot(i,k,iice) !estimate of moment3, as starting point use 200 kg m-3 estimate of bulk density
4640 do imu=1,niter_mui
4641 mu_i = compute_mu_3moment(nitot(i,k,iice),dum1z,zitot(i,k,iice),mu_i_max)
4642 call find_lookupTable_indices_1c(dumzz,dum6,zsize,qitot(i,k,iice),mu_i)
4643 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,12,dum1,dum4,dum5,dum6,f1pr16) ! find actual bulk density
4644 dum1z = 6./(f1pr16*pi)*qitot(i,k,iice) !estimate of moment3
4645 enddo
4646 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,11,dum1,dum4,dum5,dum6,f1pr15)
4648 endif
4650 !adjust Zitot to make sure mu is in bounds
4651 if (log_3momentIce) then
4652 dum1 = 6./(f1pr16*pi)*qitot(i,k,iice) !estimate of moment3
4653 tmp1 = G_of_mu(0.)
4654 tmp2 = G_of_mu(20.)
4655 zitot(i,k,iice) = min(zitot(i,k,iice),tmp1*dum1**2/nitot(i,k,iice))
4656 zitot(i,k,iice) = max(zitot(i,k,iice),tmp2*dum1**2/nitot(i,k,iice))
4657 endif
4659 diag_di(i,k,iice) = f1pr15
4661 else
4663 qv(i,k) = qv(i,k) + qitot(i,k,iice)
4664 th(i,k) = th(i,k) - invexn(i,k)*qitot(i,k,iice)*xxls(i,k)*inv_cp
4665 qitot(i,k,iice) = 0.
4666 nitot(i,k,iice) = 0.
4667 qirim(i,k,iice) = 0.
4668 birim(i,k,iice) = 0.
4669 if (log_3momentIce) zitot(i,k,iice) = 0
4670 diag_di(i,k,iice) = 0.
4672 endif qi_not_small_merge
4673 enddo iice_loop_check_before_merge
4674 enddo k_loop_check_before_merge
4676 !step 2: merge ice with similar properties into one category
4677 do k = kbot,ktop,kdir
4678 do iice = nCat,2,-1
4679 tmp1 = abs(diag_di(i,k,iice)-diag_di(i,k,iice-1))
4680 if (tmp1.le.deltaD_init .and. qitot(i,k,iice)>0. .and. qitot(i,k,iice-1)>0.) then
4681 qitot(i,k,iice-1) = qitot(i,k,iice-1) + qitot(i,k,iice)
4682 nitot(i,k,iice-1) = nitot(i,k,iice-1) + nitot(i,k,iice)
4683 qirim(i,k,iice-1) = qirim(i,k,iice-1) + qirim(i,k,iice)
4684 birim(i,k,iice-1) = birim(i,k,iice-1) + birim(i,k,iice)
4685 qitot(i,k,iice) = 0.
4686 nitot(i,k,iice) = 0.
4687 qirim(i,k,iice) = 0.
4688 birim(i,k,iice) = 0.
4689 if (log_3momentIce) then
4690 zitot(i,k,iice-1) = zitot(i,k,iice-1) + zitot(i,k,iice)
4691 zitot(i,k,iice) = 0.
4692 endif
4693 endif
4694 enddo !iice loop
4695 enddo !k loop
4697 endif multicat
4699 !...................................................
4700 ! note: This debug check is commented since small negative qx,nx values are possible here
4701 ! (but get adjusted below). If uncommented, caution in interpreting results.
4702 !
4703 ! if (debug_on) then
4704 ! location_ind = 700
4705 ! force_abort = debug_ABORT
4706 ! if (log_3momentIce) then
4707 ! call check_values(qv(i,:),T(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
4708 ! qirim(i,:,:),nitot(i,:,:),birim(i,:,:),i,it,force_abort,location_ind, &
4709 ! Zitot=zitot(i,:,:))
4710 ! else
4711 ! call check_values(qv(i,:),T(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
4712 ! qirim(i,:,:),nitot(i,:,:),birim(i,:,:),i,it,force_abort,location_ind)
4713 ! endif
4714 ! if (global_status /= STATUS_OK) return
4715 ! endif
4717 !...................................................
4718 ! Final checks to ensure consistency of mass/number
4719 ! and compute diagnostic fields for output
4722 k_loop_final_diagnostics: do k = kbot,ktop,kdir
4724 ! cloud:
4725 if (qc(i,k)*iSCF(k).ge.qsmall) then
4726 call get_cloud_dsd2(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu,lamc(i,k), &
4727 lammin,lammax,tmp1,tmp2, iSCF(k))
4728 diag_effc(i,k) = 0.5*(mu_c(i,k)+3.)/lamc(i,k)
4729 else
4730 qv(i,k) = qv(i,k)+qc(i,k)
4731 th(i,k) = th(i,k)-invexn(i,k)*qc(i,k)*xxlv(i,k)*inv_cp
4732 qc(i,k) = 0.
4733 nc(i,k) = 0.
4734 endif
4736 ! rain:
4737 if (qr(i,k).ge.qsmall) then
4739 call get_rain_dsd2(qr(i,k),nr(i,k),mu_r(i,k),lamr(i,k),tmp1,tmp2,1.)
4741 ! hm, turn off soft lambda limiter
4742 ! impose size limits for rain with 'soft' lambda limiter
4743 ! (adjusts over a set timescale rather than within one timestep)
4744 ! dum2 = (qr(i,k)/(pi*rhow*nr(i,k)))**thrd
4745 ! if (dum2.gt.dbrk) then
4746 ! dum = qr(i,k)*cons4
4747 ! !dum1 = (dum-nr(i,k))/max(60.,dt) !time scale for adjustment is 60 s
4748 ! dum1 = (dum-nr(i,k))*timeScaleFactor
4749 ! nr(i,k) = nr(i,k)+dum1*dt
4750 ! endif
4752 !diag_effr(i,k) = 0.5*(mu_r(i,k)+3.)/lamr(i,k) (currently not used)
4753 ! ze_rain(i,k) = n0r(i,k)*720./lamr(i,k)**3/lamr(i,k)**3/lamr(i,k)
4754 ! non-exponential rain:
4755 ze_rain(i,k) = rho(i,k)*nr(i,k)*(mu_r(i,k)+6.)*(mu_r(i,k)+5.)*(mu_r(i,k)+4.)* &
4756 (mu_r(i,k)+3.)*(mu_r(i,k)+2.)*(mu_r(i,k)+1.)/lamr(i,k)**6
4757 ze_rain(i,k) = max(ze_rain(i,k),1.e-22)
4758 else
4759 qv(i,k) = qv(i,k)+qr(i,k)
4760 th(i,k) = th(i,k)-invexn(i,k)*qr(i,k)*xxlv(i,k)*inv_cp
4761 qr(i,k) = 0.
4762 nr(i,k) = 0.
4763 endif
4765 ! ice:
4767 call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k))
4769 iice_loop_final_diagnostics: do iice = 1,nCat
4771 qi_not_small: if (qitot(i,k,iice).ge.qsmall) then
4773 !impose lower limits to prevent taking log of # < 0
4774 nitot(i,k,iice) = max(nitot(i,k,iice),nsmall)
4775 nr(i,k) = max(nr(i,k),nsmall)
4777 call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),birim(i,k,iice),rhop)
4779 if (.not. log_3momentIce) then
4781 call find_lookupTable_indices_1a(dumi,dumjj,dumii,dum1,dum4,dum5,isize, &
4782 rimsize,densize,qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice), &
4783 rhop)
4785 call access_lookup_table(dumjj,dumii,dumi, 2,dum1,dum4,dum5,f1pr02)
4786 call access_lookup_table(dumjj,dumii,dumi, 6,dum1,dum4,dum5,f1pr06)
4787 call access_lookup_table(dumjj,dumii,dumi, 7,dum1,dum4,dum5,f1pr09)
4788 call access_lookup_table(dumjj,dumii,dumi, 8,dum1,dum4,dum5,f1pr10)
4789 call access_lookup_table(dumjj,dumii,dumi, 9,dum1,dum4,dum5,f1pr13)
4790 call access_lookup_table(dumjj,dumii,dumi,11,dum1,dum4,dum5,f1pr15)
4791 call access_lookup_table(dumjj,dumii,dumi,12,dum1,dum4,dum5,f1pr16)
4792 call access_lookup_table(dumjj,dumii,dumi,13,dum1,dum4,dum5,f1pr22) ! lambda_i
4793 call access_lookup_table(dumjj,dumii,dumi,14,dum1,dum4,dum5,f1pr23) ! mu_i
4795 else ! triple moment ice
4797 call find_lookupTable_indices_1a(dumi,dumjj,dumii,dum1,dum4,dum5,isize, &
4798 rimsize,densize,qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice), &
4799 rhop)
4801 ! get Znorm indices
4803 !impose lower limits to prevent taking log of # < 0
4804 zitot(i,k,iice) = max(zitot(i,k,iice),zsmall)
4806 dum1z = 6./(200.*pi)*qitot(i,k,iice) !estimate of moment3, as starting point use 200 kg m-3 estimate of bulk density
4808 do imu=1,niter_mui
4809 mu_i = compute_mu_3moment(nitot(i,k,iice),dum1z,zitot(i,k,iice),mu_i_max)
4810 call find_lookupTable_indices_1c(dumzz,dum6,zsize,qitot(i,k,iice),mu_i)
4811 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,12,dum1,dum4,dum5,dum6,f1pr16) ! find actual bulk density
4812 dum1z = 6./(f1pr16*pi)*qitot(i,k,iice) !estimate of moment3
4813 enddo
4815 ! call find_lookupTable_indices_1c(dumzz,dum6,zsize,qitot(i,k,iice),zitot(i,k,iice)) !HM moved to above
4817 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 2,dum1,dum4,dum5,dum6,f1pr02)
4818 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 6,dum1,dum4,dum5,dum6,f1pr06)
4819 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 7,dum1,dum4,dum5,dum6,f1pr09)
4820 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 8,dum1,dum4,dum5,dum6,f1pr10)
4821 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi, 9,dum1,dum4,dum5,dum6,f1pr13)
4822 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,11,dum1,dum4,dum5,dum6,f1pr15)
4823 ! call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,12,dum1,dum4,dum5,dum6,f1pr16) !HM moved to above
4824 ! call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,14,dum1,dum4,dum5,dum6,f1pr20)
4825 ! call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,15,dum1,dum4,dum5,dum6,f1pr21)
4826 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,14,dum1,dum4,dum5,dum6,f1pr22) ! lambda_i
4827 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,15,dum1,dum4,dum5,dum6,f1pr23) ! mu_i
4829 endif
4832 ! impose mean ice size bounds (i.e. apply lambda limiters)
4833 nitot(i,k,iice) = min(nitot(i,k,iice),f1pr09*qitot(i,k,iice))
4834 nitot(i,k,iice) = max(nitot(i,k,iice),f1pr10*qitot(i,k,iice))
4836 ! adjust Zitot to make sure mu is in bounds
4837 ! note that the Zmax and Zmin are normalized and thus need to be multiplied by existing Q
4838 if (log_3momentIce) then
4839 dum1 = 6./(f1pr16*pi)*qitot(i,k,iice) !estimate of moment3
4840 tmp1 = G_of_mu(0.)
4841 tmp2 = G_of_mu(20.)
4842 zitot(i,k,iice) = min(zitot(i,k,iice),tmp1*dum1**2/nitot(i,k,iice))
4843 zitot(i,k,iice) = max(zitot(i,k,iice),tmp2*dum1**2/nitot(i,k,iice))
4844 ! zitot(i,k,iice) = min(zitot(i,k,iice),f1pr20*qitot(i,k,iice))
4845 ! zitot(i,k,iice) = max(zitot(i,k,iice),f1pr21*qitot(i,k,iice))
4846 endif
4848 !--this should already be done in s/r 'calc_bulkRhoRime'
4849 if (qirim(i,k,iice).lt.qsmall) then
4850 qirim(i,k,iice) = 0.
4851 birim(i,k,iice) = 0.
4852 endif
4853 !==
4855 ! note that reflectivity from lookup table is normalized, so we need to multiply by N
4856 diag_vmi(i,k,iice) = f1pr02*rhofaci(i,k)
4857 diag_effi(i,k,iice) = f1pr06 ! units are in m
4858 diag_di(i,k,iice) = f1pr15
4859 diag_rhoi(i,k,iice) = f1pr16
4860 if (present(diag_lami)) diag_lami(i,k,iice) = f1pr22
4861 if (present(diag_mui)) diag_mui(i,k,iice) = f1pr23
4862 if (present(diag_dhmax)) then
4863 diag_dhmax(i,k,iice) = maxHailSize(rho(i,k),qitot(i,k,iice), &
4864 qirim(i,k,iice),nitot(i,k,iice),rhofaci(i,k),f1pr22,f1pr23)
4865 endif
4867 ! note factor of air density below is to convert from m^6/kg to m^6/m^3
4868 ze_ice(i,k) = ze_ice(i,k) + 0.1892*f1pr13*nitot(i,k,iice)*rho(i,k) ! sum contribution from each ice category (note: 0.1892 = 0.176/0.93)
4869 ze_ice(i,k) = max(ze_ice(i,k),1.e-22)
4871 else
4873 qv(i,k) = qv(i,k) + qitot(i,k,iice)
4874 th(i,k) = th(i,k) - invexn(i,k)*qitot(i,k,iice)*xxls(i,k)*inv_cp
4875 qitot(i,k,iice) = 0.
4876 nitot(i,k,iice) = 0.
4877 qirim(i,k,iice) = 0.
4878 birim(i,k,iice) = 0.
4879 if (log_3momentIce) zitot(i,k,iice) = 0
4880 diag_di(i,k,iice) = 0.
4882 endif qi_not_small
4884 enddo iice_loop_final_diagnostics
4886 ! sum ze components and convert to dBZ
4887 diag_ze(i,k) = 10.*log10((ze_rain(i,k) + ze_ice(i,k))*1.e+18)
4889 ! if qr is very small then set Nr to 0 (needs to be done here after call
4890 ! to ice lookup table because a minimum Nr of nsmall will be set otherwise even if qr=0)
4891 if (qr(i,k).lt.qsmall) then
4892 nr(i,k) = 0.
4893 endif
4895 enddo k_loop_final_diagnostics
4897 if (debug_on) then
4898 location_ind = 800
4899 force_abort = debug_ABORT
4900 if (log_3momentIce) then
4901 call check_values(qv(i,:),T(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
4902 qirim(i,:,:),nitot(i,:,:),birim(i,:,:),i,it,force_abort,location_ind, &
4903 Zitot=zitot(i,:,:))
4904 else
4905 call check_values(qv(i,:),T(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
4906 qirim(i,:,:),nitot(i,:,:),birim(i,:,:),i,it,force_abort,location_ind)
4907 endif
4908 if (global_status /= STATUS_OK) return
4909 endif
4911 !.....................................................
4913 333 continue
4915 !......................................
4916 ! zero out zitot if there is no qitot for triple moment
4917 if (log_3momentIce) then
4918 where (qitot(i,:,:).lt.qsmall) zitot(i,:,:) = 0.
4919 ! do iice = 1,nCat
4920 ! do k = kbot,ktop,kdir
4921 ! if (qitot(i,k,iice).ge.qsmall) then
4922 ! dum1 = 6./(f1pr16*pi)*qitot(i,k,iice) !estimate of moment3
4923 ! mu_i = compute_mu_3moment(nitot(i,k,iice),dum1,zitot(i,k,iice),mu_i_max)
4924 ! print*,'after sed',k,mu_i
4925 ! endif
4926 ! enddo
4927 ! enddo
4928 endif
4929 !.......................................
4931 if (log_predictSsat) then
4932 ! recalculate supersaturation from T and qv
4933 do k = kbot,ktop,kdir
4934 t(i,k) = th(i,k)*(1.e-5*pres(i,k))**(rd*inv_cp)
4935 dum = qv_sat(t(i,k),pres(i,k),0)
4936 ssat(i,k) = qv(i,k)-dum
4937 enddo
4938 endif
4941 ! calculate 'binary' cloud fraction (0 or 1) (diagnostic only; used in GEM radiation interface)
4942 if (SCPF_on) then
4943 SCF_out(i,:) = SCF(:)
4944 else
4945 do k = kbot,ktop,kdir
4946 SCF_out(i,k) = 0.
4947 if (qc(i,k).ge.qsmall .and. sup(i,k).gt.1.e-6) SCF_out(i,k) = 1.
4948 do iice = 1,nCat
4949 if (qitot(i,k,iice).ge.qsmall .and. diag_effi(i,k,iice).lt.100.e-6) SCF_out(i,k) = 1.
4950 enddo
4951 enddo
4952 endif
4954 if (debug_on) then
4955 location_ind = 900
4956 force_abort = debug_ABORT
4957 tmparr1(i,:) = th(i,:)*(pres(i,:)*1.e-5)**(rd*inv_cp)
4958 if (log_3momentIce) then
4959 call check_values(qv(i,:),tmparr1(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
4960 qirim(i,:,:),nitot(i,:,:),birim(i,:,:),i,it,force_abort,location_ind, &
4961 Zitot=zitot(i,:,:))
4962 else
4963 call check_values(qv(i,:),tmparr1(i,:),qc(i,:),nc(i,:),qr(i,:),nr(i,:),qitot(i,:,:), &
4964 qirim(i,:,:),nitot(i,:,:),birim(i,:,:),i,it,force_abort,location_ind)
4965 endif
4966 if (global_status /= STATUS_OK) return
4967 endif
4969 !..............................................
4970 !Diagnostics -- visibility:
4972 if (present(diag_vis)) then !it is assumed that all diag_vis{x} will either be present or all not present
4974 diag_vis(i,:) = 3.*maxVIS
4975 diag_vis1(i,:) = 3.*maxVIS
4976 diag_vis2(i,:) = 3.*maxVIS
4977 diag_vis3(i,:) = 3.*maxVIS
4979 do k = kbot,ktop,kdir
4980 !VIS1: component through liquid cloud (fog); based on Gultepe and Milbrandt, 2007)
4981 tmp1 = qc(i,k)*rho(i,k)*1.e+3 !LWC [g m-3]
4982 tmp2 = nc(i,k)*rho(i,k)*1.e-6 !Nc [cm-3]
4983 if (tmp1>0.005 .and. tmp2>1.) then
4984 diag_vis1(i,k)= max(minVIS,1000.*(1.13*(tmp1*tmp2)**(-0.51))) !based on FRAM [GM2007, eqn (4)
4985 !diag_vis1(i,k)= max(minVIS,min(maxVIS, (tmp1*tmp2)**(-0.65))) !based on RACE [GM2007, eqn (3)
4986 endif
4988 !VIS2: component through rain; based on Gultepe and Milbrandt, 2008, Table 2 eqn (1)
4989 tmp1 = mflux_r(i,k)*inv_rhow*3.6e+6 !rain rate [mm h-1]
4990 if (tmp1>0.01) then
4991 diag_vis2(i,k)= max(minVIS,1000.*(-4.12*tmp1**0.176+9.01)) ![m]
4992 endif
4994 !VIS3: component through snow; based on Gultepe and Milbrandt, 2008, Table 2 eqn (6)
4995 tmp1 = mflux_i(i,k)*inv_rhow*3.6e+6 !snow rate, liq-eq [mm h-1]
4996 if (tmp1>0.01) then
4997 diag_vis3(i,k)= max(minVIS,1000.*(1.10*tmp1**(-0.701))) ![m]
4998 endif
5000 !VIS: visibility due to reduction from all components 1, 2, and 3
5001 ! (based on sum of extinction coefficients and Koschmieders's Law)
5002 diag_vis(i,k) = min(maxVIS, 1./(1./diag_vis1(i,k) + 1./diag_vis2(i,k) + 1./diag_vis3(i,k)))
5003 diag_vis1(i,k)= min(maxVIS, diag_vis1(i,k))
5004 diag_vis2(i,k)= min(maxVIS, diag_vis2(i,k))
5005 diag_vis3(i,k)= min(maxVIS, diag_vis3(i,k))
5006 enddo !k-loop
5008 endif !if present(diag_vis)
5010 !.....................................................
5012 enddo i_loop_main
5014 ! Save final microphysics values of theta and qv as old values for next time step
5015 ! note: This is not necessary for GEM, which already has these values available
5016 ! from the beginning of the model time step (TT_moins and HU_moins) when
5017 ! s/r 'p3_wrapper_gem' is called (from s/r 'condensation').
5018 if (trim(model) == 'WRF') then
5019 th_old = th
5020 qv_old = qv
5021 endif
5023 !...........................................................................................
5024 ! Compute diagnostic hydrometeor types for output as 3D fields and
5025 ! for partitioning into corresponding surface precipitation rates.
5027 compute_type_diags: if (typeDiags_ON) then
5029 if (.not.(present(prt_drzl).and.present(prt_rain).and.present(prt_crys).and. &
5030 present(prt_snow).and.present(prt_grpl).and.present(prt_pell).and. &
5031 present(prt_hail).and.present(prt_sndp))) then
5032 print*,'*** ABORT IN P3_MAIN ***'
5033 print*,'* typeDiags_ON = .true. but prt_drzl, etc. are not passed into P3_MAIN'
5034 print*,'*************************'
5035 global_status = STATUS_ERROR
5036 return
5037 endif
5039 prt_drzl(:) = 0.
5040 prt_rain(:) = 0.
5041 prt_crys(:) = 0.
5042 prt_snow(:) = 0.
5043 prt_grpl(:) = 0.
5044 prt_pell(:) = 0.
5045 prt_hail(:) = 0.
5046 prt_sndp(:) = 0.
5047 if (present(qi_type)) qi_type(:,:,:) = 0.
5049 if (freq3DtypeDiag>0. .and. mod(it*dt,freq3DtypeDiag*60.)==0.) then
5050 !diagnose hydrometeor types for full columns
5051 ktop_typeDiag = ktop
5052 else
5053 !diagnose hydrometeor types at bottom level only (for specific precip rates)
5054 ktop_typeDiag = kbot
5055 endif
5057 i_loop_typediag: do i = its,ite
5059 !-- rain vs. drizzle:
5060 k_loop_typdiag_1: do k = kbot,ktop_typeDiag,kdir
5062 Q_drizzle(i,k) = 0.
5063 Q_rain(i,k) = 0.
5064 !note: these can be broken down further (outside of microphysics) into
5065 ! liquid rain (drizzle) vs. freezing rain (drizzle) based on sfc temp.
5066 if (qr(i,k)>qsmall .and. nr(i,k)>nsmall) then
5067 tmp1 = (6.*qr(i,k)/(pi*rhow*nr(i,k)))**thrd !mean-mass diameter
5068 if (tmp1 < thres_raindrop) then
5069 Q_drizzle(i,k) = qr(i,k)
5070 else
5071 Q_rain(i,k) = qr(i,k)
5072 endif
5073 endif
5075 enddo k_loop_typdiag_1
5077 if (Q_drizzle(i,kbot) > 0.) then
5078 prt_drzl(i) = prt_liq(i)
5079 elseif (Q_rain(i,kbot) > 0.) then
5080 prt_rain(i) = prt_liq(i)
5081 endif
5083 !-- ice-phase:
5084 iice_loop_diag: do iice = 1,nCat
5086 k_loop_typdiag_2: do k = kbot,ktop_typeDiag,kdir
5088 Q_crystals(i,k,iice) = 0.
5089 Q_ursnow(i,k,iice) = 0.
5090 Q_lrsnow(i,k,iice) = 0.
5091 Q_grpl(i,k,iice) = 0.
5092 Q_pellets(i,k,iice) = 0.
5093 Q_hail(i,k,iice) = 0.
5095 !Note: The following partitioning of ice into types is subjective. However,
5096 ! this is a diagnostic only; it does not affect the model solution.
5098 if (qitot(i,k,iice)>qsmall) then
5099 tmp1 = qirim(i,k,iice)/qitot(i,k,iice) !rime mass fraction
5100 if (tmp1<0.1) then
5101 !zero or trace rime:
5102 if (diag_di(i,k,iice)<150.e-6) then
5103 Q_crystals(i,k,iice) = qitot(i,k,iice)
5104 else
5105 Q_ursnow(i,k,iice) = qitot(i,k,iice)
5106 endif
5107 elseif (tmp1>=0.1 .and. tmp1<0.6) then
5108 !lightly rimed:
5109 Q_lrsnow(i,k,iice) = qitot(i,k,iice)
5110 elseif (tmp1>=0.6 .and. tmp1<=1.) then
5111 !moderate-to-heavily rimed:
5112 if (diag_rhoi(i,k,iice)<700.) then
5113 Q_grpl(i,k,iice) = qitot(i,k,iice)
5114 else
5115 if (diag_di(i,k,iice)<1.e-3) then
5116 Q_pellets(i,k,iice) = qitot(i,k,iice)
5117 else
5118 Q_hail(i,k,iice) = qitot(i,k,iice)
5119 endif
5120 endif
5121 else
5122 print*, 'STOP -- unrealistic rime fraction: ',tmp1
5123 global_status = STATUS_ERROR
5124 return
5125 endif
5126 endif !qitot>0
5128 enddo k_loop_typdiag_2
5130 !diagnostics for sfc precipitation rates: (liquid-equivalent volume flux, m s-1)
5131 ! note: these are summed for all ice categories
5132 if (Q_crystals(i,kbot,iice) > 0.) then
5133 prt_crys(i) = prt_crys(i) + prt_sol(i) !precip rate of small crystals
5134 elseif (Q_ursnow(i,kbot,iice) > 0.) then
5135 prt_snow(i) = prt_snow(i) + prt_sol(i) !precip rate of unrimed + lightly rimed snow
5136 elseif (Q_lrsnow(i,kbot,iice) > 0.) then
5137 prt_snow(i) = prt_snow(i) + prt_sol(i) !precip rate of unrimed + lightly rimed snow
5138 elseif (Q_grpl(i,kbot,iice) > 0.) then
5139 prt_grpl(i) = prt_grpl(i) + prt_sol(i) !precip rate of graupel
5140 elseif (Q_pellets(i,kbot,iice) > 0.) then
5141 prt_pell(i) = prt_pell(i) + prt_sol(i) !precip rate of ice pellets
5142 elseif (Q_hail(i,kbot,iice) > 0.) then
5143 prt_hail(i) = prt_hail(i) + prt_sol(i) !precip rate of hail
5144 endif
5145 !--- optimized version above above IF block (does not work on all FORTRAN compilers)
5146 ! tmp3 = -(Q_crystals(i,kbot,iice) > 0.)
5147 ! tmp4 = -(Q_ursnow(i,kbot,iice) > 0.)
5148 ! tmp5 = -(Q_lrsnow(i,kbot,iice) > 0.)
5149 ! tmp6 = -(Q_grpl(i,kbot,iice) > 0.)
5150 ! tmp7 = -(Q_pellets(i,kbot,iice) > 0.)
5151 ! tmp8 = -(Q_hail(i,kbot,iice) > 0.)
5152 ! prt_crys(i) = prt_crys(i) + prt_sol(i)*tmp3 !precip rate of small crystals
5153 ! prt_snow(i) = prt_snow(i) + prt_sol(i)*tmp4 + prt_sol(i)*tmp5 !precip rate of unrimed + lightly rimed snow
5154 ! prt_grpl(i) = prt_grpl(i) + prt_sol(i)*tmp6 !precip rate of graupel
5155 ! prt_pell(i) = prt_pell(i) + prt_sol(i)*tmp7 !precip rate of ice pellets
5156 ! prt_hail(i) = prt_hail(i) + prt_sol(i)*tmp8 !precip rate of hail
5157 !===
5159 !precip rate of unmelted total "snow":
5160 ! For now, an instananeous solid-to-liquid ratio (tmp1) is assumed and is multiplied
5161 ! by the total liquid-equivalent precip rates of snow (small crystals + lightly-rime + ..)
5162 ! Later, this can be computed explicitly as the volume flux of unmelted ice.
5163 !tmp1 = 10. !assumes 10:1 ratio
5164 !tmp1 = 1000./max(1., diag_rhoi(i,kbot,iice))
5165 tmp1 = 1000./max(1., 5.*diag_rhoi(i,kbot,iice))
5166 prt_sndp(i) = prt_sndp(i) + tmp1*(prt_crys(i) + prt_snow(i) + prt_grpl(i))
5168 enddo iice_loop_diag
5170 enddo i_loop_typediag
5172 !- for output of 3D fields of diagnostic ice-phase hydrometeor type
5173 if (ktop_typeDiag==ktop .and. present(qi_type)) then
5174 !diag_3d(:,:,1) = Q_drizzle(:,:)
5175 !diag_3d(:,:,2) = Q_rain(:,:)
5176 do ii = 1,nCat
5177 qi_type(:,:,1) = qi_type(:,:,1) + Q_crystals(:,:,ii)
5178 qi_type(:,:,2) = qi_type(:,:,2) + Q_ursnow(:,:,ii)
5179 qi_type(:,:,3) = qi_type(:,:,3) + Q_lrsnow(:,:,ii)
5180 qi_type(:,:,4) = qi_type(:,:,4) + Q_grpl(:,:,ii)
5181 qi_type(:,:,5) = qi_type(:,:,5) + Q_hail(:,:,ii)
5182 qi_type(:,:,6) = qi_type(:,:,6) + Q_pellets(:,:,ii)
5183 enddo
5184 endif
5186 endif compute_type_diags
5189 !=== (end of section for diagnostic hydrometeor/precip types)
5192 ! end of main microphysics routine
5194 ! call cpu_time(t_p3main_end)
5195 ! t_p3main_accum = t_p3main_accum + (t_p3main_end-t_p3main_start)
5197 !.....................................................................................
5199 return
5201 END SUBROUTINE p3_main
5203 !==========================================================================================!
5205 SUBROUTINE access_lookup_table(dumjj,dumii,dumi,index,dum1,dum4,dum5,proc)
5207 implicit none
5209 real :: dum1,dum4,dum5,proc,iproc1,gproc1,tmp1,tmp2
5210 integer :: dumjj,dumii,dumi,index
5212 ! get value at current density index
5214 ! first interpolate for current rimed fraction index
5216 iproc1 = itab(dumjj,dumii,dumi,index)+(dum1-real(dumi))*(itab(dumjj,dumii, &
5217 dumi+1,index)-itab(dumjj,dumii,dumi,index))
5219 ! linearly interpolate to get process rates for rimed fraction index + 1
5221 gproc1 = itab(dumjj,dumii+1,dumi,index)+(dum1-real(dumi))*(itab(dumjj,dumii+1, &
5222 dumi+1,index)-itab(dumjj,dumii+1,dumi,index))
5224 tmp1 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
5226 ! get value at density index + 1
5228 ! first interpolate for current rimed fraction index
5230 iproc1 = itab(dumjj+1,dumii,dumi,index)+(dum1-real(dumi))*(itab(dumjj+1,dumii, &
5231 dumi+1,index)-itab(dumjj+1,dumii,dumi,index))
5233 ! linearly interpolate to get process rates for rimed fraction index + 1
5235 gproc1 = itab(dumjj+1,dumii+1,dumi,index)+(dum1-real(dumi))*(itab(dumjj+1, &
5236 dumii+1,dumi+1,index)-itab(dumjj+1,dumii+1,dumi,index))
5238 tmp2 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
5240 ! get final process rate
5241 proc = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
5243 END SUBROUTINE access_lookup_table
5245 !------------------------------------------------------------------------------------------!
5246 SUBROUTINE access_lookup_table_coll(dumjj,dumii,dumj,dumi,index,dum1,dum3, &
5247 dum4,dum5,proc)
5249 implicit none
5251 real :: dum1,dum3,dum4,dum5,proc,dproc1,dproc2,iproc1,gproc1,tmp1,tmp2
5252 integer :: dumjj,dumii,dumj,dumi,index
5255 ! This subroutine interpolates lookup table values for rain/ice collection processes
5257 ! current density index
5259 ! current rime fraction index
5260 dproc1 = itabcoll(dumjj,dumii,dumi,dumj,index)+(dum1-real(dumi))* &
5261 (itabcoll(dumjj,dumii,dumi+1,dumj,index)-itabcoll(dumjj,dumii,dumi, &
5262 dumj,index))
5264 dproc2 = itabcoll(dumjj,dumii,dumi,dumj+1,index)+(dum1-real(dumi))* &
5265 (itabcoll(dumjj,dumii,dumi+1,dumj+1,index)-itabcoll(dumjj,dumii,dumi, &
5266 dumj+1,index))
5268 iproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
5270 ! rime fraction index + 1
5272 dproc1 = itabcoll(dumjj,dumii+1,dumi,dumj,index)+(dum1-real(dumi))* &
5273 (itabcoll(dumjj,dumii+1,dumi+1,dumj,index)-itabcoll(dumjj,dumii+1, &
5274 dumi,dumj,index))
5276 dproc2 = itabcoll(dumjj,dumii+1,dumi,dumj+1,index)+(dum1-real(dumi))* &
5277 (itabcoll(dumjj,dumii+1,dumi+1,dumj+1,index)-itabcoll(dumjj,dumii+1, &
5278 dumi,dumj+1,index))
5280 gproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
5281 tmp1 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
5283 ! density index + 1
5285 ! current rime fraction index
5287 dproc1 = itabcoll(dumjj+1,dumii,dumi,dumj,index)+(dum1-real(dumi))* &
5288 (itabcoll(dumjj+1,dumii,dumi+1,dumj,index)-itabcoll(dumjj+1,dumii, &
5289 dumi,dumj,index))
5291 dproc2 = itabcoll(dumjj+1,dumii,dumi,dumj+1,index)+(dum1-real(dumi))* &
5292 (itabcoll(dumjj+1,dumii,dumi+1,dumj+1,index)-itabcoll(dumjj+1,dumii, &
5293 dumi,dumj+1,index))
5295 iproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
5297 ! rime fraction index + 1
5299 dproc1 = itabcoll(dumjj+1,dumii+1,dumi,dumj,index)+(dum1-real(dumi))* &
5300 (itabcoll(dumjj+1,dumii+1,dumi+1,dumj,index)-itabcoll(dumjj+1,dumii+1, &
5301 dumi,dumj,index))
5303 dproc2 = itabcoll(dumjj+1,dumii+1,dumi,dumj+1,index)+(dum1-real(dumi))* &
5304 (itabcoll(dumjj+1,dumii+1,dumi+1,dumj+1,index)-itabcoll(dumjj+1, &
5305 dumii+1,dumi,dumj+1,index))
5307 gproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
5308 tmp2 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
5310 ! interpolate over density to get final values
5311 proc = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
5313 END SUBROUTINE access_lookup_table_coll
5315 !------------------------------------------------------------------------------------------!
5317 SUBROUTINE access_lookup_table_colli(dumjjc,dumiic,dumic,dumjj,dumii,dumi,index, &
5318 dum1c,dum4c,dum5c,dum1,dum4,dum5,proc)
5320 implicit none
5322 real :: dum1,dum4,dum5,dum1c,dum4c,dum5c,proc,iproc1,iproc2, &
5323 gproc1,gproc2,rproc1,rproc2,tmp1,tmp2,dproc11,dproc12
5324 integer :: dumjj,dumii,dumi,index,dumjjc,dumiic,dumic
5327 ! This subroutine interpolates lookup table values for rain/ice collection processes
5329 ! current density index collectee category
5331 ! current rime fraction index for collectee category
5333 ! current density index collector category
5335 ! current rime fraction index for collector category
5337 if (index.eq.1) then
5339 dproc11 = itabcolli1(dumic,dumiic,dumjjc,dumi,dumii,dumjj)+(dum1c-real(dumic))* &
5340 (itabcolli1(dumic+1,dumiic,dumjjc,dumi,dumii,dumjj)- &
5341 itabcolli1(dumic,dumiic,dumjjc,dumi,dumii,dumjj))
5343 dproc12 = itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj)+(dum1c-real(dumic))* &
5344 (itabcolli1(dumic+1,dumiic,dumjjc,dumi+1,dumii,dumjj)- &
5345 itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj))
5347 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5350 ! collector rime fraction index + 1
5352 dproc11 = itabcolli1(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj)+(dum1c-real(dumic))* &
5353 (itabcolli1(dumic+1,dumiic,dumjjc,dumi,dumii+1,dumjj)- &
5354 itabcolli1(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj))
5356 dproc12 = itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))*&
5357 (itabcolli1(dumic+1,dumiic,dumjjc,dumi+1,dumii+1,dumjj)- &
5358 itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj))
5360 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5362 tmp1 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5364 ! collector density index + 1
5366 dproc11 = itabcolli1(dumic,dumiic,dumjjc,dumi,dumii,dumjj+1)+(dum1c-real(dumic))* &
5367 (itabcolli1(dumic+1,dumiic,dumjjc,dumi,dumii,dumjj+1)- &
5368 itabcolli1(dumic,dumiic,dumjjc,dumi,dumii,dumjj+1))
5370 dproc12 = itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))*&
5371 (itabcolli1(dumic+1,dumiic,dumjjc,dumi+1,dumii,dumjj+1)- &
5372 itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj+1))
5374 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5376 ! collector rime fraction index + 1
5378 dproc11 = itabcolli1(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5379 (itabcolli1(dumic+1,dumiic,dumjjc,dumi,dumii+1,dumjj+1)- &
5380 itabcolli1(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj+1))
5382 dproc12 = itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5383 (itabcolli1(dumic+1,dumiic,dumjjc,dumi+1,dumii+1,dumjj+1)- &
5384 itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj+1))
5386 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5388 tmp2 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5390 gproc1 = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
5392 !.......................................................................................................
5393 ! collectee rime fraction + 1
5395 dproc11 = itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj)+(dum1c-real(dumic))* &
5396 (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi,dumii,dumjj)- &
5397 itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj))
5399 dproc12 = itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj)+(dum1c-real(dumic))* &
5400 (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi+1,dumii,dumjj)- &
5401 itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj))
5403 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5405 ! collector rime fraction index + 1
5407 dproc11 = itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj)+(dum1c-real(dumic))* &
5408 (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi,dumii+1,dumjj)- &
5409 itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj))
5411 dproc12 = itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))* &
5412 (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj)- &
5413 itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj))
5415 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5417 tmp1 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5419 ! collector density index + 1
5421 dproc11 = itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj+1)+(dum1c-real(dumic))* &
5422 (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi,dumii,dumjj+1)- &
5423 itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj+1))
5425 dproc12 = itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))* &
5426 (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi+1,dumii,dumjj+1)- &
5427 itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj+1))
5429 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5431 ! collector rime fraction index + 1
5433 dproc11 = itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5434 (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi,dumii+1,dumjj+1)- &
5435 itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj+1))
5437 dproc12 = itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5438 (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj+1)- &
5439 itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj+1))
5441 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5443 tmp2 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5445 gproc2 = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
5447 rproc1 = gproc1+(dum4c-real(dumiic))*(gproc2-gproc1)
5449 !............................................................................................................
5450 ! collectee density index + 1
5452 dproc11 = itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj)+(dum1c-real(dumic))* &
5453 (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi,dumii,dumjj)- &
5454 itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj))
5456 dproc12 = itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj)+(dum1c-real(dumic))* &
5457 (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi+1,dumii,dumjj)- &
5458 itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj))
5460 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5462 ! collector rime fraction index + 1
5464 dproc11 = itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj)+(dum1c-real(dumic))* &
5465 (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi,dumii+1,dumjj)- &
5466 itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj))
5468 dproc12 = itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))* &
5469 (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj)- &
5470 itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj))
5472 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5474 tmp1 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5476 ! collector density index + 1
5478 dproc11 = itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj+1)+(dum1c-real(dumic))* &
5479 (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi,dumii,dumjj+1)- &
5480 itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj+1))
5482 dproc12 = itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))* &
5483 (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi+1,dumii,dumjj+1)- &
5484 itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj+1))
5486 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5488 ! collector rime fraction index + 1
5490 dproc11 = itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5491 (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi,dumii+1,dumjj+1)- &
5492 itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj+1))
5494 dproc12 = itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5495 (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj+1)- &
5496 itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj+1))
5498 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5500 tmp2 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5502 gproc1 = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
5504 !.......................................................................................................
5505 ! collectee rime fraction + 1
5507 dproc11 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj)+(dum1c-real(dumic))* &
5508 (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi,dumii,dumjj)- &
5509 itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj))
5511 dproc12 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj)+(dum1c-real(dumic))* &
5512 (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj)- &
5513 itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj))
5515 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5517 ! collector rime fraction index + 1
5519 dproc11 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj)+(dum1c-real(dumic))* &
5520 (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj)- &
5521 itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj))
5523 dproc12 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))* &
5524 (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj)- &
5525 itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj))
5527 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5529 tmp1 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5531 ! collector density index + 1
5533 dproc11 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj+1)+(dum1c-real(dumic))* &
5534 (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi,dumii,dumjj+1)- &
5535 itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj+1))
5537 dproc12 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))* &
5538 (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj+1)- &
5539 itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj+1))
5541 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5543 ! collector rime fraction index + 1
5545 dproc11 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5546 (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj+1)- &
5547 itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj+1))
5549 dproc12 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5550 (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj+1)- &
5551 itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj+1))
5553 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5555 tmp2 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5557 gproc2 = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
5559 rproc2 = gproc1+(dum4c-real(dumiic))*(gproc2-gproc1)
5561 !..........................................................................................
5562 ! final process rate interpolation over collectee density
5564 proc = rproc1+(dum5c-real(dumjjc))*(rproc2-rproc1)
5566 else if (index.eq.2) then
5568 dproc11 = itabcolli2(dumic,dumiic,dumjjc,dumi,dumii,dumjj)+(dum1c-real(dumic))* &
5569 (itabcolli2(dumic+1,dumiic,dumjjc,dumi,dumii,dumjj)- &
5570 itabcolli2(dumic,dumiic,dumjjc,dumi,dumii,dumjj))
5572 dproc12 = itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj)+(dum1c-real(dumic))* &
5573 (itabcolli2(dumic+1,dumiic,dumjjc,dumi+1,dumii,dumjj)- &
5574 itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj))
5576 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5578 ! collector rime fraction index + 1
5580 dproc11 = itabcolli2(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj)+(dum1c-real(dumic))* &
5581 (itabcolli2(dumic+1,dumiic,dumjjc,dumi,dumii+1,dumjj)- &
5582 itabcolli2(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj))
5584 dproc12 = itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))* &
5585 (itabcolli2(dumic+1,dumiic,dumjjc,dumi+1,dumii+1,dumjj)- &
5586 itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj))
5588 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5590 tmp1 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5592 ! collector density index + 1
5594 dproc11 = itabcolli2(dumic,dumiic,dumjjc,dumi,dumii,dumjj+1)+(dum1c-real(dumic))* &
5595 (itabcolli2(dumic+1,dumiic,dumjjc,dumi,dumii,dumjj+1)- &
5596 itabcolli2(dumic,dumiic,dumjjc,dumi,dumii,dumjj+1))
5598 dproc12 = itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))* &
5599 (itabcolli2(dumic+1,dumiic,dumjjc,dumi+1,dumii,dumjj+1)- &
5600 itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj+1))
5602 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5604 ! collector rime fraction index + 1
5606 dproc11 = itabcolli2(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5607 (itabcolli2(dumic+1,dumiic,dumjjc,dumi,dumii+1,dumjj+1)- &
5608 itabcolli2(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj+1))
5610 dproc12 = itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5611 (itabcolli2(dumic+1,dumiic,dumjjc,dumi+1,dumii+1,dumjj+1)- &
5612 itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj+1))
5614 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5616 tmp2 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5618 gproc1 = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
5620 !.......................................................................................................
5621 ! collectee rime fraction + 1
5623 dproc11 = itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj)+(dum1c-real(dumic))* &
5624 (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi,dumii,dumjj)- &
5625 itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj))
5627 dproc12 = itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj)+(dum1c-real(dumic))* &
5628 (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi+1,dumii,dumjj)- &
5629 itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj))
5631 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5633 ! collector rime fraction index + 1
5635 dproc11 = itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj)+(dum1c-real(dumic))* &
5636 (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi,dumii+1,dumjj)- &
5637 itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj))
5639 dproc12 = itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))* &
5640 (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj)- &
5641 itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj))
5643 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5645 tmp1 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5647 ! collector density index + 1
5649 dproc11 = itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj+1)+(dum1c-real(dumic))* &
5650 (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi,dumii,dumjj+1)- &
5651 itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj+1))
5653 dproc12 = itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))* &
5654 (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi+1,dumii,dumjj+1)- &
5655 itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj+1))
5657 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5659 ! collector rime fraction index + 1
5661 dproc11 = itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5662 (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi,dumii+1,dumjj+1)- &
5663 itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj+1))
5665 dproc12 = itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5666 (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj+1)- &
5667 itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj+1))
5669 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5671 tmp2 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5673 gproc2 = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
5675 rproc1 = gproc1+(dum4c-real(dumiic))*(gproc2-gproc1)
5677 !............................................................................................................
5678 ! collectee density index + 1
5680 dproc11 = itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj)+(dum1c-real(dumic))* &
5681 (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi,dumii,dumjj)- &
5682 itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj))
5684 dproc12 = itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj)+(dum1c-real(dumic))* &
5685 (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi+1,dumii,dumjj)- &
5686 itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj))
5688 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5690 ! collector rime fraction index + 1
5692 dproc11 = itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj)+(dum1c-real(dumic))* &
5693 (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi,dumii+1,dumjj)- &
5694 itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj))
5696 dproc12 = itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))* &
5697 (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj)- &
5698 itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj))
5700 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5702 tmp1 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5704 ! collector density index + 1
5706 dproc11 = itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj+1)+(dum1c-real(dumic))* &
5707 (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi,dumii,dumjj+1)- &
5708 itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj+1))
5710 dproc12 = itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))* &
5711 (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi+1,dumii,dumjj+1)- &
5712 itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj+1))
5714 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5716 ! collector rime fraction index + 1
5718 dproc11 = itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5719 (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi,dumii+1,dumjj+1)- &
5720 itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj+1))
5722 dproc12 = itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5723 (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj+1)- &
5724 itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj+1))
5726 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5728 tmp2 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5730 gproc1 = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
5732 !.......................................................................................................
5733 ! collectee rime fraction + 1
5735 dproc11 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj)+(dum1c-real(dumic))* &
5736 (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi,dumii,dumjj)- &
5737 itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj))
5739 dproc12 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj)+(dum1c-real(dumic))* &
5740 (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj)- &
5741 itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj))
5743 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5745 ! collector rime fraction index + 1
5747 dproc11 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj)+(dum1c-real(dumic))* &
5748 (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj)- &
5749 itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj))
5751 dproc12 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))* &
5752 (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj)- &
5753 itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj))
5755 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5757 tmp1 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5759 ! collector density index + 1
5761 dproc11 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj+1)+(dum1c-real(dumic))* &
5762 (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi,dumii,dumjj+1)- &
5763 itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj+1))
5765 dproc12 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))* &
5766 (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj+1)- &
5767 itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj+1))
5769 iproc1 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5771 ! collector rime fraction index + 1
5773 dproc11 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5774 (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj+1)- &
5775 itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj+1))
5777 dproc12 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
5778 (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj+1)- &
5779 itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj+1))
5781 iproc2 = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
5783 tmp2 = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
5785 gproc2 = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
5787 rproc2 = gproc1+(dum4c-real(dumiic))*(gproc2-gproc1)
5789 !..........................................................................................
5790 ! final process rate interpolation over collectee density
5792 proc = rproc1+(dum5c-real(dumjjc))*(rproc2-rproc1)
5794 endif ! index =1 or 2
5796 END SUBROUTINE access_lookup_table_colli
5798 !==========================================================================================!
5800 SUBROUTINE access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,index,dum1,dum4,dum5,dum6,proc)
5802 implicit none
5804 real :: dum1,dum4,dum5,dum6,proc,iproc1,gproc1,tmp1,tmp2,rproc1,rproc2
5805 integer :: dumzz,dumjj,dumii,dumi,index
5807 ! get value at current G index
5809 ! get value at current density index
5811 ! first interpolate for current rimed fraction index
5813 iproc1 = itab_3mom(dumzz,dumjj,dumii,dumi,index)+(dum1-real(dumi))*(itab_3mom(dumzz,dumjj,dumii, &
5814 dumi+1,index)-itab_3mom(dumzz,dumjj,dumii,dumi,index))
5816 ! linearly interpolate to get process rates for rimed fraction index + 1
5818 gproc1 = itab_3mom(dumzz,dumjj,dumii+1,dumi,index)+(dum1-real(dumi))*(itab_3mom(dumzz,dumjj,dumii+1, &
5819 dumi+1,index)-itab_3mom(dumzz,dumjj,dumii+1,dumi,index))
5821 tmp1 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
5823 ! get value at density index + 1
5825 ! first interpolate for current rimed fraction index
5827 iproc1 = itab_3mom(dumzz,dumjj+1,dumii,dumi,index)+(dum1-real(dumi))*(itab_3mom(dumzz,dumjj+1,dumii, &
5828 dumi+1,index)-itab_3mom(dumzz,dumjj+1,dumii,dumi,index))
5830 ! linearly interpolate to get process rates for rimed fraction index + 1
5832 gproc1 = itab_3mom(dumzz,dumjj+1,dumii+1,dumi,index)+(dum1-real(dumi))*(itab_3mom(dumzz,dumjj+1, &
5833 dumii+1,dumi+1,index)-itab_3mom(dumzz,dumjj+1,dumii+1,dumi,index))
5835 tmp2 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
5837 ! get process rate
5838 rproc1 = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
5840 !.............................................................
5842 ! get value at G index + 1
5844 ! get value at current density index
5846 ! first interpolate for current rimed fraction index
5848 iproc1 = itab_3mom(dumzz+1,dumjj,dumii,dumi,index)+(dum1-real(dumi))*(itab_3mom(dumzz+1,dumjj,dumii, &
5849 dumi+1,index)-itab_3mom(dumzz+1,dumjj,dumii,dumi,index))
5851 ! linearly interpolate to get process rates for rimed fraction index + 1
5853 gproc1 = itab_3mom(dumzz+1,dumjj,dumii+1,dumi,index)+(dum1-real(dumi))*(itab_3mom(dumzz+1,dumjj,dumii+1, &
5854 dumi+1,index)-itab_3mom(dumzz+1,dumjj,dumii+1,dumi,index))
5856 tmp1 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
5858 ! get value at density index + 1
5860 ! first interpolate for current rimed fraction index
5862 iproc1 = itab_3mom(dumzz+1,dumjj+1,dumii,dumi,index)+(dum1-real(dumi))*(itab_3mom(dumzz+1,dumjj+1,dumii, &
5863 dumi+1,index)-itab_3mom(dumzz+1,dumjj+1,dumii,dumi,index))
5865 ! linearly interpolate to get process rates for rimed fraction index + 1
5867 gproc1 = itab_3mom(dumzz+1,dumjj+1,dumii+1,dumi,index)+(dum1-real(dumi))*(itab_3mom(dumzz+1,dumjj+1, &
5868 dumii+1,dumi+1,index)-itab_3mom(dumzz+1,dumjj+1,dumii+1,dumi,index))
5870 tmp2 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
5872 ! get process rate
5873 rproc2 = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
5875 ! get final process rate
5877 proc = rproc1+(dum6-real(dumzz))*(rproc2-rproc1)
5879 END SUBROUTINE access_lookup_table_3mom
5881 !------------------------------------------------------------------------------------------!
5882 SUBROUTINE access_lookup_table_coll_3mom(dumzz,dumjj,dumii,dumj,dumi,index,dum1,dum3, &
5883 dum4,dum5,dum6,proc)
5885 implicit none
5887 real :: dum1,dum3,dum4,dum5,dum6,proc,dproc1,dproc2,iproc1,gproc1,tmp1,tmp2,rproc1,rproc2
5888 integer :: dumzz,dumjj,dumii,dumj,dumi,index
5891 ! This subroutine interpolates lookup table values for rain/ice collection processes
5893 ! current G index
5895 ! current density index
5897 ! current rime fraction index
5898 dproc1 = itabcoll_3mom(dumzz,dumjj,dumii,dumi,dumj,index)+(dum1-real(dumi))* &
5899 (itabcoll_3mom(dumzz,dumjj,dumii,dumi+1,dumj,index)-itabcoll_3mom(dumzz,dumjj,dumii,dumi, &
5900 dumj,index))
5902 dproc2 = itabcoll_3mom(dumzz,dumjj,dumii,dumi,dumj+1,index)+(dum1-real(dumi))* &
5903 (itabcoll_3mom(dumzz,dumjj,dumii,dumi+1,dumj+1,index)-itabcoll_3mom(dumzz,dumjj,dumii,dumi, &
5904 dumj+1,index))
5906 iproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
5908 ! rime fraction index + 1
5910 dproc1 = itabcoll_3mom(dumzz,dumjj,dumii+1,dumi,dumj,index)+(dum1-real(dumi))* &
5911 (itabcoll_3mom(dumzz,dumjj,dumii+1,dumi+1,dumj,index)-itabcoll_3mom(dumzz,dumjj,dumii+1, &
5912 dumi,dumj,index))
5914 dproc2 = itabcoll_3mom(dumzz,dumjj,dumii+1,dumi,dumj+1,index)+(dum1-real(dumi))* &
5915 (itabcoll_3mom(dumzz,dumjj,dumii+1,dumi+1,dumj+1,index)-itabcoll_3mom(dumzz,dumjj,dumii+1, &
5916 dumi,dumj+1,index))
5918 gproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
5919 tmp1 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
5921 ! density index + 1
5923 ! current rime fraction index
5925 dproc1 = itabcoll_3mom(dumzz,dumjj+1,dumii,dumi,dumj,index)+(dum1-real(dumi))* &
5926 (itabcoll_3mom(dumzz,dumjj+1,dumii,dumi+1,dumj,index)-itabcoll_3mom(dumzz,dumjj+1,dumii, &
5927 dumi,dumj,index))
5929 dproc2 = itabcoll_3mom(dumzz,dumjj+1,dumii,dumi,dumj+1,index)+(dum1-real(dumi))* &
5930 (itabcoll_3mom(dumzz,dumjj+1,dumii,dumi+1,dumj+1,index)-itabcoll_3mom(dumzz,dumjj+1,dumii, &
5931 dumi,dumj+1,index))
5933 iproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
5935 ! rime fraction index + 1
5937 dproc1 = itabcoll_3mom(dumzz,dumjj+1,dumii+1,dumi,dumj,index)+(dum1-real(dumi))* &
5938 (itabcoll_3mom(dumzz,dumjj+1,dumii+1,dumi+1,dumj,index)-itabcoll_3mom(dumzz,dumjj+1,dumii+1, &
5939 dumi,dumj,index))
5941 dproc2 = itabcoll_3mom(dumzz,dumjj+1,dumii+1,dumi,dumj+1,index)+(dum1-real(dumi))* &
5942 (itabcoll_3mom(dumzz,dumjj+1,dumii+1,dumi+1,dumj+1,index)-itabcoll_3mom(dumzz,dumjj+1, &
5943 dumii+1,dumi,dumj+1,index))
5945 gproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
5946 tmp2 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
5948 ! interpolate over density
5949 rproc1 = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
5951 !.....................................................................................
5952 ! G index + 1
5954 ! current density index
5956 ! current rime fraction index
5957 dproc1 = itabcoll_3mom(dumzz+1,dumjj,dumii,dumi,dumj,index)+(dum1-real(dumi))* &
5958 (itabcoll_3mom(dumzz+1,dumjj,dumii,dumi+1,dumj,index)-itabcoll_3mom(dumzz+1,dumjj,dumii,dumi, &
5959 dumj,index))
5961 dproc2 = itabcoll_3mom(dumzz+1,dumjj,dumii,dumi,dumj+1,index)+(dum1-real(dumi))* &
5962 (itabcoll_3mom(dumzz+1,dumjj,dumii,dumi+1,dumj+1,index)-itabcoll_3mom(dumzz+1,dumjj,dumii,dumi, &
5963 dumj+1,index))
5965 iproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
5967 ! rime fraction index + 1
5969 dproc1 = itabcoll_3mom(dumzz+1,dumjj,dumii+1,dumi,dumj,index)+(dum1-real(dumi))* &
5970 (itabcoll_3mom(dumzz+1,dumjj,dumii+1,dumi+1,dumj,index)-itabcoll_3mom(dumzz+1,dumjj,dumii+1, &
5971 dumi,dumj,index))
5973 dproc2 = itabcoll_3mom(dumzz+1,dumjj,dumii+1,dumi,dumj+1,index)+(dum1-real(dumi))* &
5974 (itabcoll_3mom(dumzz+1,dumjj,dumii+1,dumi+1,dumj+1,index)-itabcoll_3mom(dumzz+1,dumjj,dumii+1, &
5975 dumi,dumj+1,index))
5977 gproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
5978 tmp1 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
5980 ! density index + 1
5982 ! current rime fraction index
5984 dproc1 = itabcoll_3mom(dumzz+1,dumjj+1,dumii,dumi,dumj,index)+(dum1-real(dumi))* &
5985 (itabcoll_3mom(dumzz+1,dumjj+1,dumii,dumi+1,dumj,index)-itabcoll_3mom(dumzz+1,dumjj+1,dumii, &
5986 dumi,dumj,index))
5988 dproc2 = itabcoll_3mom(dumzz+1,dumjj+1,dumii,dumi,dumj+1,index)+(dum1-real(dumi))* &
5989 (itabcoll_3mom(dumzz+1,dumjj+1,dumii,dumi+1,dumj+1,index)-itabcoll_3mom(dumzz+1,dumjj+1,dumii, &
5990 dumi,dumj+1,index))
5992 iproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
5994 ! rime fraction index + 1
5996 dproc1 = itabcoll_3mom(dumzz+1,dumjj+1,dumii+1,dumi,dumj,index)+(dum1-real(dumi))* &
5997 (itabcoll_3mom(dumzz+1,dumjj+1,dumii+1,dumi+1,dumj,index)-itabcoll_3mom(dumzz+1,dumjj+1,dumii+1, &
5998 dumi,dumj,index))
6000 dproc2 = itabcoll_3mom(dumzz+1,dumjj+1,dumii+1,dumi,dumj+1,index)+(dum1-real(dumi))* &
6001 (itabcoll_3mom(dumzz+1,dumjj+1,dumii+1,dumi+1,dumj+1,index)-itabcoll_3mom(dumzz+1,dumjj+1, &
6002 dumii+1,dumi,dumj+1,index))
6004 gproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
6005 tmp2 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
6007 ! interpolate over density
6008 rproc2 = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
6010 ! get final process rate by interpolation over G
6011 proc = rproc1+(dum6-real(dumzz))*(rproc2-rproc1)
6013 END SUBROUTINE access_lookup_table_coll_3mom
6015 !==========================================================================================!
6017 real function polysvp1(T,i_type)
6019 !-------------------------------------------
6020 ! COMPUTE SATURATION VAPOR PRESSURE
6021 ! POLYSVP1 RETURNED IN UNITS OF PA.
6022 ! T IS INPUT IN UNITS OF K.
6023 ! i_type REFERS TO SATURATION WITH RESPECT TO LIQUID (0) OR ICE (1)
6024 !-------------------------------------------
6026 implicit none
6028 real :: T
6029 integer :: i_type
6031 ! REPLACE GOFF-GRATCH WITH FASTER FORMULATION FROM FLATAU ET AL. 1992, TABLE 4 (RIGHT-HAND COLUMN)
6033 ! ice
6034 real a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i
6035 data a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i /&
6036 6.11147274, 0.503160820, 0.188439774e-1, &
6037 0.420895665e-3, 0.615021634e-5,0.602588177e-7, &
6038 0.385852041e-9, 0.146898966e-11, 0.252751365e-14/
6040 ! liquid
6041 real a0,a1,a2,a3,a4,a5,a6,a7,a8
6043 ! V1.7
6044 data a0,a1,a2,a3,a4,a5,a6,a7,a8 /&
6045 6.11239921, 0.443987641, 0.142986287e-1, &
6046 0.264847430e-3, 0.302950461e-5, 0.206739458e-7, &
6047 0.640689451e-10,-0.952447341e-13,-0.976195544e-15/
6048 real dt
6050 !-------------------------------------------
6052 if (i_type.EQ.1 .and. T.lt.273.15) then
6053 ! ICE
6055 ! use Goff-Gratch for T < 195.8 K and Flatau et al. equal or above 195.8 K
6056 if (t.ge.195.8) then
6057 dt=t-273.15
6058 polysvp1 = a0i + dt*(a1i+dt*(a2i+dt*(a3i+dt*(a4i+dt*(a5i+dt*(a6i+dt*(a7i+a8i*dt)))))))
6059 polysvp1 = polysvp1*100.
6060 else
6061 polysvp1 = 10.**(-9.09718*(273.16/t-1.)-3.56654* &
6062 alog10(273.16/t)+0.876793*(1.-t/273.16)+ &
6063 alog10(6.1071))*100.
6064 end if
6066 elseif (i_type.EQ.0 .or. T.ge.273.15) then
6067 ! LIQUID
6069 ! use Goff-Gratch for T < 202.0 K and Flatau et al. equal or above 202.0 K
6070 if (t.ge.202.0) then
6071 dt = t-273.15
6072 polysvp1 = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt)))))))
6073 polysvp1 = polysvp1*100.
6074 else
6075 ! note: uncertain below -70 C, but produces physical values (non-negative) unlike flatau
6076 polysvp1 = 10.**(-7.90298*(373.16/t-1.)+ &
6077 5.02808*alog10(373.16/t)- &
6078 1.3816e-7*(10**(11.344*(1.-t/373.16))-1.)+ &
6079 8.1328e-3*(10**(-3.49149*(373.16/t-1.))-1.)+ &
6080 alog10(1013.246))*100.
6081 end if
6083 endif
6086 end function polysvp1
6088 !------------------------------------------------------------------------------------------!
6090 real function DERF(X)
6092 implicit none
6094 real :: X
6095 real, dimension(0 : 64) :: A, B
6096 real :: W,T,Y
6097 integer :: K,I
6098 data A/ &
6099 0.00000000005958930743E0, -0.00000000113739022964E0, &
6100 0.00000001466005199839E0, -0.00000016350354461960E0, &
6101 0.00000164610044809620E0, -0.00001492559551950604E0, &
6102 0.00012055331122299265E0, -0.00085483269811296660E0, &
6103 0.00522397762482322257E0, -0.02686617064507733420E0, &
6104 0.11283791670954881569E0, -0.37612638903183748117E0, &
6105 1.12837916709551257377E0, &
6106 0.00000000002372510631E0, -0.00000000045493253732E0, &
6107 0.00000000590362766598E0, -0.00000006642090827576E0, &
6108 0.00000067595634268133E0, -0.00000621188515924000E0, &
6109 0.00005103883009709690E0, -0.00037015410692956173E0, &
6110 0.00233307631218880978E0, -0.01254988477182192210E0, &
6111 0.05657061146827041994E0, -0.21379664776456006580E0, &
6112 0.84270079294971486929E0, &
6113 0.00000000000949905026E0, -0.00000000018310229805E0, &
6114 0.00000000239463074000E0, -0.00000002721444369609E0, &
6115 0.00000028045522331686E0, -0.00000261830022482897E0, &
6116 0.00002195455056768781E0, -0.00016358986921372656E0, &
6117 0.00107052153564110318E0, -0.00608284718113590151E0, &
6118 0.02986978465246258244E0, -0.13055593046562267625E0, &
6119 0.67493323603965504676E0, &
6120 0.00000000000382722073E0, -0.00000000007421598602E0, &
6121 0.00000000097930574080E0, -0.00000001126008898854E0, &
6122 0.00000011775134830784E0, -0.00000111992758382650E0, &
6123 0.00000962023443095201E0, -0.00007404402135070773E0, &
6124 0.00050689993654144881E0, -0.00307553051439272889E0, &
6125 0.01668977892553165586E0, -0.08548534594781312114E0, &
6126 0.56909076642393639985E0, &
6127 0.00000000000155296588E0, -0.00000000003032205868E0, &
6128 0.00000000040424830707E0, -0.00000000471135111493E0, &
6129 0.00000005011915876293E0, -0.00000048722516178974E0, &
6130 0.00000430683284629395E0, -0.00003445026145385764E0, &
6131 0.00024879276133931664E0, -0.00162940941748079288E0, &
6132 0.00988786373932350462E0, -0.05962426839442303805E0, &
6133 0.49766113250947636708E0 /
6134 data (B(I), I = 0, 12) / &
6135 -0.00000000029734388465E0, 0.00000000269776334046E0, &
6136 -0.00000000640788827665E0, -0.00000001667820132100E0, &
6137 -0.00000021854388148686E0, 0.00000266246030457984E0, &
6138 0.00001612722157047886E0, -0.00025616361025506629E0, &
6139 0.00015380842432375365E0, 0.00815533022524927908E0, &
6140 -0.01402283663896319337E0, -0.19746892495383021487E0, &
6141 0.71511720328842845913E0 /
6142 data (B(I), I = 13, 25) / &
6143 -0.00000000001951073787E0, -0.00000000032302692214E0, &
6144 0.00000000522461866919E0, 0.00000000342940918551E0, &
6145 -0.00000035772874310272E0, 0.00000019999935792654E0, &
6146 0.00002687044575042908E0, -0.00011843240273775776E0, &
6147 -0.00080991728956032271E0, 0.00661062970502241174E0, &
6148 0.00909530922354827295E0, -0.20160072778491013140E0, &
6149 0.51169696718727644908E0 /
6150 data (B(I), I = 26, 38) / &
6151 0.00000000003147682272E0, -0.00000000048465972408E0, &
6152 0.00000000063675740242E0, 0.00000003377623323271E0, &
6153 -0.00000015451139637086E0, -0.00000203340624738438E0, &
6154 0.00001947204525295057E0, 0.00002854147231653228E0, &
6155 -0.00101565063152200272E0, 0.00271187003520095655E0, &
6156 0.02328095035422810727E0, -0.16725021123116877197E0, &
6157 0.32490054966649436974E0 /
6158 data (B(I), I = 39, 51) / &
6159 0.00000000002319363370E0, -0.00000000006303206648E0, &
6160 -0.00000000264888267434E0, 0.00000002050708040581E0, &
6161 0.00000011371857327578E0, -0.00000211211337219663E0, &
6162 0.00000368797328322935E0, 0.00009823686253424796E0, &
6163 -0.00065860243990455368E0, -0.00075285814895230877E0, &
6164 0.02585434424202960464E0, -0.11637092784486193258E0, &
6165 0.18267336775296612024E0 /
6166 data (B(I), I = 52, 64) / &
6167 -0.00000000000367789363E0, 0.00000000020876046746E0, &
6168 -0.00000000193319027226E0, -0.00000000435953392472E0, &
6169 0.00000018006992266137E0, -0.00000078441223763969E0, &
6170 -0.00000675407647949153E0, 0.00008428418334440096E0, &
6171 -0.00017604388937031815E0, -0.00239729611435071610E0, &
6172 0.02064129023876022970E0, -0.06905562880005864105E0, &
6173 0.09084526782065478489E0 /
6174 W = ABS(X)
6175 if (W .LT. 2.2D0) then
6176 T = W * W
6177 K = INT(T)
6178 T = T - K
6179 K = K * 13
6180 Y = ((((((((((((A(K) * T + A(K + 1)) * T + &
6181 A(K + 2)) * T + A(K + 3)) * T + A(K + 4)) * T + &
6182 A(K + 5)) * T + A(K + 6)) * T + A(K + 7)) * T + &
6183 A(K + 8)) * T + A(K + 9)) * T + A(K + 10)) * T + &
6184 A(K + 11)) * T + A(K + 12)) * W
6185 elseif (W .LT. 6.9D0) then
6186 K = INT(W)
6187 T = W - K
6188 K = 13 * (K - 2)
6189 Y = (((((((((((B(K) * T + B(K + 1)) * T + &
6190 B(K + 2)) * T + B(K + 3)) * T + B(K + 4)) * T + &
6191 B(K + 5)) * T + B(K + 6)) * T + B(K + 7)) * T + &
6192 B(K + 8)) * T + B(K + 9)) * T + B(K + 10)) * T + &
6193 B(K + 11)) * T + B(K + 12)
6194 Y = Y * Y
6195 Y = Y * Y
6196 Y = Y * Y
6197 Y = 1 - Y * Y
6198 else
6199 Y = 1
6200 endif
6201 if (X .LT. 0) Y = -Y
6202 DERF = Y
6204 end function DERF
6206 !------------------------------------------------------------------------------------------!
6207 logical function isnan(arg1)
6208 real,intent(in) :: arg1
6209 isnan = (arg1 .ne. arg1)
6210 return
6211 end function isnan
6213 !==========================================================================================!
6214 subroutine icecat_destination(Qi,Di,D_nuc,deltaD_init,iice_dest)
6216 !--------------------------------------------------------------------------------------!
6217 ! Returns the index of the destination ice category into which new ice is nucleated.
6218 !
6219 ! New ice will be nucleated into the category in which the existing ice is
6220 ! closest in size to the ice being nucleated. The exception is that if the
6221 ! size difference between the nucleated ice and existing ice exceeds a threshold
6222 ! value for all categories, then ice is initiated into a new category.
6223 !
6224 ! D_nuc = mean diameter of new particles being added to a category
6225 ! D(i) = mean diameter of particles in category i
6226 ! diff(i) = |D(i) - D_nuc|
6227 ! deltaD_init = threshold size difference to consider a new (empty) category
6228 ! mindiff = minimum of all diff(i) (for non-empty categories)
6229 !
6230 ! POSSIBLE CASES DESTINATION CATEGORY
6231 !--------------- --------------------
6232 ! case 1: all empty category 1
6233 ! case 2: all full category with smallest diff
6234 ! case 3: partly full
6235 ! case 3a: mindiff < diff_thrs category with smallest diff
6236 ! case 3b: mindiff >= diff_thrs first empty category
6237 !--------------------------------------------------------------------------------------!
6239 implicit none
6241 ! arguments:
6242 real, intent(in), dimension(:) :: Qi,Di
6243 real, intent(in) :: D_nuc,deltaD_init
6244 integer, intent(out) :: iice_dest
6246 ! local variables:
6247 logical :: all_full,all_empty
6248 integer :: i_firstEmptyCategory,iice,i_mindiff,n_cat
6249 real :: mindiff,diff
6250 real, parameter :: qsmall_loc = 1.e-14
6252 !--------------------------------------------------------------------------------------!
6254 n_cat = size(Qi)
6255 iice_dest = -99
6257 !-- test:
6258 ! iice_dest = 1
6259 ! return
6260 !==
6262 if (sum(Qi(:))<qsmall_loc) then
6264 !case 1:
6265 iice_dest = 1
6266 return
6268 else
6270 all_full = .true.
6271 all_empty = .false.
6272 mindiff = 9.e+9
6273 i_firstEmptyCategory = 0
6275 do iice = 1,n_cat
6276 if (Qi(iice) .ge. qsmall_loc) then
6277 all_empty = .false.
6278 diff = abs(Di(iice)-D_nuc)
6279 if (diff .lt. mindiff) then
6280 mindiff = diff
6281 i_mindiff = iice
6282 endif
6283 else
6284 all_full = .false.
6285 if (i_firstEmptyCategory.eq.0) i_firstEmptyCategory = iice
6286 endif
6287 enddo
6289 if (all_full) then
6290 !case 2:
6291 iice_dest = i_mindiff
6292 return
6293 else
6294 if (mindiff .lt. deltaD_init) then
6295 !case 3a:
6296 iice_dest = i_mindiff
6297 return
6298 else
6299 !case 3b:
6300 iice_dest = i_firstEmptyCategory
6301 return
6302 endif
6303 endif
6305 endif
6307 print*, 'ERROR in s/r icecat_destination -- made it to end'
6308 global_status = STATUS_ERROR
6309 return
6311 end subroutine icecat_destination
6314 !======================================================================================!
6316 subroutine find_lookupTable_indices_1a(dumi,dumjj,dumii,dum1,dum4,dum5,isize,rimsize, &
6317 densize,qitot,nitot,qirim,rhop)
6319 !------------------------------------------------------------------------------------------!
6320 ! Finds indices in 3D ice (only) lookup table.
6321 ! - used for P3 v4
6322 !------------------------------------------------------------------------------------------!
6324 implicit none
6326 ! arguments:
6327 integer, intent(out) :: dumi,dumjj,dumii
6328 real, intent(out) :: dum1,dum4,dum5
6329 integer, intent(in) :: isize,rimsize,densize
6330 real, intent(in) :: qitot,nitot,qirim,rhop
6332 !------------------------------------------------------------------------------------------!
6334 ! find index for qi (normalized ice mass mixing ratio = qitot/nitot)
6336 ! we are inverting this equation from the lookup table to solve for i_Qnorm:
6337 ! from create_LT1: q = 800.**((i_Qnorm+10)*0.1)*1.e-18 [where q = qitot/nitot]
6338 !dum1 = (alog10(qitot/nitot)+18.)/(0.1*alog10(800.)) - 10. !original
6339 dum1 = (alog10(qitot/nitot)+18.)*3.444606 - 10. !optimized
6340 dumi = int(dum1)
6341 ! set limits (to make sure the calculated index doesn't exceed range of lookup table)
6342 dum1 = min(dum1,real(isize))
6343 dum1 = max(dum1,1.)
6344 dumi = max(1,dumi)
6345 dumi = min(isize-1,dumi)
6347 ! find index for rime mass fraction
6348 dum4 = (qirim/qitot)*3. + 1.
6349 dumii = int(dum4)
6350 ! set limits
6351 dum4 = min(dum4,real(rimsize))
6352 dum4 = max(dum4,1.)
6353 dumii = max(1,dumii)
6354 dumii = min(rimsize-1,dumii)
6356 ! find index for bulk rime density
6357 ! (account for uneven spacing in lookup table for density)
6358 if (rhop.le.650.) then
6359 dum5 = (rhop-50.)*0.005 + 1.
6360 else
6361 dum5 =(rhop-650.)*0.004 + 4.
6362 endif
6363 dumjj = int(dum5)
6364 ! set limits
6365 dum5 = min(dum5,real(densize))
6366 dum5 = max(dum5,1.)
6367 dumjj = max(1,dumjj)
6368 dumjj = min(densize-1,dumjj)
6370 end subroutine find_lookupTable_indices_1a
6372 !======================================================================================!
6374 subroutine find_lookupTable_indices_1b(dumj,dum3,rcollsize,qr,nr)
6376 !------------------------------------------------------------------------------------------!
6377 ! Finds indices in 3D rain lookup table, for 2-moment and 3-moment ice
6378 !------------------------------------------------------------------------------------------!
6380 implicit none
6382 ! arguments:
6383 integer, intent(out) :: dumj
6384 real, intent(out) :: dum3
6385 integer, intent(in) :: rcollsize
6386 real, intent(in) :: qr,nr
6388 ! local variables:
6389 real :: dumlr
6391 !------------------------------------------------------------------------------------------!
6393 ! find index for scaled mean rain size
6394 ! if no rain, then just choose dumj = 1 and do not calculate rain-ice collection processes
6395 if (qr.ge.qsmall .and. nr.gt.0.) then
6396 ! calculate scaled mean size for consistency with ice lookup table
6397 dumlr = (qr/(pi*rhow*nr))**thrd
6398 dum3 = (alog10(1.*dumlr)+5.)*10.70415
6399 dumj = int(dum3)
6400 ! set limits
6401 dum3 = min(dum3,real_rcollsize)
6402 dum3 = max(dum3,1.)
6403 dumj = max(1,dumj)
6404 dumj = min(rcollsize-1,dumj)
6405 else
6406 dumj = 1
6407 dum3 = 1.
6408 endif
6410 end subroutine find_lookupTable_indices_1b
6412 !======================================================================================!
6414 subroutine find_lookupTable_indices_1c(dumzz,dum6,zsize,qitot,mu_i)
6416 !------------------------------------------------------------------------------------------!
6417 ! Finds indices for G index in 3-moment ice lookup table
6418 !------------------------------------------------------------------------------------------!
6420 implicit none
6422 ! arguments:
6423 integer, intent(out) :: dumzz
6424 integer, intent(in) :: zsize
6425 real, intent(out) :: dum6
6426 real, intent(in) :: qitot,mu_i
6428 !------------------------------------------------------------------------------------------!
6430 ! find index for mu_i
6431 if (qitot.ge.qsmall) then
6432 ! we are inverting this equation from the lookup table to solve for i:
6433 ! use old formula for now, we are solving zitot/qitot=9^(i)*1.e-23, for beta <= 7 lookup table
6434 ! dum6 = (alog10(zitot/qitot)+23.)/alog10(9.)
6435 ! use new formula for beta >= 9 lookup table
6436 ! zitot/qitot=2.1^(i)*1.e-23
6438 ! dum6 = (alog10(zitot/qitot)+23.)/alog10(2.1)
6439 ! dum6 = (alog10(zitot/qitot)+23.)*3.10347652 !optimization
6440 ! HM replace with mu_i
6441 ! dum6 = mu_i/2.+1. ! invert lookup table indices
6442 dum6 = mu_i*0.5+1. ! optimized
6444 ! for "two-moment", setting a constant mu = 0
6445 ! dum6 = 100. ! set dum6 to a very large value, corresponding to mu = 0
6447 dumzz = int(dum6)
6448 dum6 = min(dum6,real(zsize))
6449 dum6 = max(dum6,1.)
6450 dumzz = max(1,dumzz)
6451 dumzz = min(zsize-1,dumzz)
6453 else
6455 dumzz = 1
6456 dum6 = 1.
6458 endif
6460 end subroutine find_lookupTable_indices_1c
6462 !======================================================================================!
6463 subroutine find_lookupTable_indices_2(dumi, dumii, dumjj, dumic, dumiic, dumjjc, &
6464 dum1, dum4, dum5, dum1c, dum4c, dum5c, &
6465 iisize, rimsize, densize, &
6466 qitot_1, qitot_2, nitot_1, nitot_2, &
6467 qirim_1, qirim_2, birim_1, birim_2)
6469 !------------------------------------------------------------------------------------------!
6470 ! Finds indices in ice-ice interaction lookup table (2)
6471 !------------------------------------------------------------------------------------------!
6473 implicit none
6475 ! arguments:
6476 integer, intent(out) :: dumi, dumii, dumjj, dumic, dumiic, dumjjc
6477 real, intent(out) :: dum1, dum4, dum5, dum1c, dum4c, dum5c
6478 integer, intent(in) :: iisize, rimsize, densize
6479 real, intent(in) :: qitot_1,qitot_2,nitot_1,nitot_2,qirim_1,qirim_2,birim_1,birim_2
6481 ! local variables:
6482 real :: drhop
6484 !------------------------------------------------------------------------------------------!
6486 ! find index in lookup table for collector category
6488 ! find index for qi (total ice mass mixing ratio)
6490 ! !-- For LT2-5.0 (Dm_max = 2000.)
6491 ! ! inverting the following (from create_LT2): q = 261.7**((i+5)*0.2)*1.e-18
6492 ! ! where q = qitot/nitot (normalized)
6493 ! !dum1 = (alog10(qitot_1/nitot_1)+18.)/(0.2*alog10(261.7))-5. !orig
6494 ! dum1 = (alog10(qitot_1/nitot_1)+18.)*(2.06799)-5. !optimization
6496 !-- For LT2-5.1 (Dm_max = 400000.)
6497 ! inverting this equation from the lookup table to solve for i_Qnorm:
6498 ! from create_LT2: q = 800.**(0.2*(i_Qnorm+5))*1.e-18 [where q = qitot/nitot]
6499 !dum1 = (alog10(qitot_1/nitot_1)+18.)/(0.2*alog10(800.)) - 5. !original
6500 dum1 = (alog10(qitot_1/nitot_1)+18.)*1.722303 - 5. !optimized
6502 dumi = int(dum1)
6503 dum1 = min(dum1,real(iisize))
6504 dum1 = max(dum1,1.)
6505 dumi = max(1,dumi)
6506 dumi = min(iisize-1,dumi)
6508 ! note that the code below for finding rime mass fraction and density index is
6509 ! redundant with code for main ice lookup table and can probably be omitted
6510 ! for efficiency; for now it is left in
6512 ! find index for rime mass fraction
6513 dum4 = qirim_1/qitot_1*3. + 1.
6514 dumii = int(dum4)
6515 dum4 = min(dum4,real(rimsize))
6516 dum4 = max(dum4,1.)
6517 dumii = max(1,dumii)
6518 dumii = min(rimsize-1,dumii)
6521 ! find index for bulk rime density
6522 ! (account for uneven spacing in lookup table for density)
6523 ! bulk rime density
6524 if (birim_1.ge.bsmall) then
6525 drhop = qirim_1/birim_1
6526 else
6527 drhop = 0.
6528 endif
6530 if (drhop.le.650.) then
6531 dum5 = (drhop-50.)*0.005 + 1.
6532 else
6533 dum5 =(drhop-650.)*0.004 + 4.
6534 endif
6535 dumjj = int(dum5)
6536 dum5 = min(dum5,real(densize))
6537 dum5 = max(dum5,1.)
6538 dumjj = max(1,dumjj)
6539 dumjj = min(densize-1,dumjj)
6541 ! find index in lookup table for collectee category, here 'q' is a scaled q/N
6542 ! find index for qi (total ice mass mixing ratio)
6543 ! !dum1c = (alog10(qitot_2/nitot_2)+18.)/(0.2*alog10(261.7))-5. !orig
6544 ! dum1c = (alog10(qitot_2/nitot_2)+18.)/(0.483561)-5. !for computational efficiency
6546 !-- For LT2-5.1 (Dm_max = 400000.)
6547 ! inverting this equation from the lookup table to solve for i_Qnorm:
6548 ! from create_LT2: q = 800.**(0.2*(i_Qnorm+5))*1.e-18 [where q = qitot/nitot]
6549 !dum1c = (alog10(qitot_1/nitot_1)+18.)/(0.2*alog10(800.)) - 5. !original
6550 dum1c = (alog10(qitot_2/nitot_2)+18.)*1.722303 - 5. !optimized
6551 dumic = int(dum1c)
6552 dum1c = min(dum1c,real(iisize))
6553 dum1c = max(dum1c,1.)
6554 dumic = max(1,dumic)
6555 dumic = min(iisize-1,dumic)
6558 ! find index for rime mass fraction
6559 dum4c = qirim_2/qitot_2*3. + 1.
6560 dumiic = int(dum4c)
6561 dum4c = min(dum4c,real(rimsize))
6562 dum4c = max(dum4c,1.)
6563 dumiic = max(1,dumiic)
6564 dumiic = min(rimsize-1,dumiic)
6565 ! calculate predicted bulk rime density
6566 if (birim_2.ge.1.e-15) then !*** NOTE: change to 'bsmall'
6567 drhop = qirim_2/birim_2
6568 else
6569 drhop = 0.
6570 endif
6572 ! find index for bulk rime density
6573 ! (account for uneven spacing in lookup table for density)
6574 if (drhop.le.650.) then
6575 dum5c = (drhop-50.)*0.005 + 1.
6576 else
6577 dum5c =(drhop-650.)*0.004 + 4.
6578 endif
6579 dumjjc = int(dum5c)
6580 dum5c = min(dum5c,real(densize))
6581 dum5c = max(dum5c,1.)
6582 dumjjc = max(1,dumjjc)
6583 dumjjc = min(densize-1,dumjjc)
6585 end subroutine find_lookupTable_indices_2
6588 !======================================================================================!
6589 subroutine find_lookupTable_indices_3(dumii,dumjj,dum1,rdumii,rdumjj,inv_dum3,mu_r,lamr)
6591 !------------------------------------------------------------------------------------------!
6592 ! Finds indices in rain lookup table (3)
6593 !------------------------------------------------------------------------------------------!
6595 implicit none
6597 ! arguments:
6598 integer, intent(out) :: dumii,dumjj
6599 real, intent(out) :: dum1,rdumii,rdumjj,inv_dum3
6600 real, intent(in) :: mu_r,lamr
6602 !------------------------------------------------------------------------------------------!
6604 ! find location in scaled mean size space
6605 dum1 = (mu_r+1.)/lamr
6606 if (dum1.le.195.e-6) then
6607 inv_dum3 = 0.1
6608 rdumii = (dum1*1.e6+5.)*inv_dum3
6609 rdumii = max(rdumii, 1.)
6610 rdumii = min(rdumii,20.)
6611 dumii = int(rdumii)
6612 dumii = max(dumii, 1)
6613 dumii = min(dumii,20)
6614 elseif (dum1.gt.195.e-6) then
6615 inv_dum3 = thrd*0.1 !i.e. 1/30
6616 rdumii = (dum1*1.e+6-195.)*inv_dum3 + 20.
6617 rdumii = max(rdumii, 20.)
6618 rdumii = min(rdumii,300.)
6619 dumii = int(rdumii)
6620 dumii = max(dumii, 20)
6621 dumii = min(dumii,299)
6622 endif
6624 ! find location in mu_r space
6625 rdumjj = mu_r+1.
6626 rdumjj = max(rdumjj,1.)
6627 rdumjj = min(rdumjj,10.)
6628 dumjj = int(rdumjj)
6629 dumjj = max(dumjj,1)
6630 dumjj = min(dumjj,9)
6632 end subroutine find_lookupTable_indices_3
6634 !===========================================================================================
6635 subroutine get_cloud_dsd2(qc_grd,nc_grd,mu_c,rho,nu,dnu,lamc,lammin,lammax,cdist,cdist1,iSCF)
6637 implicit none
6639 !arguments:
6640 real, dimension(:), intent(in) :: dnu
6641 real, intent(in) :: rho
6642 real, intent(in) :: qc_grd
6643 real, intent(inout) :: nc_grd !grid-mean value
6644 real, intent(out) :: mu_c,nu,lamc,cdist,cdist1
6645 real, intent(in) :: iSCF
6647 !local variables
6648 real :: lammin,lammax,qc,nc
6649 integer :: dumi
6651 !--------------------------------------------------------------------------
6653 qc = qc_grd*iSCF !in-cloud value
6655 if (qc.ge.qsmall) then
6657 nc = nc_grd*iSCF !in-cloud value
6659 ! set minimum nc to prevent floating point error
6660 nc = max(nc,nsmall)
6661 mu_c = 0.0005714*(nc*1.e-6*rho)+0.2714
6662 mu_c = 1./(mu_c**2)-1.
6663 mu_c = max(mu_c,2.)
6664 mu_c = min(mu_c,15.)
6666 ! interpolate for mass distribution spectral shape parameter (for SB warm processes)
6667 if (iparam.eq.1) then
6668 dumi = int(mu_c)
6669 nu = dnu(dumi)+(dnu(dumi+1)-dnu(dumi))*(mu_c-dumi)
6670 endif
6672 ! calculate lamc
6673 lamc = (cons1*nc*(mu_c+3.)*(mu_c+2.)*(mu_c+1.)/qc)**thrd
6675 ! apply lambda limiters
6676 lammin = (mu_c+1.)*2.5e+4 ! min: 40 micron mean diameter
6677 lammax = (mu_c+1.)*1.e+6 ! max: 1 micron mean diameter
6679 if (lamc.lt.lammin) then
6680 lamc = lammin
6681 nc = 6.*lamc**3*qc/(pi*rhow*(mu_c+3.)*(mu_c+2.)*(mu_c+1.))
6682 elseif (lamc.gt.lammax) then
6683 lamc = lammax
6684 nc = 6.*lamc**3*qc/(pi*rhow*(mu_c+3.)*(mu_c+2.)*(mu_c+1.))
6685 endif
6687 cdist = nc*(mu_c+1.)/lamc
6688 cdist1 = nc/gamma(mu_c+1.)
6689 nc_grd = nc/iSCF !compute modified grid-mean value
6691 else
6693 mu_c = 0.
6694 lamc = 0.
6695 cdist = 0.
6696 cdist1 = 0.
6697 nu = 0.
6699 endif
6701 end subroutine get_cloud_dsd2
6704 !===========================================================================================
6705 subroutine get_rain_dsd2(qr_grd,nr_grd,mu_r,lamr,cdistr,logn0r,iSPF)
6707 ! Computes and returns rain size distribution parameters
6709 implicit none
6711 !arguments:
6712 real, intent(in) :: qr_grd !grid-mean
6713 real, intent(inout) :: nr_grd !grid-mean
6714 real, intent(out) :: lamr,mu_r,cdistr,logn0r
6715 real, intent(in) :: iSPF
6717 !local variables:
6718 real :: inv_dum,lammax,lammin,qr,nr
6720 !--------------------------------------------------------------------------
6722 qr = qr_grd*iSPF !in-cloud value
6724 if (qr.ge.qsmall) then
6726 nr = nr_grd*iSPF !in-cloud value
6728 ! use lookup table to get mu
6729 ! mu-lambda relationship is from Cao et al. (2008), eq. (7)
6731 ! find spot in lookup table
6732 ! (scaled N/q for lookup table parameter space_
6733 nr = max(nr,nsmall)
6734 inv_dum = (qr/(cons1*nr*6.))**thrd
6736 ! apply constant mu_r:
6737 mu_r = mu_r_constant
6739 !--- apply diagnostic (variable) mu_r:
6740 ! if (inv_dum.lt.282.e-6) then
6741 ! mu_r = 8.282
6742 ! elseif (inv_dum.ge.282.e-6 .and. inv_dum.lt.502.e-6) then
6743 ! ! interpolate
6744 ! rdumii = (inv_dum-250.e-6)*1.e+6*0.5
6745 ! rdumii = max(rdumii,1.)
6746 ! rdumii = min(rdumii,150.)
6747 ! dumii = int(rdumii)
6748 ! dumii = min(149,dumii)
6749 ! mu_r = mu_r_table(dumii)+(mu_r_table(dumii+1)-mu_r_table(dumii))*(rdumii- &
6750 ! real(dumii))
6751 ! elseif (inv_dum.ge.502.e-6) then
6752 ! mu_r = 0.
6753 ! endif
6754 !===
6755 lamr = (cons1*nr*(mu_r+3.)*(mu_r+2)*(mu_r+1.)/(qr))**thrd ! recalculate slope based on mu_r
6757 ! apply lambda limiters for rain
6758 lammax = (mu_r+1.)*1.e+5
6759 lammin = (mu_r+1.)*inv_Drmax
6760 if (lamr.lt.lammin) then
6761 lamr = lammin
6762 nr = exp(3.*log(lamr)+log(qr)+log(gamma(mu_r+1.))-log(gamma(mu_r+4.)))/(cons1)
6763 elseif (lamr.gt.lammax) then
6764 lamr = lammax
6765 nr = exp(3.*log(lamr)+log(qr)+log(gamma(mu_r+1.))-log(gamma(mu_r+4.)))/(cons1)
6766 endif
6768 logn0r = alog10(nr)+(mu_r+1.)*alog10(lamr)-alog10(gamma(mu_r+1)) !note: logn0r is calculated as log10(n0r)
6769 cdistr = nr/gamma(mu_r+1.)
6770 nr_grd = nr/iSPF !compute modified grid-mean value (passed back)
6772 else
6774 lamr = 0.
6775 cdistr = 0.
6776 logn0r = 0.
6778 endif
6780 end subroutine get_rain_dsd2
6783 !===========================================================================================
6784 subroutine calc_bulkRhoRime(qi_tot,qi_rim,bi_rim,rho_rime)
6786 !--------------------------------------------------------------------------------
6787 ! Calculates and returns the bulk rime density from the prognostic ice variables
6788 ! and adjusts qirim and birim appropriately.
6789 !--------------------------------------------------------------------------------
6791 implicit none
6793 !arguments:
6794 real, intent(in) :: qi_tot
6795 real, intent(inout) :: qi_rim,bi_rim
6796 real, intent(out) :: rho_rime
6798 !--------------------------------------------------------------------------
6800 if (bi_rim.ge.1.e-15) then
6801 !if (bi_rim.ge.bsmall) then
6802 rho_rime = qi_rim/bi_rim
6803 !impose limits on rho_rime; adjust bi_rim if needed
6804 if (rho_rime.lt.rho_rimeMin) then
6805 rho_rime = rho_rimeMin
6806 bi_rim = qi_rim/rho_rime
6807 elseif (rho_rime.gt.rho_rimeMax) then
6808 rho_rime = rho_rimeMax
6809 bi_rim = qi_rim/rho_rime
6810 endif
6811 else
6812 qi_rim = 0.
6813 bi_rim = 0.
6814 rho_rime = 0.
6815 endif
6817 !set upper constraint qi_rim <= qi_tot
6818 if (qi_rim.gt.qi_tot .and. rho_rime.gt.0.) then
6819 qi_rim = qi_tot
6820 bi_rim = qi_rim/rho_rime
6821 endif
6823 !impose consistency
6824 if (qi_rim.lt.qsmall) then
6825 qi_rim = 0.
6826 bi_rim = 0.
6827 endif
6830 end subroutine calc_bulkRhoRime
6832 !===========================================================================================
6833 subroutine impose_max_total_Ni(nitot_local,max_total_Ni,inv_rho_local)
6835 !--------------------------------------------------------------------------------
6836 ! Impose maximum total ice number concentration (total of all ice categories).
6837 ! If the sum of all nitot(:) exceeds maximum allowable, each category to preserve
6838 ! ratio of number between categories.
6839 !--------------------------------------------------------------------------------
6841 implicit none
6843 !arguments:
6844 real, intent(inout), dimension(:) :: nitot_local !note: dimension (nCat)
6845 real, intent(in) :: max_total_Ni,inv_rho_local
6847 !local variables:
6848 real :: dum
6850 if (sum(nitot_local(:)).ge.1.e-20) then
6851 dum = max_total_Ni*inv_rho_local/sum(nitot_local(:))
6852 nitot_local(:) = nitot_local(:)*min(dum,1.)
6853 endif
6855 end subroutine impose_max_total_Ni
6857 !===========================================================================================
6859 real function qv_sat(t_atm,p_atm,i_wrt)
6861 !------------------------------------------------------------------------------------
6862 ! Calls polysvp1 to obtain the saturation vapor pressure, and then computes
6863 ! and returns the saturation mixing ratio, with respect to either liquid or ice,
6864 ! depending on value of 'i_wrt'
6865 !------------------------------------------------------------------------------------
6867 implicit none
6869 !Calling parameters:
6870 real :: t_atm !temperature [K]
6871 real :: p_atm !pressure [Pa]
6872 integer :: i_wrt !index, 0 = w.r.t. liquid, 1 = w.r.t. ice
6874 !Local variables:
6875 real :: e_pres !saturation vapor pressure [Pa]
6877 !------------------
6879 #ifdef ECCCGEM
6880 if (i_wrt.eq.1) e_pres = foew(t_atm)
6881 if (i_wrt.eq.0) e_pres = foewa(t_atm)
6882 qv_sat = ep_2*e_pres/max(1.e-3,(p_atm-e_pres))
6883 #else
6884 e_pres = polysvp1(t_atm,i_wrt)
6885 qv_sat = ep_2*e_pres/max(1.e-3,(p_atm-e_pres))
6886 #endif
6888 return
6889 end function qv_sat
6891 !===========================================================================================
6893 subroutine check_values(Qv,T,Qc,Nc,Qr,Nr,Qitot,Qirim,Nitot,Birim,i,timestepcount, &
6894 force_abort_in,source_ind,Zitot)
6896 !------------------------------------------------------------------------------------
6897 ! Checks current values of prognotic variables for reasonable values and
6898 ! stops and prints values if they are out of specified allowable ranges.
6899 !
6900 ! 'check_consistency' means include trap for inconsistency in moments;
6901 ! otherwise, only trap for Q, T, and negative Qx, etc. This option is here
6902 ! to allow for Q<qsmall.and.N>nsmall or Q>qsmall.and.N<small which can be produced
6903 ! at the leading edges due to sedimentation and whose values are accpetable
6904 ! since lambda limiters are later imposed after SEDI (so one does not necessarily
6905 ! want to trap for inconsistency after sedimentation has been called).
6906 !
6907 ! The value 'source_ind' indicates the approximate location in 'p3_main'
6908 ! from where 'check_values' was called before it resulted in a trap.
6909 !
6910 !------------------------------------------------------------------------------------
6912 implicit none
6914 !Calling parameters:
6915 real, dimension(:), intent(in) :: Qv,T,Qc,Qr,Nr,Nc
6916 real, dimension(:,:), intent(in) :: Qitot,Qirim,Nitot,Birim
6917 real, dimension(:,:), intent(in), optional :: Zitot
6918 integer, intent(in) :: source_ind,i,timestepcount
6919 logical, intent(in) :: force_abort_in !.TRUE. = forces abort if value violation is detected
6921 !logical, intent(in) :: check_consistency !.TRUE. = check for sign consistency between Qx and Nx
6923 !Local variables:
6924 real, parameter :: T_low = 173.
6925 real, parameter :: T_high = 323.
6926 real, parameter :: Q_high = 60.e-3
6927 real, parameter :: N_high = 1.e+20
6928 real, parameter :: B_high = Q_high*5.e-3
6929 real, parameter :: Z_high = 10.
6930 integer :: k,iice,nk,ncat
6931 logical :: badvalue_found
6933 nk = size(Qitot,dim=1)
6934 nCat = size(Qitot,dim=2)
6936 badvalue_found = .false.
6938 k_loop: do k = 1,nk
6940 ! check unrealistic values T and Qv
6941 if (.not.(T(k)>T_low .and. T(k)<T_high)) then
6942 write(6,'(a41,4i5,1e15.6)') '** WARNING IN P3_MAIN -- src,i,k,step,T: ', &
6943 source_ind,i,k,timestepcount,T(k)
6944 badvalue_found = .true.
6945 endif
6946 if (.not.(Qv(k)>=0. .and. Qv(k)<Q_high)) then
6947 write(6,'(a42,4i5,1e15.6)') '** WARNING IN P3_MAIN -- src,i,k,step,Qv: ', &
6948 source_ind,i,k,timestepcount,Qv(k)
6949 badvalue_found = .true.
6950 endif
6952 ! check for NANs:
6953 if (.not.(T(k) == T(k)) .or. &
6954 .not.(Qv(k) == Qv(k)) .or. &
6955 .not.(Qc(k) == Qc(k)) .or. &
6956 .not.(Nc(k) == Nc(k)) .or. &
6957 .not.(Qr(k) == Qr(k)) .or. &
6958 .not.(Nr(k) == Nr(k)) ) then
6959 write(6,'(a56,4i5,6e15.6)') '*A WARNING IN P3_MAIN -- src,i,k,step,T,Qv,Qc,Nc,Qr,Nr: ', &
6960 source_ind,i,k,timestepcount,T(k),Qv(k),Qc(k),Nc(k),Qr(k),Nr(k)
6961 badvalue_found = .true.
6962 endif
6963 do iice = 1,ncat
6964 if (.not.(Qitot(k,iice) == Qitot(k,iice)) .or. &
6965 .not.(Qirim(k,iice) == Qirim(k,iice)) .or. &
6966 .not.(Nitot(k,iice) == Nitot(k,iice)) .or. &
6967 .not.(Birim(k,iice) == Birim(k,iice)) ) then
6968 write(6,'(a68,5i5,4e15.6)') '*B WARNING IN P3_MAIN -- src,i,k,step,iice,Qitot,Qirim,Nitot,Birim: ', &
6969 source_ind,i,k,timestepcount,iice,Qitot(k,iice),Qirim(k,iice),Nitot(k,iice),Birim(k,iice)
6970 badvalue_found = .true.
6971 endif
6972 enddo
6974 ! check unrealistic values Qc,Nc
6975 if ( .not.(Qc(k)==0. .and. Nc(k)==0.) .and. & !ignore for all zeroes
6976 ( ((Qc(k)>0..and.Nc(k)<=0.) .or. (Qc(k)<=0..and.Nc(k)>0.)) & !inconsistency
6977 .or. Qc(k)<0. .or. Qc(k)>Q_high &
6978 .or. Nc(k)<0. .or. Nc(k)>N_high ) & !unrealistic values
6979 .and. source_ind /= 100 & !skip trap for this source_ind
6980 .and. source_ind /= 200 & !skip trap for this source_ind
6981 .and. source_ind /= 300 ) then !skip trap for this source_ind
6982 write(6,'(a45,4i5,4e15.6)') '*C WARNING IN P3_MAIN -- src,i,k,stepQc,Nc: ', &
6983 source_ind,i,k,timestepcount,Qc(k),Nc(k)
6984 badvalue_found = .true.
6985 endif
6987 ! check unrealistic values Qr,Nr
6988 if ( .not.(Qr(k)==0. .and. Nr(k)==0.) .and. & !ignore for all zeroes
6989 ( ((Qr(k)>0..and.Nr(k)<=0.) .or. (Qr(k)<=0..and.Nr(k)>0.)) & !inconsistency
6990 .or. Qr(k)<0. .or. Qr(k)>Q_high &
6991 .or. Nr(k)<0. .or. Nr(k)>N_high ) & !unrealistic values
6992 .and. source_ind /= 100 & !skip trap for this source_ind
6993 .and. source_ind /= 200 & !skip trap for this source_ind
6994 .and. source_ind /= 300 ) then !skip trap for this source_ind
6995 write(6,'(a45,4i5,4e15.6)') '*C WARNING IN P3_MAIN -- src,i,k,stepQr,Nr: ', &
6996 source_ind,i,k,timestepcount,Qr(k),Nr(k)
6997 badvalue_found = .true.
6998 endif
7000 ! check unrealistic values Qitot,Qirim,Nitot,Birim
7001 do iice = 1,ncat
7003 if ( .not.(Qitot(k,iice)==0..and.Qirim(k,iice)==0..and.Nitot(k,iice)==0..and.Birim(k,iice)==0.).and. & !ignore for all zeroes
7004 ( ((Qitot(k,iice)>0..and.Nitot(k,iice)<=0.) .or. (Qitot(k,iice)<=0..and.Nitot(k,iice)>0.) ) & !inconsistency
7005 .or. Qitot(k,iice)<0. .or. Qitot(k,iice)>Q_high & !unrealistic values
7006 .or. Qirim(k,iice)<0. .or. Qirim(k,iice)>Q_high &
7007 .or. Nitot(k,iice)<0. .or. Nitot(k,iice)>N_high &
7008 .or. Birim(k,iice)<0. .or. Birim(k,iice)>B_high ) &
7009 .and. source_ind /= 100 & !skip trap for this source_ind
7010 .and. source_ind /= 200 & !skip trap for this source_ind
7011 .and. source_ind /= 300 ) then !skip trap for this source_ind
7012 write(6,'(a68,5i5,4e15.6)') '*D WARNING IN P3_MAIN -- src,i,k,step,iice,Qitot,Qirim,Nitot,Birim: ', &
7013 source_ind,i,k,timestepcount,iice,Qitot(k,iice),Qirim(k,iice),Nitot(k,iice),Birim(k,iice)
7014 badvalue_found = .true.
7015 print*, '**: ',Qitot(k,iice)>Q_high, Qirim(k,iice)>Q_high, Nitot(k,iice)>N_high, &
7016 Birim(k,iice)>B_high, Q_high, N_high, B_high
7017 endif
7019 if (present(Zitot)) then
7020 if ( .not.(Qitot(k,iice)==0. .and. Nitot(k,iice)==0. .and. Zitot(k,iice)==0.) .and. &
7021 ( Qitot(k,iice)>0. .and. Nitot(k,iice)>0. .and. Zitot(k,iice)<=0. ) & !inconsistency
7022 .and. source_ind /= 100 & !skip trap for this source_ind
7023 .and. source_ind /= 200 & !skip trap for this source_ind
7024 .and. source_ind /= 300 ) then !skip trap for this source_ind
7025 write(6,'(a62,5i5,3e15.6)') '*E WARNING IN P3_MAIN -- src,i,k,step,iice,Qitot,Nitot,Zitot: ', &
7026 source_ind,i,k,timestepcount,iice,Qitot(k,iice),Nitot(k,iice),Zitot(k,iice)
7027 badvalue_found = .true.
7028 endif
7029 endif
7031 enddo !iice-loop
7033 enddo k_loop
7035 if (badvalue_found .and. force_abort_in) then
7036 print*
7037 print*,'** DEBUG TRAP IN P3_MAIN, s/r CHECK_VALUES -- source: ',source_ind
7038 print*
7039 global_status = STATUS_ERROR
7040 stop
7041 return
7042 endif
7044 end subroutine check_values
7046 !==========================================================================================!
7047 real function compute_mu_3moment(mom0,mom3,mom6,mu_max)
7049 !--------------------------------------------------------------------------
7050 ! Computes mu as a function of moments 0, 3, and 6 of the size distribution
7051 ! represented by N(D) = No*D^mu*e(-lambda*D).
7052 !
7053 ! Note: moment 3 is not equal to the mass mixing ratio (due to variable density)
7054 !
7055 ! G(mu)= mom0*mom6/mom3^2 = [(6+mu)(5+mu)(4+mu)]/[(3+mu)(2+mu)(1+mu)]
7056 !--------------------------------------------------------------------------
7058 implicit none
7060 ! Arguments passed:
7061 real, intent(in) :: mom0 !0th moment
7062 real, intent(in) :: mom3 !3th moment (note, not normalized)
7063 real, intent(in) :: mom6 !6th moment (note, not normalized)
7064 real, intent(in) :: mu_max !maximum allowable value of mu
7066 ! Local variables:
7067 real :: mu ! shape parameter in gamma distribution
7068 real :: G ! function of mu (see comments above)
7069 real :: g2
7070 !real :: a1,g1
7071 !real, parameter :: eps_m0 = 1.e-20
7072 real, parameter :: eps_m3 = 1.e-20
7073 real, parameter :: eps_m6 = 1.e-35
7075 if (mom3>eps_m3) then
7077 !G = (mom0*mom6)/(mom3**2)
7078 !To avoid very small values of mom3**2
7079 G = (mom0/mom3)*(mom6/mom3)
7081 !----------------------------------------------------------!
7082 ! !Solve alpha numerically: (brute-force)
7083 ! mu= 0.
7084 ! g2= 999.
7085 ! do i=0,4000
7086 ! a1= i*0.01
7087 ! g1= (6.+a1)*(5.+a1)*(4.+a1)/((3.+a1)*(2.+a1)*(1.+a1))
7088 ! if(abs(g-g1)<abs(g-g2)) then
7089 ! mu = a1
7090 ! g2= g1
7091 ! endif
7092 ! enddo
7093 !----------------------------------------------------------!
7095 !Piecewise-polynomial approximation of G(mu) to solve for mu:
7096 if (G>=20.) then
7097 mu = 0.
7098 else
7099 g2 = G**2
7100 if (G<20. .and.G>=13.31) then
7101 mu = 3.3638e-3*g2 - 1.7152e-1*G + 2.0857e+0
7102 elseif (G<13.31.and.G>=7.123) then
7103 mu = 1.5900e-2*g2 - 4.8202e-1*G + 4.0108e+0
7104 elseif (G<7.123.and.G>=4.200) then
7105 mu = 1.0730e-1*g2 - 1.7481e+0*G + 8.4246e+0
7106 elseif (G<4.200.and.G>=2.946) then
7107 mu = 5.9070e-1*g2 - 5.7918e+0*G + 1.6919e+1
7108 elseif (G<2.946.and.G>=1.793) then
7109 mu = 4.3966e+0*g2 - 2.6659e+1*G + 4.5477e+1
7110 elseif (G<1.793.and.G>=1.405) then
7111 mu = 4.7552e+1*g2 - 1.7958e+2*G + 1.8126e+2
7112 elseif (G<1.405.and.G>=1.230) then
7113 mu = 3.0889e+2*g2 - 9.0854e+2*G + 6.8995e+2
7114 elseif (G<1.230) then
7115 mu = mu_max
7116 endif
7117 endif
7119 compute_mu_3moment = mu
7121 else
7123 print*, 'Input parameters out of bounds in function COMPUTE_MU_3MOMENT'
7124 print*, 'mom0 = ',mom0
7125 print*, 'mom3 = ',mom3
7126 print*, 'mom6 = ',mom6
7127 stop
7129 endif
7131 end function compute_mu_3moment
7133 !======================================================================================!
7134 real function G_of_mu(mu)
7136 !arguments:
7137 real, intent(in) :: mu
7139 G_of_mu = ((6.+mu)*(5.+mu)*(4.+mu))/((3.+mu)*(2.+mu)*(1.+mu))
7141 end function G_of_mu
7143 !======================================================================================!
7145 real function maxHailSize(rho,qit,qim,nit,rhofaci,lam,mu)
7147 !--------------------------------------------------------------------------
7148 ! Computes the maximum hail size, by estimating the maximum size that is
7149 ! physically observable (and not just a numerical artifact of the compete
7150 ! gamma size distribution).
7151 !
7152 ! Follows method described in Milbrandt and Yau (2006a)
7153 !
7154 ! TO DO:
7155 ! - pass density (not just rime density) and add to is_hail criteria
7156 ! - clean up method selection (e.g. argument parameter to specify method)
7157 !
7158 ! *** NOTE ***
7159 !
7160 ! The current coding for this function is problematic.
7161 ! In GEM, overflows (apparently) result in crashes. In WRF, no crashes but erroneous
7162 ! zero values in spots (possibly resulting from over/underflows)
7163 ! --> Code is kep here for now; however this fields is better computed in
7164 ! post-processing. Eventaully this function will be removed.
7165 !--------------------------------------------------------------------------
7167 implicit none
7169 ! Arguments passed:
7170 real, intent(in) :: rho ! air density [kg m-3]
7171 real, intent(in) :: qit ! prognostic ice total mass mixing ratios
7172 real, intent(in) :: qim ! prognostic ice rime mass mixing ratios
7173 real, intent(in) :: nit ! total num and total number mixing ratio
7174 real, intent(in) :: rhofaci ! air density correction factor for ice fall speed
7175 real, intent(in) :: lam,mu ! PSD slope and shape parameters
7177 ! Local variables:
7178 real, parameter :: dD = 1.e-3 ! diameter bin width [m]
7179 real, parameter :: Dmax_psd = 200.e-3 ! maximum diameter in PSD to compute integral [m]
7180 real, parameter :: FrThrs = 0.75 ! theshold rime fraction to be considered graupel/hail
7181 !real, parameter :: Ncrit = 1.e-4 ! threshold physically observable number concentration [# m-3]
7182 real, parameter :: Rcrit = 1.e-3/6. ! threshold physically observable number flux [# m-2 s-1]
7183 real, parameter :: ch = 206.89 ! coefficient in V-D fall speed relation for hail (from MY2006a)
7184 real, parameter :: dh = 0.6384 ! exponent in V-D fall speed relation for hail (from MY2006a)
7185 real :: n0 ! shape parameter in gamma distribution
7186 real :: Frim ! rime mass fraction
7187 real :: Di ! diameter [m]
7188 real :: N_tot ! total number concentration [# m-3]
7189 real :: N_tail ! number conc. from Di to infinity; i.e. trial for Nh*{D*} in MY2006a [# m-3]
7190 real :: R_tail ! number flux of large hail; i.e. trial for Rh*{D*} (corrected from MY2006a [# m-2 s-1]
7191 !real :: Dhmax_1 ! maximum hail sized based on Nh* [m]
7192 real :: Dhmax_2 ! maximum hail sized based on Rh* [m]
7193 real :: V_h ! fall speed of hail of size D [m s-1]
7194 integer :: nd ! maximum number of size bins for integral
7195 integer :: i ! index for integration
7197 Frim = qim/max(qit,1.e-14)
7198 N_tot = rho*nit
7200 ! considered_hail: if (Frim>FrThrs .and. N_tot>Ncrit) then
7201 considered_hail: if (Frim>FrThrs) then
7203 nd = int(Dmax_psd/dD)
7204 n0 = N_tot*lam**(mu+1.)/gamma(mu+1.)
7205 ! n0 = dble(N_tot)*dexp( dble(mu+1.)*dlog(dble(lam)) )/dble(gamma(mu+1.))
7206 N_tail = 0.
7209 !-- method 1, based on Nh*crit only:
7210 ! Dhmax_1 = 0.
7211 ! do i = nd,1,-1
7212 ! Di = i*dD
7213 ! N_tail = N_tail + n0*Di**mu*exp(-lam*Di)*dD
7214 ! if (N_tail>Ncrit) then
7215 ! Dhmax_1 = Di
7216 ! exit
7217 ! endif
7218 ! enddo
7219 ! maxHailSize = Dhmax_1
7221 !-- method 2, based on Rh*crit only:
7222 R_tail = 0.
7223 Dhmax_2 = 0.
7224 do i = nd,1,-1
7225 Di = i*dD
7226 V_h = rhofaci*(ch*Di**Dh)
7227 R_tail = R_tail + V_h*n0*Di**mu*exp(-lam*Di)*dD
7228 ! R_tail = R_tail + V_h*sngl(n0*dble(Di)**dble(mu)*exp(-dble(lam)*dble(Di))*dble(dD))
7229 if (R_tail>Rcrit) then
7230 Dhmax_2 = Di
7231 exit
7232 endif
7233 enddo
7234 maxHailSize = Dhmax_2
7236 !-- method 3, finds values based on Nh*crit and Rh*crit methods
7237 ! ! found_N2 = .false.
7238 ! ! found_R2 = .false.
7239 ! ! do i = nd,1,-1
7240 ! ! Di = i*dD
7241 ! ! N_tail = N_tail + n0*Di**mu*exp(-lam*Di)*dD
7242 ! ! R_tail = N_tail*(ch*Di**Dh)
7243 ! ! if (N_tail>Ncrit) .and. .not.found_N2) then
7244 ! ! Dhmax_1 = Di ! max hail size based on N*crit
7245 ! ! found_N2 = .true.
7246 ! ! endif
7247 ! ! if (R_tail>Rcrit) .and. .not.found_R2) then
7248 ! ! Dhmax_2 = Di ! max hail size based on R*crit
7249 ! ! found_R2 = .true.
7250 ! ! endif
7251 ! ! if (found_N2 .and. found_R2) exit
7252 ! !
7253 ! ! enddo
7255 else
7257 maxHailSize = 0.
7259 endif considered_hail
7261 end function maxHailSize
7263 !===========================================================================================
7265 #ifdef ECCCGEM
7267 ! Define bus requirements
7268 function p3_phybusinit() result(F_istat)
7269 use phy_status, only: PHY_OK, PHY_ERROR
7270 use bus_builder, only: bb_request
7271 use phy_options, only: p3_trplmomi
7273 implicit none
7274 integer :: F_istat !Function return status
7275 logical :: buserr
7277 F_istat = PHY_ERROR
7278 if (n_iceCat < 0) then
7279 call physeterror('microphy_p3::p3_phybusinit', &
7280 'Called mp_phybusinit() before mp_init()')
7281 return
7282 endif
7283 buserr = .false.
7284 if (bb_request((/ &
7285 'CLOUD_WATER_MASS ', &
7286 'CLOUD_WATER_NUM ', &
7287 'RAIN_MASS ', &
7288 'RAIN_NUM ', &
7289 'ICE_MASS_TEND ', &
7290 'ICE_EFF_RAD ', &
7291 'RATE_PRECIP_TYPES', &
7292 'PARTICLE_DIAMETER', &
7293 'CCN_NUM ', &
7294 'MPDIAG_2D ', &
7295 'MPDIAG_3D ', &
7296 'MPVIS ', &
7297 'REFLECTIVITY ', &
7298 'LIGHTNING ' &
7299 /)) /= PHY_OK) buserr = .true.
7300 if (.not. buserr) then
7301 if (bb_request('ICE_CAT_1') /= PHY_OK) buserr = .true.
7302 endif
7303 if (p3_trplmomi .and. .not. buserr) then
7304 if (bb_request('ICE_CAT_1_TM') /= PHY_OK) buserr = .true.
7305 endif
7306 if (n_iceCat > 1 .and. .not. buserr) then
7307 if (bb_request('ICE_CAT_2') /= PHY_OK) buserr = .true.
7308 endif
7309 if (n_iceCat > 1 .and. p3_trplmomi .and. .not. buserr) then
7310 if (bb_request('ICE_CAT_2_TM') /= PHY_OK) buserr = .true.
7311 endif
7312 if (n_iceCat > 2 .and. .not. buserr) then
7313 if (bb_request('ICE_CAT_3') /= PHY_OK) buserr = .true.
7314 endif
7315 if (n_iceCat > 2 .and. p3_trplmomi .and. .not. buserr) then
7316 if (bb_request('ICE_CAT_3_TM') /= PHY_OK) buserr = .true.
7317 endif
7318 if (n_iceCat > 3 .and. .not. buserr) then
7319 if (bb_request('ICE_CAT_4') /= PHY_OK) buserr = .true.
7320 endif
7321 if (n_iceCat > 3 .and. p3_trplmomi .and. .not. buserr) then
7322 if (bb_request('ICE_CAT_4_TM') /= PHY_OK) buserr = .true.
7323 endif
7325 if (buserr) then
7326 call physeterror('microphy_p3::p3_phybusinit', &
7327 'Cannot construct bus request list')
7328 return
7329 endif
7330 F_istat = PHY_OK
7331 return
7332 end function p3_phybusinit
7334 !===========================================================================================
7336 ! Compute total water mass
7337 function p3_lwc(F_qltot, F_dbus, F_pbus, F_vbus) result(F_istat)
7338 use phybus
7339 use phy_status, only: PHY_OK, PHY_ERROR
7340 implicit none
7341 real, dimension(:,:), intent(out) :: F_qltot !Total water mass (kg/kg)
7342 real, dimension(:), pointer, contiguous :: F_dbus !Dynamics bus
7343 real, dimension(:), pointer, contiguous :: F_pbus !Permanent bus
7344 real, dimension(:), pointer, contiguous :: F_vbus !Volatile bus
7345 integer :: F_istat !Return status
7346 #include "phymkptr.hf"
7347 integer :: ni, nkm1
7348 real, dimension(:,:), pointer :: zqcp, zqrp
7349 F_istat = PHY_ERROR
7350 ni = size(F_qltot, dim=1); nkm1 = size(F_qltot, dim=2)
7351 MKPTR2Dm1(zqcp, qcplus, F_dbus)
7352 MKPTR2Dm1(zqrp, qrplus, F_dbus)
7353 F_qltot(:,:) = zqcp(:,:) + zqrp(:,:)
7354 F_istat = PHY_OK
7355 return
7356 end function p3_lwc
7358 !===========================================================================================
7360 ! Compute total ice mass
7361 function p3_iwc(F_qitot, F_dbus, F_pbus, F_vbus) result(F_istat)
7362 use phybus
7363 use phy_status, only: PHY_OK, PHY_ERROR
7364 implicit none
7365 real, dimension(:,:), intent(out) :: F_qitot !Total ice mass (kg/kg)
7366 real, dimension(:), pointer, contiguous :: F_dbus !Dynamics bus
7367 real, dimension(:), pointer, contiguous :: F_pbus !Permanent bus
7368 real, dimension(:), pointer, contiguous :: F_vbus !Volatile bus
7369 integer :: F_istat !Return status
7370 #include "phymkptr.hf"
7371 integer :: ni, nkm1
7372 real, dimension(:,:), pointer :: zqti1p, zqti2p, zqti3p, zqti4p
7373 F_istat = PHY_ERROR
7374 ni = size(F_qitot, dim=1); nkm1 = size(F_qitot, dim=2)
7375 MKPTR2Dm1(zqti1p, qti1plus, F_dbus)
7376 MKPTR2Dm1(zqti2p, qti2plus, F_dbus)
7377 MKPTR2Dm1(zqti3p, qti3plus, F_dbus)
7378 MKPTR2Dm1(zqti4p, qti4plus, F_dbus)
7379 F_qitot = 0.
7380 if (associated(zqti1p)) F_qitot = F_qitot + zqti1p
7381 if (associated(zqti2p)) F_qitot = F_qitot + zqti2p
7382 if (associated(zqti3p)) F_qitot = F_qitot + zqti3p
7383 if (associated(zqti4p)) F_qitot = F_qitot + zqti4p
7384 F_istat = PHY_OK
7385 return
7386 end function p3_iwc
7388 #endif
7390 !======================================================================================!
7391 END MODULE microphy_p3