1 !__________________________________________________________________________________________
2 ! This module contains the Predicted Particle Property (P3) bulk microphysics scheme. !
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. !
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). !
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 !
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 !__________________________________________________________________________________________!
24 ! Last updated: 2023-FEB !
25 !__________________________________________________________________________________________!
30 use tdpack, only: foew, foewa
36 public :: p3_main, polysvp1, p3_init
38 public :: mp_p3_wrapper_gem, p3_phybusinit, p3_lwc, p3_iwc
40 public :: mp_p3_wrapper_wrf, mp_p3_wrapper_wrf_2cat
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
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
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.
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 !------------------------------------------------------------------------------------------!
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
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
159 lookup_file_1 = trim(read_path)//'/'//'p3_lookupTable_1.dat-v'//trim(version_intended_table_1_3mom)
161 lookup_file_1 = trim(read_path)//'/'//'p3_lookupTable_1.dat-v'//trim(version_intended_table_1_2mom)
163 lookup_file_2 = trim(read_path)//'/'//'p3_lookupTable_2.dat-v'//trim(version_intended_table_2)
165 !------------------------------------------------------------------------------------------!
167 end_status = STATUS_ERROR
169 if (present(abort_on_err)) err_abort = abort_on_err
171 if (present(stat)) stat = STATUS_OK
175 n_iceCat = nCat !used for GEM interface
177 ! mathematical/optimization constants
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
191 ! = 3 Khairoutdinov and Kogan 2000
195 ! droplet concentration (m-3)
198 ! parameters for Seifert and Beheng (2001) autoconversion/accretion
209 rhosur = 100000./(rd*273.15)
210 rhosui = 60000./(rd*253.15)
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]
227 inv_rho_rimeMax = 1./rho_rimeMax
229 ! minium allowable prognostic variables
232 bsmall = qsmall*inv_rho_rimeMax
238 ! Barklie and Gokhale (1959)
242 mi0 = 4.*piov3*900.*1.e-18
248 ! mean size for soft lambda_r limiter [microns]
250 ! ratio of rain number produced to ice number loss from melting
253 ! mu of initial ice formation by deposition nucleation (or if no ice is present for process group 1)
256 ! saturation pressure at T = 0 C
257 e0 = polysvp1(273.15,0)
260 cons2 = 4.*piov3*rhow
261 cons3 = 1./(cons2*(25.e-6)**3)
262 cons4 = 1./(dbrk**3*pi*rhow)
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
277 bact = vi*osm*epsm*mw*rhoa/(map*rhow)
278 ! inv_bact = (map*rhow)/(vi*osm*epsm*mw*rhoa) *** to replace /bact **
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
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)
318 !------------------------------------------------------------------------------------------!
319 ! read in ice microphysics table
324 call rpn_comm_rank(RPN_COMM_GRID,procnum,istat)
337 IF_PROC0: if (procnum == 0) then
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
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*, '************************************************'
361 global_status = STATUS_ERROR
362 if (trim(model) == 'WRF') then
363 print*,'Stopping in P3 init'
368 IF_OK: if (global_status /= STATUS_ERROR) then
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)
386 !read in table for ice-rain collection
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
403 if (global_status == STATUS_ERROR) then
405 print*,'Stopping in P3 init'
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.'
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
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*, '************************************************'
437 global_status = STATUS_ERROR
438 if (trim(model) == 'WRF') then
439 print*,'Stopping in P3 init'
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)
457 !read in table for ice-rain collection
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
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
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*, '************************************************'
491 global_status = STATUS_ERROR
492 if (trim(model)=='WRF' .or. trim(model)=='KIN1D') then
493 print*,'Stopping in P3 init'
497 IF_OKB: if (global_status /= STATUS_ERROR) then
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)
524 call rpn_comm_bcast(global_status,1,RPN_COMM_INTEGER,0,RPN_COMM_GRID,istat)
527 if (global_status == STATUS_ERROR) then
529 print*,'Stopping in P3 init'
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)
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)
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)
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)
563 ! ! ! ! iterate to get mu_r
564 ! ! ! ! mu_r-lambda relationship is from Cao et al. (2008), eq. (7)
566 ! ! ! ! start with first guess, mu_r = 0
571 ! ! ! lamr = initlamr*((mu_r+3.)*(mu_r+2.)*(mu_r+1.)/6.)**thrd
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)
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
590 ! ! ! ! assign lookup table values
591 ! ! ! mu_r_table(i) = mu_r
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 ...'
607 mu_r_loop: do ii = 1,10
609 !mu_r = real(ii-1) ! values of mu
612 ! loop over number-weighted mean size
613 meansize_loop: do jj = 1,300
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]
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
632 ! loop over PSD to numerically integrate number and mass-weighted mean fallspeeds
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
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))
672 !.......................................................................
674 if (procnum == 0) then
675 print*, ' P3_INIT DONE.'
679 end_status = STATUS_OK
680 if (present(stat)) stat = end_status
685 END subroutine p3_init
687 !==================================================================================================!
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. !
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 !
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. !
721 !------------------------------------------------------------------------------------------!
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
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)
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)
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, &
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
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
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)
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
850 ! note: code for prediction of ssat not currently avaiable, set 2D array to 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))
892 !surface precipitation output:
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)
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
911 ! convert Z from P3 to (N*Z)^0.5 for advection
912 if (log_3momentIce) then
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
925 !...............................................
927 if (global_status /= STATUS_OK) then
928 print*,'Stopping in P3, problem in P3 main'
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. !
957 !------------------------------------------------------------------------------------------!
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
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)
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)
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, &
1018 real, dimension(ims:ime, kms:kme, jms:jme), intent(inout) :: qi2_3d,qni2_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
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
1076 ! note: code for prediction of ssat not currently avaiable, set 2D array to 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:
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)
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)
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.
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)
1161 if (qitot(i,k,2).ge.qsmall) then
1162 dum2=qitot(i,k,2)/diag_effi(i,k,2)
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)
1176 if (global_status /= STATUS_OK) then
1177 print*,'Stopping in P3, problem in P3 main'
1181 END SUBROUTINE mp_p3_wrapper_wrf_2cat
1185 !==================================================================================================!
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) &
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 !------------------------------------------------------------------------------------------!
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)
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
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(:,:)
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
1391 !if (kount == 0) 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
1399 ! note: code for prediction of ssat not currently avaiable, thus array is to 0
1403 do k = kbot,ktop,kdir
1404 pres(:,k)= psfc(:)*sigma(:,k)
1407 !layer thickness (for sedimentation):
1408 ! do k = kbot,ktop-kdir,kdir
1409 ! DZ(:,k) = gztherm(:,k+kdir) - gztherm(:,k)
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)
1419 DZ(:,kbot) = gzmom(:,kbot)
1421 !compute zitot from advected 'Z' variable (for triple-moment ice):
1422 if (present(zitot_1)) then
1424 zitot_1 = zitot_1**2/nitot_1
1429 if (present(zitot_2)) then
1431 zitot_2 = zitot_2**2/nitot_2
1436 if (present(zitot_3)) then
1438 zitot_3 = zitot_3**2/nitot_3
1443 if (present(zitot_4)) then
1445 zitot_4 = zitot_4**2/nitot_4
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(:,:)
1486 !--- substepping microphysics
1487 if (n_substep > 1) then
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:
1507 theta_m = temp*tmparr_ik
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, &
1519 diag_vis = diag_vis, &
1520 diag_vis1 = diag_vis1, &
1521 diag_vis2 = diag_vis2, &
1522 diag_vis3 = diag_vis3)
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)
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(:)
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
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)
1585 diag_effi_1(:,:) = 0.
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)
1597 diag_effi_2(:,:) = 0.
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)
1609 diag_effi_3(:,:) = 0.
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)
1621 diag_effi_4(:,:) = 0.
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.
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
1653 if (qc(i,k)>1.e-6 .and. .not.log_tmp1) then
1654 diag_hcb(i) = gztherm(i,k)
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)
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))
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
1685 call physeterror('microphy_p3::mp_p3_wrapper_gem', &
1686 'Insufficient size for qi_type')
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(:,:)
1705 end_status = STATUS_OK
1708 end function mp_p3_wrapper_gem
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: !
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.) !
1727 ! For details see: Chosson et al. (2014) [J. Atmos. Sci., 71, 2635-2653] !
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 !
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 !
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% !
1744 ! Version 3: June 2018, Caroline Jouan (ECCC) !
1745 ! Tests in GEM models !
1747 !------------------------------------------------------------------------------------------!
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.
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
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
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
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
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
1884 SPF_clr(k) = max(SPF(k)-SCF(k),0.)
1889 else ! compute_cloud_fraction
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, &
1914 !----------------------------------------------------------------------------------------!
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. !
1923 ! Several diagnostic values are also computed and returned to the wrapper subroutine, !
1924 ! including precipitation rates. !
1926 !----------------------------------------------------------------------------------------!
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, &
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
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.
2168 ! diag_3d(i,k,1) = qrcon
2169 ! diag_3d(i,k,2) = qrevp
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.
2174 ! Similarly, 'diag_2d(ni,n_diag_2d) is a placeholder to output 2D diagnostic fields.
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):
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
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
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)
2212 ktop = kte !k of top level
2213 kbot = kts !k of bottom level
2214 kdir = 1 !(k: 1=bottom, nk=top)
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
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'
2234 deltaD_init = 999. !not used if n_iceCat=1 (but should be defined)
2236 deltaD_init = 500.e-6
2238 deltaD_init = 400.e-6
2240 deltaD_init = 235.e-6
2242 deltaD_init = 175.e-6
2244 deltaD_init = 150.e-6
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)
2279 diag_effc = 10.e-6 ! default value
2280 !diag_effr = 25.e-6 ! default value
2281 diag_effi = 25.e-6 ! default value
2285 if (present(diag_dhmax)) diag_dhmax = 0.
2286 if (present(diag_lami)) diag_lami = 0.
2287 if (present(diag_mui)) diag_mui = 0.
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)
2300 !-----------------------------------------------------------------------------------!
2301 i_loop_main: do i = its,ite ! main i-loop (around the entire scheme)
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, &
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)
2314 if (global_status /= STATUS_OK) return
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)
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)
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
2371 log_hydrometeorsPresent = .true. ! updated further down
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
2380 log_hydrometeorsPresent = .true. ! updated further down
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.
2393 log_hydrometeorsPresent = .true. ! final update
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.
2413 !zero out zitot if there is no qitot for triple moment
2414 if (log_3momentIce) where (qitot(i,:,:).lt.qsmall) zitot(i,:,:) = 0.
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, &
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)
2428 if (global_status /= STATUS_OK) return
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:
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.
2456 if (qitot(i,k,iice).ge.qsmall) log_exitlevel = .false.
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.
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)
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.
2526 if (qitot(i,k,iice).ge.qsmall) log_exitlevel=.false.
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
2540 !very simple temperature dependent aggregation efficiency
2541 ! if (t(i,k).lt.253.15) then
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
2548 if (t(i,k).lt.253.15) then
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
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), &
2563 ! initialize inverse supersaturation relaxation timescale for combined ice categories
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)
2603 f1pr07 = -99. ! log space
2604 f1pr08 = -99. ! log space
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
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
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)
2640 f1pr07 = -99. ! log space
2641 f1pr08 = -99. ! log space
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
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))
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
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
2679 endif qitot_notsmall_1 ! qitot > qsmall
2681 !----------------------------------------------------------------------
2682 ! Begin calculations of microphysical processes
2684 !......................................................................
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)
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
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
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))
2733 ! for T > 273.15, assume collected rain number is shed as
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
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
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)
2845 !............................................................
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)
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))
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
2890 ! densify due to wet growth
2891 log_wetgrowth(iice) = .true.
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)
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)
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.))
2943 rhorime_c(iice) = (0.051 + 0.114*Ri - 0.0055*Ri**2)*1000.
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.)
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.
2963 ! rhorime_r(iice) = 400.
2967 rhorime_c(iice) = 400.
2968 ! rhorime_r(iice) = 400.
2969 endif ! qi > qsmall and T < 273.15
2971 !--------------------
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)/ &
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
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
3013 qcheti(iice_dest) = Q_nuc
3014 ncheti(iice_dest) = N_nuc
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)
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
3041 qrheti(iice_dest) = Q_nuc
3042 nrheti(iice_dest) = N_nuc
3046 !......................................
3047 ! rime splintering (Hallet-Mossop 1974)
3049 rimesplintering_on: if (log_hmossopOn) 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
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
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
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)
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
3099 qrmul(iice_dest) = qrmul(iice_dest) + dum2
3100 nimul(iice_dest) = nimul(iice_dest) + dum2/(piov6*900.*(10.e-6)**3)
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)
3131 if (qc(i,k).ge.qsmall) then
3132 epsc = 2.*pi*rho(i,k)*dv*cdist(i,k)
3137 if (t(i,k).lt.273.15) then
3139 xx = epsc + epsr + epsi_tot*(1.+xxls(i,k)*inv_cp*dqsdT)*oabi
3144 dumqvi = qvi(i,k) !no modification due to latent heating
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)
3156 ! ! dumqvi = qvi(i,k) + dum*(qvs(i,k)-qvi(i,k))
3157 ! ! dumqvi = min(qvs(i,k),dumqvi)
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
3179 aaa = (qv(i,k)-qv_old(i,k))*odt - dqsdT*(-dum*g*inv_cp)
3182 xx = max(1.e-20,xx) ! set lower bound on xx to prevent division by zero
3185 if (.not. scpf_ON) then
3186 ssat_cld = ssat(i,k)
3190 supi_cld = supi(i,k)
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 %
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
3214 qccon = min(qccon, qv(i,k)*odt)
3217 if (qrcon.lt.0.) then
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]
3223 qrcon = min(qrcon, qv(i,k)*odt)
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
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))
3251 qidep(iice) = qidep(iice)*clbfact_dep
3252 qidep(iice) = min(qidep(iice), qv(i,k)*odt)
3255 enddo iice_loop_depsub
3260 !................................................................
3261 ! deposition/condensation-freezing nucleation
3262 ! (allow ice nucleation if T < -15 C and > 5% ice supersaturation)
3264 if (.not. scpf_ON) then
3266 supi_cld = supi(i,k)
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 %
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)
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
3290 qinuc(iice_dest) = Q_nuc
3291 ninuc(iice_dest) = N_nuc
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)
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
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)
3331 ! don't include mass increase from droplet activation during first time step
3332 ! since this is already accounted for by saturation adjustment below
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
3349 dumt = th(i,k)*(pres(i,k)*1.e-5)**(rd*inv_cp)
3351 dumqvs = qv_sat(dumt,pres(i,k),0)
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.
3359 !................................................................
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
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) &
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)
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
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)
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
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)
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
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
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)
3469 if (qcacc.eq.0.) ncacc = 0.
3470 if (ncacc.eq.0.) qcacc = 0.
3474 !.....................................
3475 ! self-collection and breakup of rain
3476 ! (breakup following modified Verlinde and Cotton scheme)
3478 if (qr(i,k).ge.qsmall) then
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
3491 else if (dum2.ge.dum1) then
3492 dum = 2.-exp(2300.*(dum2-dum1))
3493 ! dum = 2.-dexp(dble(2300.*(dum2-dum1)))
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
3507 !.................................................................
3508 ! conservation of mass
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
3525 if (tmp1.gt.0. .and. tmp1.gt.qcon_satadj) then
3526 ratio = max(0.,qcon_satadj)/tmp1
3527 ratio = min(1.,ratio)
3532 elseif (qcevp+qrevp.gt.0.) then
3533 ratio = max(0.,-qcon_satadj)/(qcevp+qrevp)
3534 ratio = min(1.,ratio)
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
3553 if (tmp1.gt.0. .and. tmp1.gt.qdep_satadj) then
3554 ratio = max(0.,qdep_satadj)/tmp1
3555 ratio = min(1.,ratio)
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)
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
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
3579 qcheti = qcheti*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
3587 ncheti = ncheti*ratio
3588 !nchetc = nchetc*ratio
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
3599 qrheti = qrheti*ratio
3603 nrheti = nrheti*ratio
3604 !qrhetc = qrhetc*ratio
3605 !nrhetc = nrhetc*ratio
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
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
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
3626 qicol(iice,catcoll) = qicol(iice,catcoll)*ratio
3627 nicol(iice,catcoll) = nicol(iice,catcoll)*ratio
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
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)
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
3669 iice_loop_z2: do iice = 1,nCat
3671 !update further due to category interactions:
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)
3685 !if there is no existing ice, assume an ice density of 900 kg m-3
3686 dumm3(iice) = 6./(900.*pi)*dumm3(iice)
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)
3695 !no ice present, therefore assign an initial value
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)
3703 zitot(i,k,iice) = 0.
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
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
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
3737 !---- Group 3 -- processes that we know how to do formally
3738 ! FUTURE. e.g. diffusional growth, riming, drop freezing
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
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
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
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
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)
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
3829 if (qirim(i,k,iice).lt.0.) then
3830 qirim(i,k,iice) = 0.
3831 birim(i,k,iice) = 0.
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
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)
3847 ! densify in above freezing conditions and melting
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.
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))* &
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
3875 nc(i,k) = nccnst*inv_rho(i,k)
3877 if (iparam.eq.1 .or. iparam.eq.2) then
3878 nr(i,k) = nr(i,k) + (0.5*ncautc-nrslf-nrevp)*dt
3880 nr(i,k) = nr(i,k) + (ncautr-nrslf-nrevp)*dt
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)* &
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
3895 log_hydrometeorsPresent = .true.
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
3904 log_hydrometeorsPresent = .true.
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.
3916 log_hydrometeorsPresent = .true.
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 !---------------------------------------------------------------------------------
3929 !-- for sedimentation-only tests:
3931 ! log_hydrometeorsPresent = .true.
3934 !......................................
3935 ! zero out zitot if there is no qitot for triple moment
3936 if (log_3momentIce) then
3938 do k = kbot,ktop,kdir
3939 if (qitot(i,k,iice).lt.qsmall) zitot(i,k,iice) = 0.
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.
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, &
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)
3964 if (global_status /= STATUS_OK) return
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 !==========================================================================================!
3981 !------------------------------------------------------------------------------------------!
3982 ! Cloud sedimentation: (adaptivive substepping)
3984 log_qxpresent = .false.
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.
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
4002 do k = kbot,k_qxtop,kdir
4003 if (qc(i,k)*iSCF(k).ge.qsmall) then
4009 two_moment: if (log_predictNc) then !2-moment cloud:
4011 substep_sedi_c2: do while (dt_left.gt.1.e-4)
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.))
4027 Co_max = max(Co_max, V_qc(k)*dt_left*inv_dzq(i,k))
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
4038 k_temp = k_qxbot-kdir
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)
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)
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)
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)
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.))
4086 Co_max = max(Co_max, V_qc(k)*dt_left*inv_dzq(i,k))
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
4096 k_temp = k_qxbot-kdir
4099 do k = k_temp,k_qxtop,kdir
4100 flux_qx(k) = V_qc(k)*qc(i,k)*rho(i,k)
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)
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)
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
4123 prt_liq(i) = prt_accum*inv_rhow*odt !note, contribution from rain is added below
4128 !------------------------------------------------------------------------------------------!
4129 ! Rain sedimentation: (adaptivive substepping)
4131 log_qxpresent = .false.
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.
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
4149 do k = kbot,k_qxtop,kdir
4150 if (qr(i,k)*iSPF(k).ge.qsmall) then
4156 substep_sedi_r: do while (dt_left.gt.1.e-4)
4162 kloop_sedi_r1: do k = k_qxtop,k_qxbot,-kdir
4164 qr_not_small_1: if (qr(i,k)*iSPF(k)>qsmall) then
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))
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
4205 k_temp = k_qxbot-kdir
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)
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)
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)
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
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
4256 !find top, determine qxpresent
4257 do k = ktop,kbot,-kdir
4258 if (qitot(i,k,iice).ge.qsmall) then
4259 log_qxpresent = .true.
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
4271 do k = kbot,k_qxtop,kdir
4272 if (qitot(i,k,iice).ge.qsmall) then
4278 three_moment_ice_1: if (.not. log_3momentIce) then
4280 substep_sedi_i1: do while (dt_left.gt.1.e-4)
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
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)
4308 endif qi_notsmall_i1
4310 Co_max = max(Co_max, V_qit(k)*dt_left*inv_dzq(i,k))
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
4321 k_temp = k_qxbot-kdir
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)
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)
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)
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)
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
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
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
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))
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
4435 k_temp = k_qxbot-kdir
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)
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)
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)
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
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.
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,:,:))
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)
4513 ! if (global_status /= STATUS_OK) return
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.
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
4540 qc_not_small_2: if (qc(i,k).ge.qsmall .and. t(i,k).lt.233.15) then
4543 nc(i,k) = max(nc(i,k),nsmall)
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, &
4552 if (global_status /= STATUS_OK) return
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
4581 nr(i,k) = max(nr(i,k),nsmall)
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
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
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), &
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), &
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
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
4646 call access_lookup_table_3mom(dumzz,dumjj,dumii,dumi,11,dum1,dum4,dum5,dum6,f1pr15)
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
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))
4659 diag_di(i,k,iice) = f1pr15
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
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.
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.
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,:,:))
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)
4714 ! if (global_status /= STATUS_OK) return
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
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)
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
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
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)
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
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), &
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), &
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
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
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
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
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))
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.
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)
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)
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.
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
4895 enddo k_loop_final_diagnostics
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, &
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)
4908 if (global_status /= STATUS_OK) return
4911 !.....................................................
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.
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
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
4941 ! calculate 'binary' cloud fraction (0 or 1) (diagnostic only; used in GEM radiation interface)
4943 SCF_out(i,:) = SCF(:)
4945 do k = kbot,ktop,kdir
4947 if (qc(i,k).ge.qsmall .and. sup(i,k).gt.1.e-6) SCF_out(i,k) = 1.
4949 if (qitot(i,k,iice).ge.qsmall .and. diag_effi(i,k,iice).lt.100.e-6) SCF_out(i,k) = 1.
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, &
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)
4966 if (global_status /= STATUS_OK) return
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)
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]
4991 diag_vis2(i,k)= max(minVIS,1000.*(-4.12*tmp1**0.176+9.01)) ![m]
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]
4997 diag_vis3(i,k)= max(minVIS,1000.*(1.10*tmp1**(-0.701))) ![m]
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))
5008 endif !if present(diag_vis)
5010 !.....................................................
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
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
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
5053 !diagnose hydrometeor types at bottom level only (for specific precip rates)
5054 ktop_typeDiag = kbot
5057 i_loop_typediag: do i = its,ite
5059 !-- rain vs. drizzle:
5060 k_loop_typdiag_1: do k = kbot,ktop_typeDiag,kdir
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)
5071 Q_rain(i,k) = qr(i,k)
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)
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
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)
5105 Q_ursnow(i,k,iice) = qitot(i,k,iice)
5107 elseif (tmp1>=0.1 .and. tmp1<0.6) then
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)
5115 if (diag_di(i,k,iice)<1.e-3) then
5116 Q_pellets(i,k,iice) = qitot(i,k,iice)
5118 Q_hail(i,k,iice) = qitot(i,k,iice)
5122 print*, 'STOP -- unrealistic rime fraction: ',tmp1
5123 global_status = STATUS_ERROR
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
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
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(:,:)
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)
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 !.....................................................................................
5201 END SUBROUTINE p3_main
5203 !==========================================================================================!
5205 SUBROUTINE access_lookup_table(dumjj,dumii,dumi,index,dum1,dum4,dum5,proc)
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, &
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, &
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, &
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, &
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, &
5280 gproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
5281 tmp1 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
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, &
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, &
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, &
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)
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)
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)
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)
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)
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
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, &
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, &
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, &
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, &
5918 gproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
5919 tmp1 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
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, &
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, &
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, &
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 !.....................................................................................
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, &
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, &
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, &
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, &
5977 gproc1 = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
5978 tmp1 = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
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, &
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, &
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, &
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 !-------------------------------------------
6031 ! REPLACE GOFF-GRATCH WITH FASTER FORMULATION FROM FLATAU ET AL. 1992, TABLE 4 (RIGHT-HAND COLUMN)
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/
6041 real a0,a1,a2,a3,a4,a5,a6,a7,a8
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/
6050 !-------------------------------------------
6052 if (i_type.EQ.1 .and. T.lt.273.15) then
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
6058 polysvp1 = a0i + dt*(a1i+dt*(a2i+dt*(a3i+dt*(a4i+dt*(a5i+dt*(a6i+dt*(a7i+a8i*dt)))))))
6059 polysvp1 = polysvp1*100.
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.
6066 elseif (i_type.EQ.0 .or. T.ge.273.15) then
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
6072 polysvp1 = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt)))))))
6073 polysvp1 = polysvp1*100.
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.
6086 end function polysvp1
6088 !------------------------------------------------------------------------------------------!
6090 real function DERF(X)
6095 real, dimension(0 : 64) :: A, B
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 /
6175 if (W .LT. 2.2D0) then
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
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)
6201 if (X .LT. 0) Y = -Y
6206 !------------------------------------------------------------------------------------------!
6207 logical function isnan(arg1)
6208 real,intent(in) :: arg1
6209 isnan = (arg1 .ne. arg1)
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.
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.
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)
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 !--------------------------------------------------------------------------------------!
6242 real, intent(in), dimension(:) :: Qi,Di
6243 real, intent(in) :: D_nuc,deltaD_init
6244 integer, intent(out) :: iice_dest
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 !--------------------------------------------------------------------------------------!
6262 if (sum(Qi(:))<qsmall_loc) then
6273 i_firstEmptyCategory = 0
6276 if (Qi(iice) .ge. qsmall_loc) then
6278 diff = abs(Di(iice)-D_nuc)
6279 if (diff .lt. mindiff) then
6285 if (i_firstEmptyCategory.eq.0) i_firstEmptyCategory = iice
6291 iice_dest = i_mindiff
6294 if (mindiff .lt. deltaD_init) then
6296 iice_dest = i_mindiff
6300 iice_dest = i_firstEmptyCategory
6307 print*, 'ERROR in s/r icecat_destination -- made it to end'
6308 global_status = STATUS_ERROR
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.
6322 !------------------------------------------------------------------------------------------!
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
6341 ! set limits (to make sure the calculated index doesn't exceed range of lookup table)
6342 dum1 = min(dum1,real(isize))
6345 dumi = min(isize-1,dumi)
6347 ! find index for rime mass fraction
6348 dum4 = (qirim/qitot)*3. + 1.
6351 dum4 = min(dum4,real(rimsize))
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.
6361 dum5 =(rhop-650.)*0.004 + 4.
6365 dum5 = min(dum5,real(densize))
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 !------------------------------------------------------------------------------------------!
6383 integer, intent(out) :: dumj
6384 real, intent(out) :: dum3
6385 integer, intent(in) :: rcollsize
6386 real, intent(in) :: qr,nr
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
6401 dum3 = min(dum3,real_rcollsize)
6404 dumj = min(rcollsize-1,dumj)
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 !------------------------------------------------------------------------------------------!
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
6448 dum6 = min(dum6,real(zsize))
6450 dumzz = max(1,dumzz)
6451 dumzz = min(zsize-1,dumzz)
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 !------------------------------------------------------------------------------------------!
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
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
6503 dum1 = min(dum1,real(iisize))
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.
6515 dum4 = min(dum4,real(rimsize))
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)
6524 if (birim_1.ge.bsmall) then
6525 drhop = qirim_1/birim_1
6530 if (drhop.le.650.) then
6531 dum5 = (drhop-50.)*0.005 + 1.
6533 dum5 =(drhop-650.)*0.004 + 4.
6536 dum5 = min(dum5,real(densize))
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
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.
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
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.
6577 dum5c =(drhop-650.)*0.004 + 4.
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 !------------------------------------------------------------------------------------------!
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
6608 rdumii = (dum1*1.e6+5.)*inv_dum3
6609 rdumii = max(rdumii, 1.)
6610 rdumii = min(rdumii,20.)
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.)
6620 dumii = max(dumii, 20)
6621 dumii = min(dumii,299)
6624 ! find location in mu_r space
6626 rdumjj = max(rdumjj,1.)
6627 rdumjj = min(rdumjj,10.)
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)
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
6648 real :: lammin,lammax,qc,nc
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
6661 mu_c = 0.0005714*(nc*1.e-6*rho)+0.2714
6662 mu_c = 1./(mu_c**2)-1.
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
6669 nu = dnu(dumi)+(dnu(dumi+1)-dnu(dumi))*(mu_c-dumi)
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
6681 nc = 6.*lamc**3*qc/(pi*rhow*(mu_c+3.)*(mu_c+2.)*(mu_c+1.))
6682 elseif (lamc.gt.lammax) then
6684 nc = 6.*lamc**3*qc/(pi*rhow*(mu_c+3.)*(mu_c+2.)*(mu_c+1.))
6687 cdist = nc*(mu_c+1.)/lamc
6688 cdist1 = nc/gamma(mu_c+1.)
6689 nc_grd = nc/iSCF !compute modified grid-mean value
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
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
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_
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
6742 ! elseif (inv_dum.ge.282.e-6 .and. inv_dum.lt.502.e-6) then
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- &
6751 ! elseif (inv_dum.ge.502.e-6) then
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
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
6765 nr = exp(3.*log(lamr)+log(qr)+log(gamma(mu_r+1.))-log(gamma(mu_r+4.)))/(cons1)
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)
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 !--------------------------------------------------------------------------------
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
6817 !set upper constraint qi_rim <= qi_tot
6818 if (qi_rim.gt.qi_tot .and. rho_rime.gt.0.) then
6820 bi_rim = qi_rim/rho_rime
6824 if (qi_rim.lt.qsmall) then
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 !--------------------------------------------------------------------------------
6844 real, intent(inout), dimension(:) :: nitot_local !note: dimension (nCat)
6845 real, intent(in) :: max_total_Ni,inv_rho_local
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.)
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 !------------------------------------------------------------------------------------
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
6875 real :: e_pres !saturation vapor pressure [Pa]
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))
6884 e_pres = polysvp1(t_atm,i_wrt)
6885 qv_sat = ep_2*e_pres/max(1.e-3,(p_atm-e_pres))
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.
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).
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.
6910 !------------------------------------------------------------------------------------
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
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.
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.
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.
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.
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.
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.
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.
7000 ! check unrealistic values Qitot,Qirim,Nitot,Birim
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
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.
7035 if (badvalue_found .and. force_abort_in) then
7037 print*,'** DEBUG TRAP IN P3_MAIN, s/r CHECK_VALUES -- source: ',source_ind
7039 global_status = STATUS_ERROR
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).
7053 ! Note: moment 3 is not equal to the mass mixing ratio (due to variable density)
7055 ! G(mu)= mom0*mom6/mom3^2 = [(6+mu)(5+mu)(4+mu)]/[(3+mu)(2+mu)(1+mu)]
7056 !--------------------------------------------------------------------------
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
7067 real :: mu ! shape parameter in gamma distribution
7068 real :: G ! function of mu (see comments above)
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)
7087 ! g1= (6.+a1)*(5.+a1)*(4.+a1)/((3.+a1)*(2.+a1)*(1.+a1))
7088 ! if(abs(g-g1)<abs(g-g2)) then
7093 !----------------------------------------------------------!
7095 !Piecewise-polynomial approximation of G(mu) to solve for mu:
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
7119 compute_mu_3moment = mu
7123 print*, 'Input parameters out of bounds in function COMPUTE_MU_3MOMENT'
7124 print*, 'mom0 = ',mom0
7125 print*, 'mom3 = ',mom3
7126 print*, 'mom6 = ',mom6
7131 end function compute_mu_3moment
7133 !======================================================================================!
7134 real function G_of_mu(mu)
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).
7152 ! Follows method described in Milbrandt and Yau (2006a)
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)
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 !--------------------------------------------------------------------------
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
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)
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.))
7209 !-- method 1, based on Nh*crit only:
7213 ! N_tail = N_tail + n0*Di**mu*exp(-lam*Di)*dD
7214 ! if (N_tail>Ncrit) then
7219 ! maxHailSize = Dhmax_1
7221 !-- method 2, based on Rh*crit only:
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
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.
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.
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.
7251 ! ! if (found_N2 .and. found_R2) exit
7259 endif considered_hail
7261 end function maxHailSize
7263 !===========================================================================================
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
7274 integer :: F_istat !Function return status
7278 if (n_iceCat < 0) then
7279 call physeterror('microphy_p3::p3_phybusinit', &
7280 'Called mp_phybusinit() before mp_init()')
7285 'CLOUD_WATER_MASS ', &
7286 'CLOUD_WATER_NUM ', &
7291 'RATE_PRECIP_TYPES', &
7292 'PARTICLE_DIAMETER', &
7299 /)) /= PHY_OK) buserr = .true.
7300 if (.not. buserr) then
7301 if (bb_request('ICE_CAT_1') /= PHY_OK) buserr = .true.
7303 if (p3_trplmomi .and. .not. buserr) then
7304 if (bb_request('ICE_CAT_1_TM') /= PHY_OK) buserr = .true.
7306 if (n_iceCat > 1 .and. .not. buserr) then
7307 if (bb_request('ICE_CAT_2') /= PHY_OK) buserr = .true.
7309 if (n_iceCat > 1 .and. p3_trplmomi .and. .not. buserr) then
7310 if (bb_request('ICE_CAT_2_TM') /= PHY_OK) buserr = .true.
7312 if (n_iceCat > 2 .and. .not. buserr) then
7313 if (bb_request('ICE_CAT_3') /= PHY_OK) buserr = .true.
7315 if (n_iceCat > 2 .and. p3_trplmomi .and. .not. buserr) then
7316 if (bb_request('ICE_CAT_3_TM') /= PHY_OK) buserr = .true.
7318 if (n_iceCat > 3 .and. .not. buserr) then
7319 if (bb_request('ICE_CAT_4') /= PHY_OK) buserr = .true.
7321 if (n_iceCat > 3 .and. p3_trplmomi .and. .not. buserr) then
7322 if (bb_request('ICE_CAT_4_TM') /= PHY_OK) buserr = .true.
7326 call physeterror('microphy_p3::p3_phybusinit', &
7327 'Cannot construct bus request list')
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)
7339 use phy_status, only: PHY_OK, PHY_ERROR
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"
7348 real, dimension(:,:), pointer :: zqcp, zqrp
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(:,:)
7358 !===========================================================================================
7360 ! Compute total ice mass
7361 function p3_iwc(F_qitot, F_dbus, F_pbus, F_vbus) result(F_istat)
7363 use phy_status, only: PHY_OK, PHY_ERROR
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"
7372 real, dimension(:,:), pointer :: zqti1p, zqti2p, zqti3p, zqti4p
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)
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
7390 !======================================================================================!
7391 END MODULE microphy_p3