!WRF:MODEL_LAYER:PHYSICS ! MODULE module_mp_gsfcgce USE module_wrf_error !JJS 1/3/2008 vvvvv ! common /bt/ REAL, PRIVATE :: rd1, rd2, al, cp ! common /cont/ REAL, PRIVATE :: c38, c358, c610, c149, & c879, c172, c409, c76, & c218, c580, c141 ! common /b3cs/ REAL, PRIVATE :: ag, bg, as, bs, & aw, bw, bgh, bgq, & bsh, bsq, bwh, bwq ! common /size/ REAL, PRIVATE :: tnw, tns, tng, & roqs, roqg, roqr ! common /bterv/ REAL, PRIVATE :: zrc, zgc, zsc, & vrc, vgc, vsc ! common /bsnw/ REAL, PRIVATE :: alv, alf, als, t0, t00, & avc, afc, asc, rn1, bnd1, & rn2, bnd2, rn3, rn4, rn5, & rn6, rn7, rn8, rn9, rn10, & rn101,rn10a, rn11,rn11a, rn12 REAL, PRIVATE :: rn14, rn15,rn15a, rn16, rn17, & rn17a,rn17b,rn17c, rn18, rn18a, & rn19,rn19a,rn19b, rn20, rn20a, & rn20b, bnd3, rn21, rn22, rn23, & rn23a,rn23b, rn25,rn30a, rn30b, & rn30c, rn31, beta, rn32 REAL, PRIVATE, DIMENSION( 31 ) :: rn12a, rn12b, rn13, rn25a ! common /rsnw1/ REAL, PRIVATE :: rn10b, rn10c, rnn191, rnn192, rn30, & rnn30a, rn33, rn331, rn332 ! REAL, PRIVATE, DIMENSION( 31 ) :: aa1, aa2 DATA aa1/.7939e-7, .7841e-6, .3369e-5, .4336e-5, .5285e-5, & .3728e-5, .1852e-5, .2991e-6, .4248e-6, .7434e-6, & .1812e-5, .4394e-5, .9145e-5, .1725e-4, .3348e-4, & .1725e-4, .9175e-5, .4412e-5, .2252e-5, .9115e-6, & .4876e-6, .3473e-6, .4758e-6, .6306e-6, .8573e-6, & .7868e-6, .7192e-6, .6513e-6, .5956e-6, .5333e-6, & .4834e-6/ DATA aa2/.4006, .4831, .5320, .5307, .5319, & .5249, .4888, .3894, .4047, .4318, & .4771, .5183, .5463, .5651, .5813, & .5655, .5478, .5203, .4906, .4447, & .4126, .3960, .4149, .4320, .4506, & .4483, .4460, .4433, .4413, .4382, & .4361/ !JJS 1/3/2008 ^^^^^ CONTAINS !------------------------------------------------------------------- ! NASA/GSFC GCE ! Tao et al, 2001, Meteo. & Atmos. Phy., 97-137 !------------------------------------------------------------------- ! SUBROUTINE gsfcgce( th, th_old, & SUBROUTINE gsfcgce( th, & qv, ql, & qr, qi, & qs, & ! qvold, qlold, & ! qrold, qiold, & ! qsold, & rho, pii, p, dt_in, z, & ht, dz8w, grav, & rhowater, rhosnow, & itimestep, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte, & ! tile dims rainnc, rainncv, & snownc, snowncv, sr, & graupelnc, graupelncv, & ! f_qg, qg, pgold & f_qg, qg, & ihail, ice2 & ) !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- ! ! JJS 2/15/2005 ! INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte INTEGER, INTENT(IN ) :: itimestep, ihail, ice2 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & INTENT(INOUT) :: & th, & qv, & ql, & qr, & qi, & qs, & qg ! REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & INTENT(IN ) :: & ! th_old, & ! qvold, & ! qlold, & ! qrold, & ! qiold, & ! qsold, & ! qgold, & rho, & pii, & p, & dz8w, & z REAL, DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: rainnc, & rainncv, & snownc, & snowncv, & sr, & graupelnc, & graupelncv REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: ht REAL, INTENT(IN ) :: dt_in, & grav, & rhowater, & rhosnow LOGICAL, INTENT(IN), OPTIONAL :: F_QG ! LOCAL VAR !jjs INTEGER :: min_q, max_q !jjs REAL, DIMENSION( its:ite , jts:jte ) & !jjs :: rain, snow, graupel,ice ! ! INTEGER :: IHAIL, itaobraun, ice2, istatmin, new_ice_sat, id INTEGER :: itaobraun, istatmin, new_ice_sat, id INTEGER :: i, j, k INTEGER :: iskip, ih, icount, ibud, i12h REAL :: hour REAL , PARAMETER :: cmin=1.e-20 REAL :: dth, dqv, dqrest, dqall, dqall1, rhotot, a1, a2 REAL, DIMENSION( its:ite , kts:kte , jts:jte ) :: & th1, qv1, ql1, qr1, qi1, qs1, qg1 LOGICAL :: flag_qg ! !c ihail = 0 for graupel, for tropical region !c ihail = 1 for hail, for mid-lat region ! itaobraun: 0 for Tao's constantis, 1 for Braun's constants !c if ( itaobraun.eq.1 ) --> betah=0.5*beta=-.46*0.5=-0.23; cn0=1.e-6 !c if ( itaobraun.eq.0 ) --> betah=0.5*beta=-.6*0.5=-0.30; cn0=1.e-8 itaobraun = 1 !c ice2 = 0 for 3 ice --- ice, snow and graupel/hail !c ice2 = 1 for 2 ice --- ice and snow only !c ice2 = 2 for 2 ice --- ice and graupel only, use ihail = 0 only i12h=int(86400./dt_in) ! if (itimestep.eq.1.or.itimestep.eq.1441) then ! if (mod(itimestep,1440).eq.1) then if (mod(itimestep,i12h).eq.1) then write(6,*) 'ihail=',ihail,' ice2=',ice2 if (ice2.eq.0) then write(6,*) 'Running 3-ice scheme in GSFCGCE with' if (ihail.eq.0) then write(6,*) ' ice, snow and graupel' else if (ihail.eq.1) then write(6,*) ' ice, snow and hail' else write(6,*) 'ihail has to be either 1 or 0' stop endif !ihail else if (ice2.eq.1) then write(6,*) 'Running 2-ice scheme in GSFCGCE with' write(6,*) ' ice and snow' else if (ice2.eq.2) then write(6,*) 'Running 2-ice scheme in GSFCGCE with' write(6,*) ' ice and graupel' else write(6,*) 'gsfcgce_2ice in namelist.input has to be 0, 1, or 2' stop endif !ice2 endif !itimestep !c new_ice_sat = 0, 1 or 2 new_ice_sat = 2 !c istatmin istatmin = 180 !c id = 0 without in-line staticstics !c id = 1 with in-line staticstics id = 0 !c ibud = 0 no calculation of dth, dqv, dqrest and dqall !c ibud = 1 yes ibud = 0 !jjs dt=dt_in !jjs rhoe_s=1.29 ! ! IF (P_QI .lt. P_FIRST_SCALAR .or. P_QS .lt. P_FIRST_SCALAR) THEN ! CALL wrf_error_fatal3 ( "module_mp_lin.b" , 130 , 'module_mp_lin: Improper use of Lin et al scheme; no ice phase. Please chose another one.') ! ENDIF ! calculte fallflux and precipiation in MKS system call fall_flux(dt_in, qr, qi, qs, qg, p, & rho, z, dz8w, ht, rainnc, & rainncv, grav,itimestep, & rhowater, rhosnow, & snownc, snowncv, sr, & graupelnc, graupelncv, & ihail, ice2, & ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte ) ! tile dims !----------------------------------------------------------------------- !c set up constants used internally in GCE call consat_s (ihail, itaobraun) !c Negative values correction iskip = 1 ! i12h=int(86400./dt_in) if (iskip.eq.0) then call negcor(qv,rho,dz8w,ims,ime,jms,jme,kms,kme, & itimestep,1, & its,ite,jts,jte,kts,kte) call negcor(ql,rho,dz8w,ims,ime,jms,jme,kms,kme, & itimestep,2, & its,ite,jts,jte,kts,kte) call negcor(qr,rho,dz8w,ims,ime,jms,jme,kms,kme, & itimestep,3, & its,ite,jts,jte,kts,kte) call negcor(qi,rho,dz8w,ims,ime,jms,jme,kms,kme, & itimestep,4, & its,ite,jts,jte,kts,kte) call negcor(qs,rho,dz8w,ims,ime,jms,jme,kms,kme, & itimestep,5, & its,ite,jts,jte,kts,kte) call negcor(qg,rho,dz8w,ims,ime,jms,jme,kms,kme, & itimestep,6, & its,ite,jts,jte,kts,kte) if (mod(itimestep,i12h).eq.1) then print *,'negative correction used in gsfcgce mp ' endif endif ! iskip !c microphysics in GCE call SATICEL_S( dt_in, IHAIL, itaobraun, ICE2, istatmin, & new_ice_sat, id, & ! th, th_old, qv, ql, qr, & th, qv, ql, qr, & qi, qs, qg, & ! qvold, qlold, qrold, & ! qiold, qsold, qgold, & rho, pii, p, itimestep, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte & ! tile dims ) END SUBROUTINE gsfcgce !----------------------------------------------------------------------- SUBROUTINE fall_flux ( dt, qr, qi, qs, qg, p, & rho, z, dz8w, topo, rainnc, & rainncv, grav, itimestep, & rhowater, rhosnow, & snownc, snowncv, sr, & graupelnc, graupelncv, & ihail, ice2, & ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte ) ! tile dims !----------------------------------------------------------------------- ! adopted from Jiun-Dar Chern's codes for Purdue Regional Model ! adopted by Jainn J. Shi, 6/10/2005 !----------------------------------------------------------------------- IMPLICIT NONE INTEGER, INTENT(IN ) :: ihail, ice2, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte INTEGER, INTENT(IN ) :: itimestep REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & INTENT(INOUT) :: qr, qi, qs, qg REAL, DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: rainnc, rainncv, & snownc, snowncv, sr, & graupelnc, graupelncv REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & INTENT(IN ) :: rho, z, dz8w, p REAL, INTENT(IN ) :: dt, grav, rhowater, rhosnow REAL, DIMENSION( ims:ime , jms:jme ), & INTENT(IN ) :: topo ! temperary vars REAL, DIMENSION( kts:kte ) :: sqrhoz REAL :: tmp1, term0 REAL :: pptrain, pptsnow, & pptgraul, pptice REAL, DIMENSION( kts:kte ) :: qrz, qiz, qsz, qgz, & zz, dzw, prez, rhoz, & orhoz INTEGER :: k, i, j ! REAL, DIMENSION( kts:kte ) :: vtr, vts, vtg, vti REAL :: dtb, pi, consta, constc, gambp4, & gamdp4, gam4pt5, gam4bbar ! Lin REAL , PARAMETER :: xnor = 8.0e6 ! REAL , PARAMETER :: xnos = 3.0e6 REAL , PARAMETER :: xnos = 1.6e7 ! Tao's value REAL , PARAMETER :: & constb = 0.8, constd = 0.25, o6 = 1./6., & cdrag = 0.6 ! Lin ! REAL , PARAMETER :: xnoh = 4.0e4 REAL , PARAMETER :: xnoh = 2.0e5 ! Tao's value REAL , PARAMETER :: rhohail = 917. ! Hobbs REAL , PARAMETER :: xnog = 4.0e6 REAL , PARAMETER :: rhograul = 400. REAL , PARAMETER :: abar = 19.3, bbar = 0.37, & p0 = 1.0e5 REAL , PARAMETER :: rhoe_s = 1.29 ! for terminal velocity flux INTEGER :: min_q, max_q REAL :: t_del_tv, del_tv, flux, fluxin, fluxout ,tmpqrz LOGICAL :: notlast ! if (itimestep.eq.1) then ! write(6, *) 'in fall_flux' ! write(6, *) 'ims=', ims, ' ime=', ime ! write(6, *) 'jms=', jms, ' jme=', jme ! write(6, *) 'kms=', kms, ' kme=', kme ! write(6, *) 'its=', its, ' ite=', ite ! write(6, *) 'jts=', jts, ' jte=', jte ! write(6, *) 'kts=', kts, ' kte=', kte ! write(6, *) 'dt=', dt ! write(6, *) 'ihail=', ihail ! write(6, *) 'ICE2=', ICE2 ! write(6, *) 'dt=', dt ! endif !----------------------------------------------------------------------- ! This program calculates precipitation fluxes due to terminal velocities. !----------------------------------------------------------------------- dtb=dt pi=acos(-1.) consta=2115.0*0.01**(1-constb) ! constc=152.93*0.01**(1-constd) constc=78.63*0.01**(1-constd) ! Gamma function gambp4=ggamma(constb+4.) gamdp4=ggamma(constd+4.) gam4pt5=ggamma(4.5) gam4bbar=ggamma(4.+bbar) !*********************************************************************** ! Calculate precipitation fluxes due to terminal velocities. !*********************************************************************** ! !- Calculate termianl velocity (vt?) of precipitation q?z !- Find maximum vt? to determine the small delta t j_loop: do j = jts, jte i_loop: do i = its, ite pptrain = 0. pptsnow = 0. pptgraul = 0. pptice = 0. do k = kts, kte qrz(k)=qr(i,k,j) rhoz(k)=rho(i,k,j) orhoz(k)=1./rhoz(k) prez(k)=p(i,k,j) sqrhoz(k)=sqrt(rhoe_s/rhoz(k)) zz(k)=z(i,k,j) dzw(k)=dz8w(i,k,j) enddo !k DO k = kts, kte qiz(k)=qi(i,k,j) ENDDO DO k = kts, kte qsz(k)=qs(i,k,j) ENDDO IF (ice2 .eq. 0) THEN DO k = kts, kte qgz(k)=qg(i,k,j) ENDDO ELSE DO k = kts, kte qgz(k)=0. ENDDO ENDIF ! !-- rain ! t_del_tv=0. del_tv=dtb notlast=.true. DO while (notlast) ! min_q=kte max_q=kts-1 ! do k=kts,kte-1 if (qrz(k) .gt. 1.0e-8) then min_q=min0(min_q,k) max_q=max0(max_q,k) tmp1=sqrt(pi*rhowater*xnor/rhoz(k)/qrz(k)) tmp1=sqrt(tmp1) vtr(k)=consta*gambp4*sqrhoz(k)/tmp1**constb vtr(k)=vtr(k)/6. if (k .eq. 1) then del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vtr(k)) else del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtr(k)) endif else vtr(k)=0. endif enddo if (max_q .ge. min_q) then ! !- Check if the summation of the small delta t >= big delta t ! (t_del_tv) (del_tv) (dtb) t_del_tv=t_del_tv+del_tv ! if ( t_del_tv .ge. dtb ) then notlast=.false. del_tv=dtb+del_tv-t_del_tv endif ! use small delta t to calculate the qrz flux ! termi is the qrz flux pass in the grid box through the upper boundary ! termo is the qrz flux pass out the grid box through the lower boundary ! fluxin=0. do k=max_q,min_q,-1 fluxout=rhoz(k)*vtr(k)*qrz(k) flux=(fluxin-fluxout)/rhoz(k)/dzw(k) ! tmpqrz=qrz(k) qrz(k)=qrz(k)+del_tv*flux qrz(k)=amax1(0.,qrz(k)) qr(i,k,j)=qrz(k) fluxin=fluxout enddo if (min_q .eq. 1) then pptrain=pptrain+fluxin*del_tv else qrz(min_q-1)=qrz(min_q-1)+del_tv* & fluxin/rhoz(min_q-1)/dzw(min_q-1) qr(i,min_q-1,j)=qrz(min_q-1) endif ! else notlast=.false. endif ENDDO ! !-- snow ! t_del_tv=0. del_tv=dtb notlast=.true. DO while (notlast) ! min_q=kte max_q=kts-1 ! do k=kts,kte-1 if (qsz(k) .gt. 1.0e-8) then min_q=min0(min_q,k) max_q=max0(max_q,k) tmp1=sqrt(pi*rhosnow*xnos/rhoz(k)/qsz(k)) tmp1=sqrt(tmp1) vts(k)=constc*gamdp4*sqrhoz(k)/tmp1**constd vts(k)=vts(k)/6. if (k .eq. 1) then del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vts(k)) else del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vts(k)) endif else vts(k)=0. endif enddo if (max_q .ge. min_q) then ! ! !- Check if the summation of the small delta t >= big delta t ! (t_del_tv) (del_tv) (dtb) t_del_tv=t_del_tv+del_tv if ( t_del_tv .ge. dtb ) then notlast=.false. del_tv=dtb+del_tv-t_del_tv endif ! use small delta t to calculate the qsz flux ! termi is the qsz flux pass in the grid box through the upper boundary ! termo is the qsz flux pass out the grid box through the lower boundary ! fluxin=0. do k=max_q,min_q,-1 fluxout=rhoz(k)*vts(k)*qsz(k) flux=(fluxin-fluxout)/rhoz(k)/dzw(k) qsz(k)=qsz(k)+del_tv*flux qsz(k)=amax1(0.,qsz(k)) qs(i,k,j)=qsz(k) fluxin=fluxout enddo if (min_q .eq. 1) then pptsnow=pptsnow+fluxin*del_tv else qsz(min_q-1)=qsz(min_q-1)+del_tv* & fluxin/rhoz(min_q-1)/dzw(min_q-1) qs(i,min_q-1,j)=qsz(min_q-1) endif ! else notlast=.false. endif ENDDO ! ! ice2=0 --- with hail/graupel ! ice2=1 --- without hail/graupel ! if (ice2.eq.0) then ! !-- If IHAIL=1, use hail. !-- If IHAIL=0, use graupel. ! ! if (ihail .eq. 1) then ! xnog = xnoh ! rhograul = rhohail ! endif t_del_tv=0. del_tv=dtb notlast=.true. ! DO while (notlast) ! min_q=kte max_q=kts-1 ! do k=kts,kte-1 if (qgz(k) .gt. 1.0e-8) then if (ihail .eq. 1) then ! for hail, based on Lin et al (1983) min_q=min0(min_q,k) max_q=max0(max_q,k) tmp1=sqrt(pi*rhohail*xnoh/rhoz(k)/qgz(k)) tmp1=sqrt(tmp1) term0=sqrt(4.*grav*rhohail/3./rhoz(k)/cdrag) vtg(k)=gam4pt5*term0*sqrt(1./tmp1) vtg(k)=vtg(k)/6. if (k .eq. 1) then del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vtg(k)) else del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtg(k)) endif !k else ! added by JJS ! for graupel, based on RH (1984) min_q=min0(min_q,k) max_q=max0(max_q,k) tmp1=sqrt(pi*rhograul*xnog/rhoz(k)/qgz(k)) tmp1=sqrt(tmp1) tmp1=tmp1**bbar tmp1=1./tmp1 term0=abar*gam4bbar/6. vtg(k)=term0*tmp1*(p0/prez(k))**0.4 if (k .eq. 1) then del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vtg(k)) else del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtg(k)) endif !k endif !ihail else vtg(k)=0. endif !qgz enddo !k if (max_q .ge. min_q) then ! ! !- Check if the summation of the small delta t >= big delta t ! (t_del_tv) (del_tv) (dtb) t_del_tv=t_del_tv+del_tv if ( t_del_tv .ge. dtb ) then notlast=.false. del_tv=dtb+del_tv-t_del_tv endif ! use small delta t to calculate the qgz flux ! termi is the qgz flux pass in the grid box through the upper boundary ! termo is the qgz flux pass out the grid box through the lower boundary ! fluxin=0. do k=max_q,min_q,-1 fluxout=rhoz(k)*vtg(k)*qgz(k) flux=(fluxin-fluxout)/rhoz(k)/dzw(k) qgz(k)=qgz(k)+del_tv*flux qgz(k)=amax1(0.,qgz(k)) qg(i,k,j)=qgz(k) fluxin=fluxout enddo if (min_q .eq. 1) then pptgraul=pptgraul+fluxin*del_tv else qgz(min_q-1)=qgz(min_q-1)+del_tv* & fluxin/rhoz(min_q-1)/dzw(min_q-1) qg(i,min_q-1,j)=qgz(min_q-1) endif ! else notlast=.false. endif ! ENDDO ENDIF !ice2 ! !-- cloud ice (03/21/02) follow Vaughan T.J. Phillips at GFDL ! t_del_tv=0. del_tv=dtb notlast=.true. ! DO while (notlast) ! min_q=kte max_q=kts-1 ! do k=kts,kte-1 if (qiz(k) .gt. 1.0e-8) then min_q=min0(min_q,k) max_q=max0(max_q,k) vti(k)= 3.29 * (rhoz(k)* qiz(k))** 0.16 ! Heymsfield and Donner if (k .eq. 1) then del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vti(k)) else del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vti(k)) endif else vti(k)=0. endif enddo if (max_q .ge. min_q) then ! ! !- Check if the summation of the small delta t >= big delta t ! (t_del_tv) (del_tv) (dtb) t_del_tv=t_del_tv+del_tv if ( t_del_tv .ge. dtb ) then notlast=.false. del_tv=dtb+del_tv-t_del_tv endif ! use small delta t to calculate the qiz flux ! termi is the qiz flux pass in the grid box through the upper boundary ! termo is the qiz flux pass out the grid box through the lower boundary ! fluxin=0. do k=max_q,min_q,-1 fluxout=rhoz(k)*vti(k)*qiz(k) flux=(fluxin-fluxout)/rhoz(k)/dzw(k) qiz(k)=qiz(k)+del_tv*flux qiz(k)=amax1(0.,qiz(k)) qi(i,k,j)=qiz(k) fluxin=fluxout enddo if (min_q .eq. 1) then pptice=pptice+fluxin*del_tv else qiz(min_q-1)=qiz(min_q-1)+del_tv* & fluxin/rhoz(min_q-1)/dzw(min_q-1) qi(i,min_q-1,j)=qiz(min_q-1) endif ! else notlast=.false. endif ! ENDDO !notlast ! prnc(i,j)=prnc(i,j)+pptrain ! psnowc(i,j)=psnowc(i,j)+pptsnow ! pgrauc(i,j)=pgrauc(i,j)+pptgraul ! picec(i,j)=picec(i,j)+pptice ! ! write(6,*) 'i=',i,' j=',j,' ', pptrain, pptsnow, pptgraul, pptice ! call flush(6) snowncv(i,j) = pptsnow snownc(i,j) = snownc(i,j) + pptsnow graupelncv(i,j) = pptgraul graupelnc(i,j) = graupelnc(i,j) + pptgraul RAINNCV(i,j) = pptrain + pptsnow + pptgraul + pptice RAINNC(i,j) = RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice sr(i,j) = 0. if (RAINNCV(i,j) .gt. 0.) sr(i,j) = (pptsnow + pptgraul + pptice) / RAINNCV(i,j) ENDDO i_loop ENDDO j_loop ! if (itimestep.eq.6480) then ! write(51,*) 'in the end of fallflux, itimestep=',itimestep ! do j=jts,jte ! do i=its,ite ! if (rainnc(i,j).gt.400.) then ! write(50,*) 'i=',i,' j=',j,' rainnc=',rainnc ! endif ! enddo ! enddo ! endif END SUBROUTINE fall_flux !---------------------------------------------------------------- REAL FUNCTION ggamma(X) !---------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------- REAL, INTENT(IN ) :: x REAL, DIMENSION(8) :: B INTEGER ::j, K1 REAL ::PF, G1TO2 ,TEMP DATA B/-.577191652,.988205891,-.897056937,.918206857, & -.756704078,.482199394,-.193527818,.035868343/ PF=1. TEMP=X DO 10 J=1,200 IF (TEMP .LE. 2) GO TO 20 TEMP=TEMP-1. 10 PF=PF*TEMP 100 FORMAT(//,5X,'module_gsfcgce: INPUT TO GAMMA FUNCTION TOO LARGE, X=',E12.5) WRITE(wrf_err_message,100)X CALL wrf_error_fatal(wrf_err_message) 20 G1TO2=1. TEMP=TEMP - 1. DO 30 K1=1,8 30 G1TO2=G1TO2 + B(K1)*TEMP**K1 ggamma=PF*G1TO2 END FUNCTION ggamma !----------------------------------------------------------------------- !c Correction of negative values SUBROUTINE negcor ( X, rho, dz8w, & ims,ime, jms,jme, kms,kme, & ! memory dims itimestep, ics, & its,ite, jts,jte, kts,kte ) ! tile dims !----------------------------------------------------------------------- REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & INTENT(INOUT) :: X REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & INTENT(IN ) :: rho, dz8w integer, INTENT(IN ) :: itimestep, ics !c Local variables ! REAL, DIMENSION( kts:kte ) :: Y1, Y2 REAL :: A0, A1, A2 A1=0. A2=0. do k=kts,kte do j=jts,jte do i=its,ite A1=A1+max(X(i,k,j), 0.)*rho(i,k,j)*dz8w(i,k,j) A2=A2+max(-X(i,k,j), 0.)*rho(i,k,j)*dz8w(i,k,j) enddo enddo enddo ! A1=0.0 ! A2=0.0 ! do k=kts,kte ! A1=A1+Y1(k) ! A2=A2+Y2(k) ! enddo A0=0.0 if (A1.NE.0.0.and.A1.GT.A2) then A0=(A1-A2)/A1 if (mod(itimestep,540).eq.0) then if (ics.eq.1) then write(61,*) 'kms=',kms,' kme=',kme,' kts=',kts,' kte=',kte write(61,*) 'jms=',jms,' jme=',jme,' jts=',jts,' jte=',jte write(61,*) 'ims=',ims,' ime=',ime,' its=',its,' ite=',ite endif if (ics.eq.1) then write(61,*) 'qv timestep=',itimestep write(61,*) ' A1=',A1,' A2=',A2,' A0=',A0 else if (ics.eq.2) then write(61,*) 'ql timestep=',itimestep write(61,*) ' A1=',A1,' A2=',A2,' A0=',A0 else if (ics.eq.3) then write(61,*) 'qr timestep=',itimestep write(61,*) ' A1=',A1,' A2=',A2,' A0=',A0 else if (ics.eq.4) then write(61,*) 'qi timestep=',itimestep write(61,*) ' A1=',A1,' A2=',A2,' A0=',A0 else if (ics.eq.5) then write(61,*) 'qs timestep=',itimestep write(61,*) ' A1=',A1,' A2=',A2,' A0=',A0 else if (ics.eq.6) then write(61,*) 'qg timestep=',itimestep write(61,*) ' A1=',A1,' A2=',A2,' A0=',A0 else write(61,*) 'wrong cloud specieis number' endif endif do k=kts,kte do j=jts,jte do i=its,ite X(i,k,j)=A0*AMAX1(X(i,k,j), 0.0) enddo enddo enddo endif END SUBROUTINE negcor SUBROUTINE consat_s (ihail,itaobraun) !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! c ! Tao, W.-K., and J. Simpson, 1989: Modeling study of a tropical c ! squall-type convective line. J. Atmos. Sci., 46, 177-202. c ! c ! Tao, W.-K., J. Simpson and M. McCumber, 1989: An ice-water c ! saturation adjustment. Mon. Wea. Rev., 117, 231-235. c ! c ! Tao, W.-K., and J. Simpson, 1993: The Goddard Cumulus Ensemble c ! Model. Part I: Model description. Terrestrial, Atmospheric and c ! Oceanic Sciences, 4, 35-72. c ! c ! Tao, W.-K., J. Simpson, D. Baker, S. Braun, M.-D. Chou, B. c ! Ferrier,D. Johnson, A. Khain, S. Lang, B. Lynn, C.-L. Shie, c ! D. Starr, C.-H. Sui, Y. Wang and P. Wetzel, 2003: Microphysics, c ! radiation and surface processes in the Goddard Cumulus Ensemble c ! (GCE) model, A Special Issue on Non-hydrostatic Mesoscale c ! Modeling, Meteorology and Atmospheric Physics, 82, 97-137. c ! c ! Lang, S., W.-K. Tao, R. Cifelli, W. Olson, J. Halverson, S. c ! Rutledge, and J. Simpson, 2007: Improving simulations of c ! convective system from TRMM LBA: Easterly and Westerly regimes. c ! J. Atmos. Sci., 64, 1141-1164. c ! c ! Coded by Tao (1989-2003), modified by S. Lang (2006/07) c ! c ! Implemented into WRF by Roger Shi 2006/2007 c !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! itaobraun=0 ! see Tao and Simpson (1993) ! itaobraun=1 ! see Tao et al. (2003) integer :: itaobraun real :: cn0 !JJS 1/3/2008 vvvvv !JJS the following common blocks have been moved to the top of !JJS module_mp_gsfcgce_driver_instat.F ! ! real, dimension (1:31) :: a1, a2 ! data a1/.7939e-7,.7841e-6,.3369e-5,.4336e-5,.5285e-5,.3728e-5, & ! .1852e-5,.2991e-6,.4248e-6,.7434e-6,.1812e-5,.4394e-5,.9145e-5, & ! .1725e-4,.3348e-4,.1725e-4,.9175e-5,.4412e-5,.2252e-5,.9115e-6, & ! .4876e-6,.3473e-6,.4758e-6,.6306e-6,.8573e-6,.7868e-6,.7192e-6, & ! .6513e-6,.5956e-6,.5333e-6,.4834e-6/ ! data a2/.4006,.4831,.5320,.5307,.5319,.5249,.4888,.3894,.4047, & ! .4318,.4771,.5183,.5463,.5651,.5813,.5655,.5478,.5203,.4906, & ! .4447,.4126,.3960,.4149,.4320,.4506,.4483,.4460,.4433,.4413, & ! .4382,.4361/ !JJS 1/3/2008 ^^^^^ ! ****************************************************************** !JJS al = 2.5e10 cp = 1.004e7 rd1 = 1.e-3 rd2 = 2.2 !JJS cpi=4.*atan(1.) cpi2=cpi*cpi grvt=980. cd1=6.e-1 cd2=4.*grvt/(3.*cd1) tca=2.43e3 dwv=.226 dva=1.718e-4 amw=18.016 ars=8.314e7 scv=2.2904487 t0=273.16 t00=238.16 alv=2.5e10 alf=3.336e9 als=2.8336e10 avc=alv/cp afc=alf/cp asc=als/cp rw=4.615e6 cw=4.187e7 ci=2.093e7 c76=7.66 c358=35.86 c172=17.26939 c409=4098.026 c218=21.87456 c580=5807.695 c610=6.1078e3 c149=1.496286e-5 c879=8.794142 c141=1.4144354e7 !*** DEFINE THE COEFFICIENTS USED IN TERMINAL VELOCITY !*** DEFINE THE DENSITY AND SIZE DISTRIBUTION OF PRECIPITATION !********** HAIL OR GRAUPEL PARAMETERS ********** if(ihail .eq. 1) then roqg=.9 ag=sqrt(cd2*roqg) bg=.5 tng=.002 else roqg=.4 ag=351.2 ! AG=372.3 ! if ice913=1 6/15/02 tao's bg=.37 tng=.04 endif !********** SNOW PARAMETERS ********** !ccshie 6/15/02 tao's ! TNS=1. ! TNS=.08 ! if ice913=1, tao's tns=.16 ! if ice913=0, tao's roqs=.1 ! AS=152.93 as=78.63 ! BS=.25 bs=.11 !********** RAIN PARAMETERS ********** aw=2115. bw=.8 roqr=1. tnw=.08 !***************************************************************** bgh=.5*bg bsh=.5*bs bwh=.5*bw bgq=.25*bg bsq=.25*bs bwq=.25*bw !**********GAMMA FUNCTION CALCULATIONS************* ga3b = gammagce(3.+bw) ga4b = gammagce(4.+bw) ga6b = gammagce(6.+bw) ga5bh = gammagce((5.+bw)/2.) ga3g = gammagce(3.+bg) ga4g = gammagce(4.+bg) ga5gh = gammagce((5.+bg)/2.) ga3d = gammagce(3.+bs) ga4d = gammagce(4.+bs) ga5dh = gammagce((5.+bs)/2.) !CCCCC LIN ET AL., 1983 OR LORD ET AL., 1984 CCCCCCCCCCCCCCCCC ac1=aw !JJS ac2=ag ac3=as !JJS bc1=bw cc1=as dc1=bs zrc=(cpi*roqr*tnw)**0.25 zsc=(cpi*roqs*tns)**0.25 zgc=(cpi*roqg*tng)**0.25 vrc=aw*ga4b/(6.*zrc**bw) vsc=as*ga4d/(6.*zsc**bs) vgc=ag*ga4g/(6.*zgc**bg) ! **************************** ! RN1=1.E-3 rn1=9.4e-15 ! 6/15/02 tao's bnd1=6.e-4 rn2=1.e-3 ! BND2=1.25E-3 ! BND2=1.5E-3 ! if ice913=1 6/15/02 tao's bnd2=2.0e-3 ! if ice913=0 6/15/02 tao's rn3=.25*cpi*tns*cc1*ga3d esw=1. rn4=.25*cpi*esw*tns*cc1*ga3d ! ERI=1. eri=.1 ! 6/17/02 tao's ice913=0 (not 1) rn5=.25*cpi*eri*tnw*ac1*ga3b ! AMI=1./(24.*4.19E-10) ami=1./(24.*6.e-9) ! 6/15/02 tao's rn6=cpi2*eri*tnw*ac1*roqr*ga6b*ami ! ESR=1. ! also if ice913=1 for tao's esr=.5 ! 6/15/02 for ice913=0 tao's rn7=cpi2*esr*tnw*tns*roqs esr=1. rn8=cpi2*esr*tnw*tns*roqr rn9=cpi2*tns*tng*roqs rn10=2.*cpi*tns rn101=.31*ga5dh*sqrt(cc1) rn10a=als*als/rw !JJS rn10b=alv/tca rn10c=ars/(dwv*amw) !JJS rn11=2.*cpi*tns/alf rn11a=cw/alf ! AMI50=1.51e-7 ami50=3.84e-6 ! 6/15/02 tao's ! AMI40=2.41e-8 ami40=3.08e-8 ! 6/15/02 tao's eiw=1. ! UI50=20. ui50=100. ! 6/15/02 tao's ri50=2.*5.e-3 cmn=1.05e-15 rn12=cpi*eiw*ui50*ri50**2 do 10 k=1,31 y1=1.-aa2(k) rn13(k)=aa1(k)*y1/(ami50**y1-ami40**y1) rn12a(k)=rn13(k)/ami50 rn12b(k)=aa1(k)*ami50**aa2(k) rn25a(k)=aa1(k)*cmn**aa2(k) 10 continue egw=1. rn14=.25*cpi*egw*tng*ga3g*ag egi=.1 rn15=.25*cpi*egi*tng*ga3g*ag egi=1. rn15a=.25*cpi*egi*tng*ga3g*ag egr=1. rn16=cpi2*egr*tng*tnw*roqr rn17=2.*cpi*tng rn17a=.31*ga5gh*sqrt(ag) rn17b=cw-ci rn17c=cw apri=.66 bpri=1.e-4 bpri=0.5*bpri ! 6/17/02 tao's rn18=20.*cpi2*bpri*tnw*roqr rn18a=apri rn19=2.*cpi*tng/alf rn19a=.31*ga5gh*sqrt(ag) rn19b=cw/alf ! rnn191=.78 rnn192=.31*ga5gh*sqrt(ac2/dva) ! rn20=2.*cpi*tng rn20a=als*als/rw rn20b=.31*ga5gh*sqrt(ag) bnd3=2.e-3 rn21=1.e3*1.569e-12/0.15 erw=1. rn22=.25*cpi*erw*ac1*tnw*ga3b rn23=2.*cpi*tnw rn23a=.31*ga5bh*sqrt(ac1) rn23b=alv*alv/rw !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc !cc !cc "c0" in routine "consat" (2d), "consatrh" (3d) !cc if ( itaobraun.eq.1 ) --> betah=0.5*beta=-.46*0.5=-0.23; cn0=1.e-6 !cc if ( itaobraun.eq.0 ) --> betah=0.5*beta=-.6*0.5=-0.30; cn0=1.e-8 if (itaobraun .eq. 0) then cn0=1.e-8 beta=-.6 elseif (itaobraun .eq. 1) then cn0=1.e-6 beta=-.46 endif !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! CN0=1.E-6 ! CN0=1.E-8 ! 6/15/02 tao's ! BETA=-.46 ! BETA=-.6 ! 6/15/02 tao's rn25=cn0 rn30a=alv*als*amw/(tca*ars) rn30b=alv/tca rn30c=ars/(dwv*amw) rn31=1.e-17 rn32=4.*51.545e-4 ! rn30=2.*cpi*tng rnn30a=alv*alv*amw/(tca*ars) ! rn33=4.*tns rn331=.65 rn332=.44*sqrt(ac3/dva)*ga5dh ! return END SUBROUTINE consat_s SUBROUTINE saticel_s (dt, ihail, itaobraun, ice2, istatmin, & new_ice_sat, id, & ptwrf, qvwrf, qlwrf, qrwrf, & qiwrf, qswrf, qgwrf, & rho_mks, pi_mks, p0_mks,itimestep, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & ) !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! c ! Tao, W.-K., and J. Simpson, 1989: Modeling study of a tropical c ! squall-type convective line. J. Atmos. Sci., 46, 177-202. c ! c ! Tao, W.-K., J. Simpson and M. McCumber, 1989: An ice-water c ! saturation adjustment. Mon. Wea. Rev., 117, 231-235. c ! c ! Tao, W.-K., and J. Simpson, 1993: The Goddard Cumulus Ensemble c ! Model. Part I: Model description. Terrestrial, Atmospheric and c ! Oceanic Sciences, 4, 35-72. c ! c ! Tao, W.-K., J. Simpson, D. Baker, S. Braun, M.-D. Chou, B. c ! Ferrier,D. Johnson, A. Khain, S. Lang, B. Lynn, C.-L. Shie, c ! D. Starr, C.-H. Sui, Y. Wang and P. Wetzel, 2003: Microphysics, c ! radiation and surface processes in the Goddard Cumulus Ensemble c ! (GCE) model, A Special Issue on Non-hydrostatic Mesoscale c ! Modeling, Meteorology and Atmospheric Physics, 82, 97-137. c ! c ! Lang, S., W.-K. Tao, R. Cifelli, W. Olson, J. Halverson, S. c ! Rutledge, and J. Simpson, 2007: Improving simulations of c ! convective system from TRMM LBA: Easterly and Westerly regimes. c ! J. Atmos. Sci., 64, 1141-1164. c ! c ! Tao, W.-K., J. J. Shi, S. Lang, C. Peters-Lidard, A. Hou, S. c ! Braun, and J. Simpson, 2007: New, improved bulk-microphysical c ! schemes for studying precipitation processes in WRF. Part I: c ! Comparisons with other schemes. to appear on Mon. Wea. Rev. C ! c ! Coded by Tao (1989-2003), modified by S. Lang (2006/07) c ! c ! Implemented into WRF by Roger Shi 2006/2007 c !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! ! COMPUTE ICE PHASE MICROPHYSICS AND SATURATION PROCESSES ! integer, parameter :: nt=2880, nt2=2*nt !cc using scott braun's way for pint, pidep computations integer :: itaobraun,ice2,ihail,new_ice_sat,id,istatmin integer :: itimestep real :: tairccri, cn0, dt !cc !JJS common/bxyz/ n,isec,nran,kt1,kt2 !JJS common/option/ lipps,ijkadv,istatmin,iwater,itoga,imlifting,lin, !JJS 1 irf,iadvh,irfg,ismg,id !JJS common/timestat/ ndt_stat,idq !JJS common/iice/ new_ice_sat !JJS common/bt/ dt,d2t,rijl2,dts,f5,rd1,rd2,bound,al,cp,ra,ck,ce,eps, !JJS 1 psfc,fcor,sec,aminut,rdt !JJS the following common blocks have been moved to the top of !JJS module_mp_gsfcgce_driver_instat.F ! common/bt/ rd1,rd2,al,cp ! ! ! common/bterv/ zrc,zgc,zsc,vrc,vgc,vsc ! common/size/ tnw,tns,tng,roqs,roqg,roqr ! common/cont/ c38,c358,c610,c149,c879,c172,c409,c76,c218,c580,c141 ! common/b3cs/ ag,bg,as,bs,aw,bw,bgh,bgq,bsh,bsq,bwh,bwq ! common/bsnw/ alv,alf,als,t0,t00,avc,afc,asc,rn1,bnd1,rn2,bnd2, & ! rn3,rn4,rn5,rn6,rn7,rn8,rn9,rn10,rn101,rn10a,rn11,rn11a, & ! rn12,rn12a(31),rn12b(31),rn13(31),rn14,rn15,rn15a,rn16,rn17, & ! rn17a,rn17b,rn17c,rn18,rn18a,rn19,rn19a,rn19b,rn20,rn20a,rn20b, & ! bnd3,rn21,rn22,rn23,rn23a,rn23b,rn25,rn25a(31),rn30a,rn30b, & ! rn30c,rn31,beta,rn32 ! common/rsnw1/ rn10b,rn10c,rnn191,rnn192,rn30,rnn30a,rn33,rn331, & ! rn332 !JJS real, dimension (its:ite,jts:jte,kts:kte) :: fv real, dimension (its:ite,jts:jte,kts:kte) :: dpt, dqv real, dimension (its:ite,jts:jte,kts:kte) :: qcl, qrn, & qci, qcs, qcg !JJS 10/16/06 vvvv ! real dpt1(ims:ime,jms:jme,kms:kme) ! real dqv1(ims:ime,jms:jme,kms:kme), ! 1 qcl1(ims:ime,jms:jme,kms:kme) ! real qrn1(ims:ime,jms:jme,kms:kme), ! 1 qci1(ims:ime,jms:jme,kms:kme) ! real qcs1(ims:ime,jms:jme,kms:kme), ! 1 qcg1(ims:ime,jms:jme,kms:kme) !JJS 10/16/06 ^^^^ !JJS real, dimension (ims:ime, kms:kme, jms:jme) :: ptwrf, qvwrf real, dimension (ims:ime, kms:kme, jms:jme) :: qlwrf, qrwrf, & qiwrf, qswrf, qgwrf !JJS 10/16/06 vvvv ! real ptwrfold(ims:ime, kms:kme, jms:jme) ! real qvwrfold(ims:ime, kms:kme, jms:jme), ! 1 qlwrfold(ims:ime, kms:kme, jms:jme) ! real qrwrfold(ims:ime, kms:kme, jms:jme), ! 1 qiwrfold(ims:ime, kms:kme, jms:jme) ! real qswrfold(ims:ime, kms:kme, jms:jme), ! 1 qgwrfold(ims:ime, kms:kme, jms:jme) !JJS 10/16/06 ^^^^ !JJS in MKS real, dimension (ims:ime, kms:kme, jms:jme) :: rho_mks real, dimension (ims:ime, kms:kme, jms:jme) :: pi_mks real, dimension (ims:ime, kms:kme, jms:jme) :: p0_mks !JJS ! real, dimension (its:ite,jts:jte,kts:kte) :: ww1 ! real, dimension (its:ite,jts:jte,kts:kte) :: rsw ! real, dimension (its:ite,jts:jte,kts:kte) :: rlw !JJS COMMON /BADV/ real, dimension (its:ite,jts:jte) :: & vg, zg, & ps, pg, & prn, psn, & pwacs, wgacr, & pidep, pint, & qsi, ssi, & esi, esw, & qsw, pr, & ssw, pihom, & pidw, pimlt, & psaut, qracs, & psaci, psacw, & qsacw, praci, & pmlts, pmltg, & asss, y1, y2 !JJS Y2(its:ite,jts:jte), DDE(NB) !JJS COMMON/BSAT/ real, dimension (its:ite,jts:jte) :: & praut, pracw, & psfw, psfi, & dgacs, dgacw, & dgaci, dgacr, & pgacs, wgacs, & qgacw, wgaci, & qgacr, pgwet, & pgaut, pracs, & psacr, qsacr, & pgfr, psmlt, & pgmlt, psdep, & pgdep, piacr, & y5, scv, & tca, dwv, & egs, y3, & y4, ddb !JJS COMMON/BSAT1/ real, dimension (its:ite,jts:jte) :: & pt, qv, & qc, qr, & qi, qs, & qg, tair, & tairc, rtair, & dep, dd, & dd1, qvs, & dm, rq, & rsub1, col, & cnd, ern, & dlt1, dlt2, & dlt3, dlt4, & zr, vr, & zs, vs, & dbz, pssub, & pgsub, dda !JJS COMMON/B5/ real, dimension (its:ite,jts:jte,kts:kte) :: rho real, dimension (kts:kte) :: & tb, qb, rho1, & ta, qa, ta1, qa1, & coef, z1, z2, z3, & am, am1, ub, vb, & wb, ub1, vb1, rrho, & rrho1, wbx !JJS COMMON/B6/ real, dimension (its:ite,jts:jte,kts:kte) :: p0, pi, f0 real, dimension (kts:kte) :: & fd, fe, & st, sv, & sq, sc, & se, sqa !JJS COMMON/BRH1/ real, dimension (kts:kte) :: & srro, qrro, sqc, sqr, & sqi, sqs, sqg, stqc, & stqr, stqi, stqs, stqg real, dimension (nt) :: & tqc, tqr, tqi, tqs, tqg !JJS common/bls/ y0(nx,ny),ts0new(nx,ny),qss0new(nx,ny) !JJS COMMON/BLS/ real, dimension (its:ite,jts:jte) :: & y0, ts0, qss0 !JJS COMMON/BI/ IT(its:ite,jts:jte), ICS(its:ite,jts:jte,4) integer, dimension (its:ite,jts:jte) :: it integer, dimension (its:ite,jts:jte, 4) :: ics !JJS COMMON/MICRO/ real, dimension (its:ite,kts:kte,jts:jte) :: & physc, physe, physd, & physs, physm, physf !23456789012345678901234567890123456789012345678901234567890123456789012 ! !JJS 1/3/2008 vvvvv !JJS the following common blocks have been moved to the top of !JJS module_mp_gsfcgce_driver.F ! real, dimension (31) :: aa1, aa2 ! data aa1/.7939e-7, .7841e-6, .3369e-5, .4336e-5, .5285e-5, & ! .3728e-5, .1852e-5, .2991e-6, .4248e-6, .7434e-6, & ! .1812e-5, .4394e-5, .9145e-5, .1725e-4, .3348e-4, & ! .1725e-4, .9175e-5, .4412e-5, .2252e-5, .9115e-6, & ! .4876e-6, .3473e-6, .4758e-6, .6306e-6, .8573e-6, & ! .7868e-6, .7192e-6, .6513e-6, .5956e-6, .5333e-6, & ! .4834e-6/ ! data aa2/.4006, .4831, .5320, .5307, .5319, & ! .5249, .4888, .3894, .4047, .4318, & ! .4771, .5183, .5463, .5651, .5813, & ! .5655, .5478, .5203, .4906, .4447, & ! .4126, .3960, .4149, .4320, .4506, & ! .4483, .4460, .4433, .4413, .4382, & ! .4361/ !JJS 1/3/2008 ^^^^^ ! save ! write(6, *) 'in gsfcgce_open_ice2 at itimestep=',itimestep ! write(6, *) 'ims=', ims, ' ime=', ime ! write(6, *) 'jms=', jms, ' jme=', jme ! write(6, *) 'kms=', kms, ' kme=', kme ! write(6, *) 'its=', its, ' ite=', ite ! write(6, *) 'jts=', jts, ' jte=', jte ! write(6, *) 'kts=', kts, ' kte=', kte ! write(6, *) 'ihail=', ihail ! write(6, *) 'itaobraun=',itaobraun ! write(6, *) 'ICE2=', ICE2 ! write(6, *) 'istatmin=',istatmin ! write(6, *) 'new_ice_sat=', new_ice_sat ! write(6, *) 'id=', id ! write(6, *) 'dt=', dt ! endif !JJS convert from mks to cgs, and move from WRF grid to GCE grid do k=kts,kte do j=jts,jte do i=its,ite rho(i,j,k)=rho_mks(i,k,j)*0.001 p0(i,j,k)=p0_mks(i,k,j)*10.0 pi(i,j,k)=pi_mks(i,k,j) dpt(i,j,k)=ptwrf(i,k,j) dqv(i,j,k)=qvwrf(i,k,j) qcl(i,j,k)=qlwrf(i,k,j) qrn(i,j,k)=qrwrf(i,k,j) qci(i,j,k)=qiwrf(i,k,j) qcs(i,j,k)=qswrf(i,k,j) qcg(i,j,k)=qgwrf(i,k,j) !JJS 10/16/06 vvvv ! dpt1(i,j,k)=ptwrfold(i,k,j) ! dqv1(i,j,k)=qvwrfold(i,k,j) ! qcl1(i,j,k)=qlwrfold(i,k,j) ! qrn1(i,j,k)=qrwrfold(i,k,j) ! qci1(i,j,k)=qiwrfold(i,k,j) ! qcs1(i,j,k)=qswrfold(i,k,j) ! qcg1(i,j,k)=qgwrfold(i,k,j) !JJS 10/16/06 ^^^^ enddo !i enddo !j enddo !k if (ice2 .eq. 2) ihail = 0 do k=kts,kte do j=jts,jte do i=its,ite fv(i,j,k)=sqrt(rho(i,j,2)/rho(i,j,k)) enddo !i enddo !j enddo !k !JJS ! ! ****** THREE CLASSES OF ICE-PHASE (LIN ET AL, 1983) ********* !JJS D22T=D2T !JJS IF(IJKADV .EQ. 0) THEN !JJS D2T=D2T !JJS ELSE d2t=dt !JJS ENDIF ! ! itaobraun=0 ! original pint and pidep & see Tao and Simpson 1993 itaobraun=1 ! see Tao et al. (2003) ! if ( itaobraun.eq.0 ) then cn0=1.e-8 !c beta=-.6 elseif ( itaobraun.eq.1 ) then cn0=1.e-6 ! cn0=1.e-8 ! special !c beta=-.46 endif !C TAO 2007 START ! ICE2=2 ! 2ICE with cloud ice and graupel (no snow) - r2ice=1, r2iceg=0. ! ICE2=1 ! 2ice with cloud ice and snow (no graupel) - r2iceg=1, r2ice=0. !c r2ice=1. r2iceg=1. if (ice2 .eq. 1) then r2ice=0. r2iceg=1. endif if (ice2 .eq. 2) then r2ice=1. r2iceg=0. endif !C TAO 2007 END cmin=1.e-19 cmin1=1.e-20 cmin2=1.e-12 ucor=3071.29/tnw**.75 ucos=687.97*roqs**.25/tns**.75 ucog=687.97*roqg**.25/tng**.75 uwet=4.464**.95 rijl2 = 1. / (ide-ids) / (jde-jds) !JJScap $doacross local(j,i) !JJS DO 1 J=1,JMAX !JJS DO 1 I=1,IMAX do j=jts,jte do i=its,ite it(i,j)=1 enddo enddo f2=rd1*d2t f3=rd2*d2t ft=dt/d2t rft=rijl2*ft a0=.5*istatmin*rijl2 rt0=1./(t0-t00) bw3=bw+3. bs3=bs+3. bg3=bg+3. bsh5=2.5+bsh bgh5=2.5+bgh bwh5=2.5+bwh bw6=bw+6. bs6=bs+6. betah=.5*beta r10t=rn10*d2t r11at=rn11a*d2t r19bt=rn19b*d2t r20t=-rn20*d2t r23t=-rn23*d2t r25a=rn25 ! ami50 for use in PINT ami50=3.76e-8 ami100=1.51e-7 ami40=2.41e-8 !C ****************************************************************** !JJS DO 1000 K=2,kles do 1000 k=kts,kte kp=k+1 !JJS tb0=ta1(k) !JJS qb0=qa1(k) tb0=0. qb0=0. do 2000 j=jts,jte do 2000 i=its,ite rp0=3.799052e3/p0(i,j,k) pi0=pi(i,j,k) pir=1./(pi(i,j,k)) pr0=1./p0(i,j,k) r00=rho(i,j,k) r0s=sqrt(rho(i,j,k)) !JJS RR0=RRHO(K) rr0=1./rho(i,j,k) !JJS RRS=SRRO(K) rrs=sqrt(rr0) !JJS RRQ=QRRO(K) rrq=sqrt(rrs) f0(i,j,k)=al/cp/pi(i,j,k) f00=f0(i,j,k) fv0=fv(i,j,k) fvs=sqrt(fv(i,j,k)) zrr=1.e5*zrc*rrq zsr=1.e5*zsc*rrq zgr=1.e5*zgc*rrq cp409=c409*pi0 cv409=c409*avc cp580=c580*pi0 cs580=c580*asc alvr=r00*alv afcp=afc*pir avcp=avc*pir ascp=asc*pir vrcf=vrc*fv0 vscf=vsc*fv0 vgcf=vgc*fv0 vgcr=vgc*rrs dwvp=c879*pr0 r3f=rn3*fv0 r4f=rn4*fv0 r5f=rn5*fv0 r6f=rn6*fv0 r7r=rn7*rr0 r8r=rn8*rr0 r9r=rn9*rr0 r101f=rn101*fvs r10ar=rn10a*r00 r11rt=rn11*rr0*d2t r12r=rn12*r00 r14r=rn14*rrs r14f=rn14*fv0 r15r=rn15*rrs r15ar=rn15a*rrs r15f=rn15*fv0 r15af=rn15a*fv0 r16r=rn16*rr0 r17r=rn17*rr0 r17aq=rn17a*rrq r17as=rn17a*fvs r18r=rn18*rr0 r19rt=rn19*rr0*d2t r19aq=rn19a*rrq r19as=rn19a*fvs r20bq=rn20b*rrq r20bs=rn20b*fvs r22f=rn22*fv0 r23af=rn23a*fvs r23br=rn23b*r00 r25rt=rn25*rr0*d2t r31r=rn31*rr0 r32rt=rn32*d2t*rrs !JJS DO 100 J=3,JLES !JJS DO 100 I=3,ILES pt(i,j)=dpt(i,j,k) qv(i,j)=dqv(i,j,k) qc(i,j)=qcl(i,j,k) qr(i,j)=qrn(i,j,k) qi(i,j)=qci(i,j,k) qs(i,j)=qcs(i,j,k) qg(i,j)=qcg(i,j,k) ! IF (QV(I,J)+QB0 .LE. 0.) QV(I,J)=-QB0 if (qc(i,j) .le. cmin1) qc(i,j)=0.0 if (qr(i,j) .le. cmin1) qr(i,j)=0.0 if (qi(i,j) .le. cmin1) qi(i,j)=0.0 if (qs(i,j) .le. cmin1) qs(i,j)=0.0 if (qg(i,j) .le. cmin1) qg(i,j)=0.0 tair(i,j)=(pt(i,j)+tb0)*pi0 tairc(i,j)=tair(i,j)-t0 zr(i,j)=zrr zs(i,j)=zsr zg(i,j)=zgr vr(i,j)=0.0 vs(i,j)=0.0 vg(i,j)=0.0 ! *** COMPUTE ZR,ZS,ZG,VR,VS,VG ***************************** if (qr(i,j) .gt. cmin1) then dd(i,j)=r00*qr(i,j) y1(i,j)=dd(i,j)**.25 zr(i,j)=zrc/y1(i,j) vr(i,j)=max(vrcf*dd(i,j)**bwq, 0.) endif if (qs(i,j) .gt. cmin1) then dd(i,j)=r00*qs(i,j) y1(i,j)=dd(i,j)**.25 zs(i,j)=zsc/y1(i,j) vs(i,j)=max(vscf*dd(i,j)**bsq, 0.) endif if (qg(i,j) .gt. cmin1) then dd(i,j)=r00*qg(i,j) y1(i,j)=dd(i,j)**.25 zg(i,j)=zgc/y1(i,j) if(ihail .eq. 1) then vg(i,j)=max(vgcr*dd(i,j)**bgq, 0.) else vg(i,j)=max(vgcf*dd(i,j)**bgq, 0.) endif endif if (qr(i,j) .le. cmin2) vr(i,j)=0.0 if (qs(i,j) .le. cmin2) vs(i,j)=0.0 if (qg(i,j) .le. cmin2) vg(i,j)=0.0 ! ****************************************************************** ! *** Y1 : DYNAMIC VISCOSITY OF AIR (U) ! *** DWV : DIFFUSIVITY OF WATER VAPOR IN AIR (PI) ! *** TCA : THERMAL CONDUCTIVITY OF AIR (KA) ! *** Y2 : KINETIC VISCOSITY (V) y1(i,j)=c149*tair(i,j)**1.5/(tair(i,j)+120.) dwv(i,j)=dwvp*tair(i,j)**1.81 tca(i,j)=c141*y1(i,j) scv(i,j)=1./((rr0*y1(i,j))**.1666667*dwv(i,j)**.3333333) !JJS 100 CONTINUE !* 1 * PSAUT : AUTOCONVERSION OF QI TO QS ***1** !* 3 * PSACI : ACCRETION OF QI TO QS ***3** !* 4 * PSACW : ACCRETION OF QC BY QS (RIMING) (QSACW FOR PSMLT) ***4** !* 5 * PRACI : ACCRETION OF QI BY QR ***5** !* 6 * PIACR : ACCRETION OF QR OR QG BY QI ***6** !JJS DO 125 J=3,JLES !JJS DO 125 I=3,ILES psaut(i,j)=0.0 psaci(i,j)=0.0 praci(i,j)=0.0 piacr(i,j)=0.0 psacw(i,j)=0.0 qsacw(i,j)=0.0 dd(i,j)=1./zs(i,j)**bs3 if (tair(i,j).lt.t0) then esi(i,j)=exp(.025*tairc(i,j)) psaut(i,j)=r2iceg*max(rn1*esi(i,j)*(qi(i,j)-bnd1) ,0.0) psaci(i,j)=r2iceg*r3f*esi(i,j)*qi(i,j)*dd(i,j) !JJS 3/30/06 ! to cut water to snow accretion by half ! PSACW(I,J)=R4F*QC(I,J)*DD(I,J) psacw(i,j)=r2iceg*0.5*r4f*qc(i,j)*dd(i,j) !JJS 3/30/06 praci(i,j)=r2iceg*r5f*qi(i,j)/zr(i,j)**bw3 piacr(i,j)=r2iceg*r6f*qi(i,j)*(zr(i,j)**(-bw6)) !JJS PIACR(I,J)=R6F*QI(I,J)/ZR(I,J)**BW6 else qsacw(i,j)=r2iceg*r4f*qc(i,j)*dd(i,j) endif !* 21 * PRAUT AUTOCONVERSION OF QC TO QR **21** !* 22 * PRACW : ACCRETION OF QC BY QR **22** pracw(i,j)=r22f*qc(i,j)/zr(i,j)**bw3 praut(i,j)=0.0 y1(i,j)=qc(i,j)-bnd3 if (y1(i,j).gt.0.0) then praut(i,j)=r00*y1(i,j)*y1(i,j)/(1.2e-4+rn21/y1(i,j)) endif !* 12 * PSFW : BERGERON PROCESSES FOR QS (KOENING, 1971) **12** !* 13 * PSFI : BERGERON PROCESSES FOR QS **13** psfw(i,j)=0.0 psfi(i,j)=0.0 pidep(i,j)=0.0 if(tair(i,j).lt.t0.and.qi(i,j).gt.cmin) then y1(i,j)=max( min(tairc(i,j), -1.), -31.) it(i,j)=int(abs(y1(i,j))) y1(i,j)=rn12a(it(i,j)) y2(i,j)=rn12b(it(i,j)) !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc psfw(i,j)=r2iceg* & max(d2t*y1(i,j)*(y2(i,j)+r12r*qc(i,j))*qi(i,j),0.0) rtair(i,j)=1./(tair(i,j)-c76) y2(i,j)=exp(c218-c580*rtair(i,j)) qsi(i,j)=rp0*y2(i,j) esi(i,j)=c610*y2(i,j) ssi(i,j)=(qv(i,j)+qb0)/qsi(i,j)-1. r_nci=min(1.e-6*exp(-.46*tairc(i,j)),1.) ! R_NCI=min(1.e-8*EXP(-.6*TAIRC(I,J)),1.) ! use Tao's dm(i,j)=max( (qv(i,j)+qb0-qsi(i,j)), 0.) rsub1(i,j)=cs580*qsi(i,j)*rtair(i,j)*rtair(i,j) y3(i,j)=1./tair(i,j) dd(i,j)=y3(i,j)*(rn30a*y3(i,j)-rn30b)+rn30c*tair(i,j)/esi(i,j) y1(i,j)=206.18*ssi(i,j)/dd(i,j) pidep(i,j)=y1(i,j)*sqrt(r_nci*qi(i,j)/r00) dep(i,j)=dm(i,j)/(1.+rsub1(i,j))/d2t if(dm(i,j).gt.cmin2) then a2=1. if(pidep(i,j).gt.dep(i,j).and.pidep(i,j).gt.cmin2) then a2=dep(i,j)/pidep(i,j) pidep(i,j)=dep(i,j) endif psfi(i,j)=r2iceg*a2*.5*qi(i,j)*y1(i,j)/(sqrt(ami100) & -sqrt(ami40)) elseif(dm(i,j).lt.-cmin2) then ! ! SUBLIMATION TERMS USED ONLY WHEN SATURATION ADJUSTMENT FOR ICE ! IS TURNED OFF ! pidep(i,j)=0. psfi(i,j)=0. else pidep(i,j)=0. psfi(i,j)=0. endif endif !TTT***** QG=QG+MIN(PGDRY,PGWET) !* 9 * PGACS : ACCRETION OF QS BY QG (DGACS,WGACS: DRY AND WET) ***9** !* 14 * DGACW : ACCRETION OF QC BY QG (QGACW FOR PGMLT) **14** !* 16 * DGACR : ACCRETION OF QR TO QG (QGACR FOR PGMLT) **16** if(qc(i,j)+qr(i,j).lt.1.e-4) then ee1=.01 else ee1=1. endif ee2=0.09 egs(i,j)=ee1*exp(ee2*tairc(i,j)) ! EGS(I,J)=0.1 ! 6/15/02 tao's if (tair(i,j).ge.t0) egs(i,j)=1.0 y1(i,j)=abs(vg(i,j)-vs(i,j)) y2(i,j)=zs(i,j)*zg(i,j) y3(i,j)=5./y2(i,j) y4(i,j)=.08*y3(i,j)*y3(i,j) y5(i,j)=.05*y3(i,j)*y4(i,j) dd(i,j)=y1(i,j)*(y3(i,j)/zs(i,j)**5+y4(i,j)/zs(i,j)**3 & +y5(i,j)/zs(i,j)) pgacs(i,j)=r2ice*r2iceg*r9r*egs(i,j)*dd(i,j) !JJS 1/3/06 from Steve and Chunglin if (ihail.eq.1) then dgacs(i,j)=pgacs(i,j) else dgacs(i,j)=0. endif !JJS 1/3/06 from Steve and Chunglin wgacs(i,j)=r2ice*r2iceg*r9r*dd(i,j) ! WGACS(I,J)=0. ! 6/15/02 tao's y1(i,j)=1./zg(i,j)**bg3 if(ihail .eq. 1) then dgacw(i,j)=r2ice*max(r14r*qc(i,j)*y1(i,j), 0.0) else dgacw(i,j)=r2ice*max(r14f*qc(i,j)*y1(i,j), 0.0) endif qgacw(i,j)=dgacw(i,j) y1(i,j)=abs(vg(i,j)-vr(i,j)) y2(i,j)=zr(i,j)*zg(i,j) y3(i,j)=5./y2(i,j) y4(i,j)=.08*y3(i,j)*y3(i,j) y5(i,j)=.05*y3(i,j)*y4(i,j) dd(i,j)=r16r*y1(i,j)*(y3(i,j)/zr(i,j)**5+y4(i,j)/zr(i,j)**3 & +y5(i,j)/zr(i,j)) dgacr(i,j)=r2ice*max(dd(i,j), 0.0) qgacr(i,j)=dgacr(i,j) if (tair(i,j).ge.t0) then dgacs(i,j)=0.0 wgacs(i,j)=0.0 dgacw(i,j)=0.0 dgacr(i,j)=0.0 else pgacs(i,j)=0.0 qgacw(i,j)=0.0 qgacr(i,j)=0.0 endif !*******PGDRY : DGACW+DGACI+DGACR+DGACS ****** !* 15 * DGACI : ACCRETION OF QI BY QG (WGACI FOR WET GROWTH) **15** !* 17 * PGWET : WET GROWTH OF QG **17** dgaci(i,j)=0.0 wgaci(i,j)=0.0 pgwet(i,j)=0.0 if (tair(i,j).lt.t0) then y1(i,j)=qi(i,j)/zg(i,j)**bg3 if (ihail.eq.1) then dgaci(i,j)=r2ice*r15r*y1(i,j) wgaci(i,j)=r2ice*r15ar*y1(i,j) ! WGACI(I,J)=0. ! 6/15/02 tao's else !JJS DGACI(I,J)=r2ice*R15F*Y1(I,J) dgaci(i,j)=0. wgaci(i,j)=r2ice*r15af*y1(i,j) ! WGACI(I,J)=0. ! 6/15/02 tao's endif ! if (tairc(i,j).ge.-50.) then if (alf+rn17c*tairc(i,j) .eq. 0.) then write(91,*) itimestep, i,j,k, alf, rn17c, tairc(i,j) endif y1(i,j)=1./(alf+rn17c*tairc(i,j)) if (ihail.eq.1) then y3(i,j)=.78/zg(i,j)**2+r17aq*scv(i,j)/zg(i,j)**bgh5 else y3(i,j)=.78/zg(i,j)**2+r17as*scv(i,j)/zg(i,j)**bgh5 endif y4(i,j)=alvr*dwv(i,j)*(rp0-(qv(i,j)+qb0)) & -tca(i,j)*tairc(i,j) dd(i,j)=y1(i,j)*(r17r*y4(i,j)*y3(i,j) & +(wgaci(i,j)+wgacs(i,j))*(alf+rn17b*tairc(i,j))) pgwet(i,j)=r2ice*max(dd(i,j), 0.0) endif endif !JJS 125 CONTINUE !******** HANDLING THE NEGATIVE CLOUD WATER (QC) ****************** !******** HANDLING THE NEGATIVE CLOUD ICE (QI) ****************** !JJS DO 150 J=3,JLES !JJS DO 150 I=3,ILES y1(i,j)=qc(i,j)/d2t psacw(i,j)=min(y1(i,j), psacw(i,j)) praut(i,j)=min(y1(i,j), praut(i,j)) pracw(i,j)=min(y1(i,j), pracw(i,j)) psfw(i,j)= min(y1(i,j), psfw(i,j)) dgacw(i,j)=min(y1(i,j), dgacw(i,j)) qsacw(i,j)=min(y1(i,j), qsacw(i,j)) qgacw(i,j)=min(y1(i,j), qgacw(i,j)) y1(i,j)=(psacw(i,j)+praut(i,j)+pracw(i,j)+psfw(i,j) & +dgacw(i,j)+qsacw(i,j)+qgacw(i,j))*d2t qc(i,j)=qc(i,j)-y1(i,j) if (qc(i,j) .lt. 0.0) then a1=1. if (y1(i,j) .ne. 0.0) a1=qc(i,j)/y1(i,j)+1. psacw(i,j)=psacw(i,j)*a1 praut(i,j)=praut(i,j)*a1 pracw(i,j)=pracw(i,j)*a1 psfw(i,j)=psfw(i,j)*a1 dgacw(i,j)=dgacw(i,j)*a1 qsacw(i,j)=qsacw(i,j)*a1 qgacw(i,j)=qgacw(i,j)*a1 qc(i,j)=0.0 endif !c ! !******** SHED PROCESS (WGACR=PGWET-DGACW-WGACI-WGACS) !c wgacr(i,j)=pgwet(i,j)-dgacw(i,j)-wgaci(i,j)-wgacs(i,j) y2(i,j)=dgacw(i,j)+dgaci(i,j)+dgacr(i,j)+dgacs(i,j) if (pgwet(i,j).ge.y2(i,j)) then wgacr(i,j)=0.0 wgaci(i,j)=0.0 wgacs(i,j)=0.0 else dgacr(i,j)=0.0 dgaci(i,j)=0.0 dgacs(i,j)=0.0 endif !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc !c y1(i,j)=qi(i,j)/d2t psaut(i,j)=min(y1(i,j), psaut(i,j)) psaci(i,j)=min(y1(i,j), psaci(i,j)) praci(i,j)=min(y1(i,j), praci(i,j)) psfi(i,j)= min(y1(i,j), psfi(i,j)) dgaci(i,j)=min(y1(i,j), dgaci(i,j)) wgaci(i,j)=min(y1(i,j), wgaci(i,j)) ! y2(i,j)=(psaut(i,j)+psaci(i,j)+praci(i,j)+psfi(i,j) & +dgaci(i,j)+wgaci(i,j))*d2t qi(i,j)=qi(i,j)-y2(i,j)+pidep(i,j)*d2t if (qi(i,j).lt.0.0) then a2=1. if (y2(i,j) .ne. 0.0) a2=qi(i,j)/y2(i,j)+1. psaut(i,j)=psaut(i,j)*a2 psaci(i,j)=psaci(i,j)*a2 praci(i,j)=praci(i,j)*a2 psfi(i,j)=psfi(i,j)*a2 dgaci(i,j)=dgaci(i,j)*a2 wgaci(i,j)=wgaci(i,j)*a2 qi(i,j)=0.0 endif ! dlt3(i,j)=0.0 dlt2(i,j)=0.0 ! ! DLT4(I,J)=1.0 ! if(qc(i,j) .gt. 5.e-4) dlt4(i,j)=0.0 ! if(qs(i,j) .le. 1.e-4) dlt4(i,j)=1.0 ! ! IF (TAIR(I,J).ge.T0) THEN ! DLT4(I,J)=0.0 ! ENDIF if (tair(i,j).lt.t0) then if (qr(i,j).lt.1.e-4) then dlt3(i,j)=1.0 dlt2(i,j)=1.0 endif if (qs(i,j).ge.1.e-4) then dlt2(i,j)=0.0 endif endif if (ice2 .eq. 1) then dlt3(i,j)=1.0 dlt2(i,j)=1.0 endif !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc pr(i,j)=(qsacw(i,j)+praut(i,j)+pracw(i,j)+qgacw(i,j))*d2t ps(i,j)=(psaut(i,j)+psaci(i,j)+psacw(i,j)+psfw(i,j) & +psfi(i,j)+dlt3(i,j)*praci(i,j))*d2t ! PS(I,J)=(PSAUT(I,J)+PSACI(I,J)+dlt4(i,j)*PSACW(I,J) ! 1 +PSFW(I,J)+PSFI(I,J)+DLT3(I,J)*PRACI(I,J))*D2T pg(i,j)=((1.-dlt3(i,j))*praci(i,j)+dgaci(i,j)+wgaci(i,j) & +dgacw(i,j))*d2t ! PG(I,J)=((1.-DLT3(I,J))*PRACI(I,J)+DGACI(I,J)+WGACI(I,J) ! 1 +DGACW(I,J)+(1.-dlt4(i,j))*PSACW(I,J))*D2T !JJS 150 CONTINUE !* 7 * PRACS : ACCRETION OF QS BY QR ***7** !* 8 * PSACR : ACCRETION OF QR BY QS (QSACR FOR PSMLT) ***8** !JJS DO 175 J=3,JLES !JJS DO 175 I=3,ILES y1(i,j)=abs(vr(i,j)-vs(i,j)) y2(i,j)=zr(i,j)*zs(i,j) y3(i,j)=5./y2(i,j) y4(i,j)=.08*y3(i,j)*y3(i,j) y5(i,j)=.05*y3(i,j)*y4(i,j) pracs(i,j)=r2ice*r2iceg*r7r*y1(i,j)*(y3(i,j)/zs(i,j)**5 & +y4(i,j)/zs(i,j)**3+y5(i,j)/zs(i,j)) psacr(i,j)=r2iceg*r8r*y1(i,j)*(y3(i,j)/zr(i,j)**5 & +y4(i,j)/zr(i,j)**3+y5(i,j)/zr(i,j)) qsacr(i,j)=psacr(i,j) if (tair(i,j).ge.t0) then pracs(i,j)=0.0 psacr(i,j)=0.0 else qsacr(i,j)=0.0 endif !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc !* 2 * PGAUT : AUTOCONVERSION OF QS TO QG ***2** !* 18 * PGFR : FREEZING OF QR TO QG **18** pgaut(i,j)=0.0 pgfr(i,j)=0.0 if (tair(i,j) .lt. t0) then ! Y1(I,J)=EXP(.09*TAIRC(I,J)) ! PGAUT(I,J)=r2iceg*max(RN2*Y1(I,J)*(QS(I,J)-BND2), 0.0) ! IF(IHAIL.EQ.1) PGAUT(I,J)=max(RN2*Y1(I,J)*(QS(I,J)-BND2),0.0) y2(i,j)=exp(rn18a*(t0-tair(i,j))) !JJS PGFR(I,J)=r2ice*max(R18R*(Y2(I,J)-1.)/ZR(I,J)**7., 0.0) ! pgfr(i,j)=r2ice*max(r18r*(y2(i,j)-1.)* & ! (zr(i,j)**(-7.)), 0.0) ! modify to prevent underflow on some computers (JD) temp = 1./zr(i,j) temp = temp*temp*temp*temp*temp*temp*temp pgfr(i,j)=r2ice*max(r18r*(y2(i,j)-1.)* & temp, 0.0) endif !JJS 175 CONTINUE !******** HANDLING THE NEGATIVE RAIN WATER (QR) ******************* !******** HANDLING THE NEGATIVE SNOW (QS) ******************* !JJS DO 200 J=3,JLES !JJS DO 200 I=3,ILES y1(i,j)=qr(i,j)/d2t y2(i,j)=-qg(i,j)/d2t piacr(i,j)=min(y1(i,j), piacr(i,j)) dgacr(i,j)=min(y1(i,j), dgacr(i,j)) wgacr(i,j)=min(y1(i,j), wgacr(i,j)) wgacr(i,j)=max(y2(i,j), wgacr(i,j)) psacr(i,j)=min(y1(i,j), psacr(i,j)) pgfr(i,j)= min(y1(i,j), pgfr(i,j)) del=0. if(wgacr(i,j) .lt. 0.) del=1. y1(i,j)=(piacr(i,j)+dgacr(i,j)+(1.-del)*wgacr(i,j) & +psacr(i,j)+pgfr(i,j))*d2t qr(i,j)=qr(i,j)+pr(i,j)-y1(i,j)-del*wgacr(i,j)*d2t if (qr(i,j) .lt. 0.0) then a1=1. if(y1(i,j) .ne. 0.) a1=qr(i,j)/y1(i,j)+1. piacr(i,j)=piacr(i,j)*a1 dgacr(i,j)=dgacr(i,j)*a1 if (wgacr(i,j).gt.0.) wgacr(i,j)=wgacr(i,j)*a1 pgfr(i,j)=pgfr(i,j)*a1 psacr(i,j)=psacr(i,j)*a1 qr(i,j)=0.0 endif !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc prn(i,j)=d2t*((1.-dlt3(i,j))*piacr(i,j)+dgacr(i,j) & +wgacr(i,j)+(1.-dlt2(i,j))*psacr(i,j)+pgfr(i,j)) ps(i,j)=ps(i,j)+d2t*(dlt3(i,j)*piacr(i,j) & +dlt2(i,j)*psacr(i,j)) pracs(i,j)=(1.-dlt2(i,j))*pracs(i,j) y1(i,j)=qs(i,j)/d2t pgacs(i,j)=min(y1(i,j), pgacs(i,j)) dgacs(i,j)=min(y1(i,j), dgacs(i,j)) wgacs(i,j)=min(y1(i,j), wgacs(i,j)) pgaut(i,j)=min(y1(i,j), pgaut(i,j)) pracs(i,j)=min(y1(i,j), pracs(i,j)) psn(i,j)=d2t*(pgacs(i,j)+dgacs(i,j)+wgacs(i,j) & +pgaut(i,j)+pracs(i,j)) qs(i,j)=qs(i,j)+ps(i,j)-psn(i,j) if (qs(i,j).lt.0.0) then a2=1. if (psn(i,j) .ne. 0.0) a2=qs(i,j)/psn(i,j)+1. pgacs(i,j)=pgacs(i,j)*a2 dgacs(i,j)=dgacs(i,j)*a2 wgacs(i,j)=wgacs(i,j)*a2 pgaut(i,j)=pgaut(i,j)*a2 pracs(i,j)=pracs(i,j)*a2 psn(i,j)=psn(i,j)*a2 qs(i,j)=0.0 endif ! !C PSN(I,J)=D2T*(PGACS(I,J)+DGACS(I,J)+WGACS(I,J) !c +PGAUT(I,J)+PRACS(I,J)) y2(i,j)=d2t*(psacw(i,j)+psfw(i,j)+dgacw(i,j)+piacr(i,j) & +dgacr(i,j)+wgacr(i,j)+psacr(i,j)+pgfr(i,j)) pt(i,j)=pt(i,j)+afcp*y2(i,j) qg(i,j)=qg(i,j)+pg(i,j)+prn(i,j)+psn(i,j) !JJS 200 CONTINUE !* 11 * PSMLT : MELTING OF QS **11** !* 19 * PGMLT : MELTING OF QG TO QR **19** !JJS DO 225 J=3,JLES !JJS DO 225 I=3,ILES psmlt(i,j)=0.0 pgmlt(i,j)=0.0 tair(i,j)=(pt(i,j)+tb0)*pi0 if (tair(i,j).ge.t0) then tairc(i,j)=tair(i,j)-t0 y1(i,j)=tca(i,j)*tairc(i,j)-alvr*dwv(i,j) & *(rp0-(qv(i,j)+qb0)) y2(i,j)=.78/zs(i,j)**2+r101f*scv(i,j)/zs(i,j)**bsh5 dd(i,j)=r11rt*y1(i,j)*y2(i,j)+r11at*tairc(i,j) & *(qsacw(i,j)+qsacr(i,j)) psmlt(i,j)=r2iceg*max(0.0, min(dd(i,j), qs(i,j))) if(ihail.eq.1) then y3(i,j)=.78/zg(i,j)**2+r19aq*scv(i,j)/zg(i,j)**bgh5 else y3(i,j)=.78/zg(i,j)**2+r19as*scv(i,j)/zg(i,j)**bgh5 endif dd1(i,j)=r19rt*y1(i,j)*y3(i,j)+r19bt*tairc(i,j) & *(qgacw(i,j)+qgacr(i,j)) pgmlt(i,j)=r2ice*max(0.0, min(dd1(i,j), qg(i,j))) pt(i,j)=pt(i,j)-afcp*(psmlt(i,j)+pgmlt(i,j)) qr(i,j)=qr(i,j)+psmlt(i,j)+pgmlt(i,j) qs(i,j)=qs(i,j)-psmlt(i,j) qg(i,j)=qg(i,j)-pgmlt(i,j) endif !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc !* 24 * PIHOM : HOMOGENEOUS FREEZING OF QC TO QI (T < T00) **24** !* 25 * PIDW : DEPOSITION GROWTH OF QC TO QI ( T0 < T <= T00) **25** !* 26 * PIMLT : MELTING OF QI TO QC (T >= T0) **26** if (qc(i,j).le.cmin1) qc(i,j)=0.0 if (qi(i,j).le.cmin1) qi(i,j)=0.0 tair(i,j)=(pt(i,j)+tb0)*pi0 if(tair(i,j).le.t00) then pihom(i,j)=qc(i,j) else pihom(i,j)=0.0 endif if(tair(i,j).ge.t0) then pimlt(i,j)=qi(i,j) else pimlt(i,j)=0.0 endif pidw(i,j)=0.0 if (tair(i,j).lt.t0 .and. tair(i,j).gt.t00) then tairc(i,j)=tair(i,j)-t0 y1(i,j)=max( min(tairc(i,j), -1.), -31.) it(i,j)=int(abs(y1(i,j))) y2(i,j)=aa1(it(i,j)) y3(i,j)=aa2(it(i,j)) y4(i,j)=exp(abs(beta*tairc(i,j))) y5(i,j)=(r00*qi(i,j)/(r25a*y4(i,j)))**y3(i,j) pidw(i,j)=min(r25rt*y2(i,j)*y4(i,j)*y5(i,j), qc(i,j)) endif y1(i,j)=pihom(i,j)-pimlt(i,j)+pidw(i,j) pt(i,j)=pt(i,j)+afcp*y1(i,j)+ascp*(pidep(i,j))*d2t qv(i,j)=qv(i,j)-(pidep(i,j))*d2t qc(i,j)=qc(i,j)-y1(i,j) qi(i,j)=qi(i,j)+y1(i,j) !* 31 * PINT : INITIATION OF QI **31** !* 32 * PIDEP : DEPOSITION OF QI **32** ! ! CALCULATION OF PINT USES DIFFERENT VALUES OF THE INTERCEPT AND SLOPE FOR ! THE FLETCHER EQUATION. ALSO, ONLY INITIATE MORE ICE IF THE NEW NUMBER ! CONCENTRATION EXCEEDS THAT ALREADY PRESENT. !* 31 * pint : initiation of qi **31** !* 32 * pidep : deposition of qi **32** pint(i,j)=0.0 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if ( itaobraun.eq.1 ) then tair(i,j)=(pt(i,j)+tb0)*pi0 if (tair(i,j) .lt. t0) then ! if (qi(i,j) .le. cmin) qi(i,j)=0. if (qi(i,j) .le. cmin2) qi(i,j)=0. tairc(i,j)=tair(i,j)-t0 rtair(i,j)=1./(tair(i,j)-c76) y2(i,j)=exp(c218-c580*rtair(i,j)) qsi(i,j)=rp0*y2(i,j) esi(i,j)=c610*y2(i,j) ssi(i,j)=(qv(i,j)+qb0)/qsi(i,j)-1. ami50=3.76e-8 !ccif ( itaobraun.eq.1 ) --> betah=0.5*beta=-.46*0.5=-0.23; cn0=1.e-6 !ccif ( itaobraun.eq.0 ) --> betah=0.5*beta=-.6*0.5=-0.30; cn0=1.e-8 y1(i,j)=1./tair(i,j) !cc insert a restriction on ice collection that ice collection !cc should be stopped at -30 c (with cn0=1.e-6, beta=-.46) tairccri=tairc(i,j) ! in degree c if(tairccri.le.-30.) tairccri=-30. ! y2(i,j)=exp(betah*tairc(i,j)) y2(i,j)=exp(betah*tairccri) y3(i,j)=sqrt(qi(i,j)) dd(i,j)=y1(i,j)*(rn10a*y1(i,j)-rn10b)+rn10c*tair(i,j) & /esi(i,j) pidep(i,j)=max(r32rt*ssi(i,j)*y2(i,j)*y3(i,j)/dd(i,j), 0.e0) r_nci=min(cn0*exp(beta*tairc(i,j)),1.) ! r_nci=min(1.e-6*exp(-.46*tairc(i,j)),1.) dd(i,j)=max(1.e-9*r_nci/r00-qi(i,j)*1.e-9/ami50, 0.) dm(i,j)=max( (qv(i,j)+qb0-qsi(i,j)), 0.0) rsub1(i,j)=cs580*qsi(i,j)*rtair(i,j)*rtair(i,j) dep(i,j)=dm(i,j)/(1.+rsub1(i,j)) pint(i,j)=max(min(dd(i,j), dm(i,j)), 0.) ! pint(i,j)=min(pint(i,j), dep(i,j)) pint(i,j)=min(pint(i,j)+pidep(i,j), dep(i,j)) ! if (pint(i,j) .le. cmin) pint(i,j)=0. if (pint(i,j) .le. cmin2) pint(i,j)=0. pt(i,j)=pt(i,j)+ascp*pint(i,j) qv(i,j)=qv(i,j)-pint(i,j) qi(i,j)=qi(i,j)+pint(i,j) endif endif ! if ( itaobraun.eq.1 ) !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if ( itaobraun.eq.0 ) then tair(i,j)=(pt(i,j)+tb0)*pi0 if (tair(i,j) .lt. t0) then if (qi(i,j) .le. cmin1) qi(i,j)=0. tairc(i,j)=tair(i,j)-t0 dd(i,j)=r31r*exp(beta*tairc(i,j)) rtair(i,j)=1./(tair(i,j)-c76) y2(i,j)=exp(c218-c580*rtair(i,j)) qsi(i,j)=rp0*y2(i,j) esi(i,j)=c610*y2(i,j) ssi(i,j)=(qv(i,j)+qb0)/qsi(i,j)-1. dm(i,j)=max( (qv(i,j)+qb0-qsi(i,j)), 0.) rsub1(i,j)=cs580*qsi(i,j)*rtair(i,j)*rtair(i,j) dep(i,j)=dm(i,j)/(1.+rsub1(i,j)) pint(i,j)=max(min(dd(i,j), dm(i,j)), 0.) y1(i,j)=1./tair(i,j) y2(i,j)=exp(betah*tairc(i,j)) y3(i,j)=sqrt(qi(i,j)) dd(i,j)=y1(i,j)*(rn10a*y1(i,j)-rn10b) & +rn10c*tair(i,j)/esi(i,j) pidep(i,j)=max(r32rt*ssi(i,j)*y2(i,j)*y3(i,j)/dd(i,j), 0.) pint(i,j)=pint(i,j)+pidep(i,j) pint(i,j)=min(pint(i,j),dep(i,j)) !c if (pint(i,j) .le. cmin2) pint(i,j)=0. pt(i,j)=pt(i,j)+ascp*pint(i,j) qv(i,j)=qv(i,j)-pint(i,j) qi(i,j)=qi(i,j)+pint(i,j) endif endif ! if ( itaobraun.eq.0 ) !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc !JJS 225 CONTINUE !***** TAO ET AL (1989) SATURATION TECHNIQUE *********************** if (new_ice_sat .eq. 0) then !JJS DO 250 J=3,JLES !JJS DO 250 I=3,ILES tair(i,j)=(pt(i,j)+tb0)*pi0 cnd(i,j)=rt0*(tair(i,j)-t00) dep(i,j)=rt0*(t0-tair(i,j)) y1(i,j)=1./(tair(i,j)-c358) y2(i,j)=1./(tair(i,j)-c76) qsw(i,j)=rp0*exp(c172-c409*y1(i,j)) qsi(i,j)=rp0*exp(c218-c580*y2(i,j)) dd(i,j)=cp409*y1(i,j)*y1(i,j) dd1(i,j)=cp580*y2(i,j)*y2(i,j) if (qc(i,j).le.cmin) qc(i,j)=cmin if (qi(i,j).le.cmin) qi(i,j)=cmin if (tair(i,j).ge.t0) then dep(i,j)=0.0 cnd(i,j)=1. qi(i,j)=0.0 endif if (tair(i,j).lt.t00) then cnd(i,j)=0.0 dep(i,j)=1. qc(i,j)=0.0 endif y5(i,j)=avcp*cnd(i,j)+ascp*dep(i,j) ! if (qc(i,j) .ge. cmin .or. qi(i,j) .ge. cmin) then y1(i,j)=qc(i,j)*qsw(i,j)/(qc(i,j)+qi(i,j)) y2(i,j)=qi(i,j)*qsi(i,j)/(qc(i,j)+qi(i,j)) y4(i,j)=dd(i,j)*y1(i,j)+dd1(i,j)*y2(i,j) qvs(i,j)=y1(i,j)+y2(i,j) rsub1(i,j)=(qv(i,j)+qb0-qvs(i,j))/(1.+y4(i,j)*y5(i,j)) cnd(i,j)=cnd(i,j)*rsub1(i,j) dep(i,j)=dep(i,j)*rsub1(i,j) if (qc(i,j).le.cmin) qc(i,j)=0. if (qi(i,j).le.cmin) qi(i,j)=0. !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc !c ****** condensation or evaporation of qc ****** cnd(i,j)=max(-qc(i,j),cnd(i,j)) !c ****** deposition or sublimation of qi ****** dep(i,j)=max(-qi(i,j),dep(i,j)) pt(i,j)=pt(i,j)+avcp*cnd(i,j)+ascp*dep(i,j) qv(i,j)=qv(i,j)-cnd(i,j)-dep(i,j) qc(i,j)=qc(i,j)+cnd(i,j) qi(i,j)=qi(i,j)+dep(i,j) !JJS 250 continue endif if (new_ice_sat .eq. 1) then !JJS DO J=3,JLES !JJS DO I=3,ILES tair(i,j)=(pt(i,j)+tb0)*pi0 cnd(i,j)=rt0*(tair(i,j)-t00) dep(i,j)=rt0*(t0-tair(i,j)) y1(i,j)=1./(tair(i,j)-c358) y2(i,j)=1./(tair(i,j)-c76) qsw(i,j)=rp0*exp(c172-c409*y1(i,j)) qsi(i,j)=rp0*exp(c218-c580*y2(i,j)) dd(i,j)=cp409*y1(i,j)*y1(i,j) dd1(i,j)=cp580*y2(i,j)*y2(i,j) y5(i,j)=avcp*cnd(i,j)+ascp*dep(i,j) y1(i,j)=rt0*(tair(i,j)-t00)*qsw(i,j) y2(i,j)=rt0*(t0-tair(i,j))*qsi(i,j) ! IF (QC(I,J).LE.CMIN) QC(I,J)=CMIN ! IF (QI(I,J).LE.CMIN) QI(I,J)=CMIN if (tair(i,j).ge.t0) then ! QI(I,J)=0.0 dep(i,j)=0.0 cnd(i,j)=1. y2(i,j)=0. y1(i,j)=qsw(i,j) endif if (tair(i,j).lt.t00) then cnd(i,j)=0.0 dep(i,j)=1. y2(i,j)=qsi(i,j) y1(i,j)=0. ! QC(I,J)=0.0 endif ! Y1(I,J)=QC(I,J)*QSW(I,J)/(QC(I,J)+QI(I,J)) ! Y2(I,J)=QI(I,J)*QSI(I,J)/(QC(I,J)+QI(I,J)) y4(i,j)=dd(i,j)*y1(i,j)+dd1(i,j)*y2(i,j) qvs(i,j)=y1(i,j)+y2(i,j) rsub1(i,j)=(qv(i,j)+qb0-qvs(i,j))/(1.+y4(i,j)*y5(i,j)) cnd(i,j)=cnd(i,j)*rsub1(i,j) dep(i,j)=dep(i,j)*rsub1(i,j) ! IF (QC(I,J).LE.CMIN) QC(I,J)=0. ! IF (QI(I,J).LE.CMIN) QI(I,J)=0. !C ****** CONDENSATION OR EVAPORATION OF QC ****** cnd(i,j)=max(-qc(i,j),cnd(i,j)) !C ****** DEPOSITION OR SUBLIMATION OF QI ****** dep(i,j)=max(-qi(i,j),dep(i,j)) pt(i,j)=pt(i,j)+avcp*cnd(i,j)+ascp*dep(i,j) qv(i,j)=qv(i,j)-cnd(i,j)-dep(i,j) qc(i,j)=qc(i,j)+cnd(i,j) qi(i,j)=qi(i,j)+dep(i,j) !JJS ENDDO !JJS ENDDO endif !c ! if (new_ice_sat .eq. 2) then !JJS do j=3,jles !JJS do i=3,iles dep(i,j)=0.0 cnd(i,j)=0.0 tair(i,j)=(pt(i,j)+tb0)*pi0 if (tair(i,j) .ge. 253.16) then y1(i,j)=1./(tair(i,j)-c358) qsw(i,j)=rp0*exp(c172-c409*y1(i,j)) dd(i,j)=cp409*y1(i,j)*y1(i,j) dm(i,j)=qv(i,j)+qb0-qsw(i,j) cnd(i,j)=dm(i,j)/(1.+avcp*dd(i,j)*qsw(i,j)) !c ****** condensation or evaporation of qc ****** cnd(i,j)=max(-qc(i,j), cnd(i,j)) pt(i,j)=pt(i,j)+avcp*cnd(i,j) qv(i,j)=qv(i,j)-cnd(i,j) qc(i,j)=qc(i,j)+cnd(i,j) endif if (tair(i,j) .le. 258.16) then !c cnd(i,j)=0.0 y2(i,j)=1./(tair(i,j)-c76) qsi(i,j)=rp0*exp(c218-c580*y2(i,j)) dd1(i,j)=cp580*y2(i,j)*y2(i,j) dep(i,j)=(qv(i,j)+qb0-qsi(i,j))/(1.+ascp*dd1(i,j)*qsi(i,j)) !c ****** deposition or sublimation of qi ****** dep(i,j)=max(-qi(i,j),dep(i,j)) pt(i,j)=pt(i,j)+ascp*dep(i,j) qv(i,j)=qv(i,j)-dep(i,j) qi(i,j)=qi(i,j)+dep(i,j) endif !JJS enddo !JJS enddo endif !c ! !* 10 * PSDEP : DEPOSITION OR SUBLIMATION OF QS **10** !* 20 * PGSUB : SUBLIMATION OF QG **20** !JJS DO 275 J=3,JLES !JJS DO 275 I=3,ILES psdep(i,j)=0.0 pssub(i,j)=0.0 pgsub(i,j)=0.0 tair(i,j)=(pt(i,j)+tb0)*pi0 if(tair(i,j).lt.t0) then if(qs(i,j).lt.cmin1) qs(i,j)=0.0 if(qg(i,j).lt.cmin1) qg(i,j)=0.0 rtair(i,j)=1./(tair(i,j)-c76) qsi(i,j)=rp0*exp(c218-c580*rtair(i,j)) ssi(i,j)=(qv(i,j)+qb0)/qsi(i,j)-1. !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc y1(i,j)=r10ar/(tca(i,j)*tair(i,j)**2)+1./(dwv(i,j) & *qsi(i,j)) y2(i,j)=.78/zs(i,j)**2+r101f*scv(i,j)/zs(i,j)**bsh5 psdep(i,j)=r10t*ssi(i,j)*y2(i,j)/y1(i,j) pssub(i,j)=psdep(i,j) psdep(i,j)=r2iceg*max(psdep(i,j), 0.) pssub(i,j)=r2iceg*max(-qs(i,j), min(pssub(i,j), 0.)) if(ihail.eq.1) then y2(i,j)=.78/zg(i,j)**2+r20bq*scv(i,j)/zg(i,j)**bgh5 else y2(i,j)=.78/zg(i,j)**2+r20bs*scv(i,j)/zg(i,j)**bgh5 endif pgsub(i,j)=r2ice*r20t*ssi(i,j)*y2(i,j)/y1(i,j) dm(i,j)=qv(i,j)+qb0-qsi(i,j) rsub1(i,j)=cs580*qsi(i,j)*rtair(i,j)*rtair(i,j) ! ******** DEPOSITION OR SUBLIMATION OF QS ********************** y1(i,j)=dm(i,j)/(1.+rsub1(i,j)) psdep(i,j)=r2iceg*min(psdep(i,j),max(y1(i,j),0.)) y2(i,j)=min(y1(i,j),0.) pssub(i,j)=r2iceg*max(pssub(i,j),y2(i,j)) ! ******** SUBLIMATION OF QG *********************************** dd(i,j)=max((-y2(i,j)-qs(i,j)), 0.) pgsub(i,j)=r2ice*min(dd(i,j), qg(i,j), max(pgsub(i,j),0.)) if(qc(i,j)+qi(i,j).gt.1.e-5) then dlt1(i,j)=1. else dlt1(i,j)=0. endif psdep(i,j)=dlt1(i,j)*psdep(i,j) pssub(i,j)=(1.-dlt1(i,j))*pssub(i,j) pgsub(i,j)=(1.-dlt1(i,j))*pgsub(i,j) pt(i,j)=pt(i,j)+ascp*(psdep(i,j)+pssub(i,j)-pgsub(i,j)) qv(i,j)=qv(i,j)+pgsub(i,j)-pssub(i,j)-psdep(i,j) qs(i,j)=qs(i,j)+psdep(i,j)+pssub(i,j) qg(i,j)=qg(i,j)-pgsub(i,j) endif !* 23 * ERN : EVAPORATION OF QR (SUBSATURATION) **23** ern(i,j)=0.0 if(qr(i,j).gt.0.0) then tair(i,j)=(pt(i,j)+tb0)*pi0 rtair(i,j)=1./(tair(i,j)-c358) qsw(i,j)=rp0*exp(c172-c409*rtair(i,j)) ssw(i,j)=(qv(i,j)+qb0)/qsw(i,j)-1.0 dm(i,j)=qv(i,j)+qb0-qsw(i,j) rsub1(i,j)=cv409*qsw(i,j)*rtair(i,j)*rtair(i,j) dd1(i,j)=max(-dm(i,j)/(1.+rsub1(i,j)), 0.0) y1(i,j)=.78/zr(i,j)**2+r23af*scv(i,j)/zr(i,j)**bwh5 y2(i,j)=r23br/(tca(i,j)*tair(i,j)**2)+1./(dwv(i,j) & *qsw(i,j)) !cccc ern(i,j)=r23t*ssw(i,j)*y1(i,j)/y2(i,j) ern(i,j)=min(dd1(i,j),qr(i,j),max(ern(i,j),0.)) pt(i,j)=pt(i,j)-avcp*ern(i,j) qv(i,j)=qv(i,j)+ern(i,j) qr(i,j)=qr(i,j)-ern(i,j) endif ! IF (QV(I,J)+QB0 .LE. 0.) QV(I,J)=-QB0 if (qc(i,j) .le. cmin1) qc(i,j)=0. if (qr(i,j) .le. cmin1) qr(i,j)=0. if (qi(i,j) .le. cmin1) qi(i,j)=0. if (qs(i,j) .le. cmin1) qs(i,j)=0. if (qg(i,j) .le. cmin1) qg(i,j)=0. dpt(i,j,k)=pt(i,j) dqv(i,j,k)=qv(i,j) qcl(i,j,k)=qc(i,j) qrn(i,j,k)=qr(i,j) qci(i,j,k)=qi(i,j) qcs(i,j,k)=qs(i,j) qcg(i,j,k)=qg(i,j) !JJS 275 CONTINUE scc=0. see=0. ! DO 110 J=3,JLES ! DO 110 I=3,ILES ! DD(I,J)=MAX(-CND(I,J), 0.) ! CND(I,J)=MAX(CND(I,J), 0.) ! DD1(I,J)=MAX(-DEP(I,J), 0.) !ccshie 2/21/02 shie follow tao !CC for reference QI(I,J)=QI(I,J)-Y2(I,J)+PIDEP(I,J)*D2T !CC for reference QV(I,J)=QV(I,J)-(PIDEP(I,J))*D2T !c DEP(I,J)=MAX(DEP(I,J), 0.) ! DEP(I,J)=MAX(DEP(I,J), 0.)+PIDEP(I,J)*D2T ! SCC=SCC+CND(I,J) ! SEE=SEE+DD(I,J)+ERN(I,J) ! 110 CONTINUE ! SC(K)=SCC+SC(K) ! SE(K)=SEE+SE(K) !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc !c henry: please take a look (start) !JJS modified by JJS on 5/1/2007 vvvvv !JJS do 305 j=3,jles !JJS do 305 i=3,iles dd(i,j)=max(-cnd(i,j), 0.) cnd(i,j)=max(cnd(i,j), 0.) dd1(i,j)=max(-dep(i,j), 0.)+pidep(i,j)*d2t dep(i,j)=max(dep(i,j), 0.) !JJS 305 continue !JJS do 306 j=3,jles !JJS do 306 i=3,iles !JJS scc=scc+cnd(i,j) !JJS see=see+(dd(i,j)+ern(i,j)) ! !JJS sddd=sddd+(dep(i,j)+pint(i,j)+psdep(i,j)+pgdep(i,j)) !JJS ssss=ssss+dd1(i,j) !JJS ! shhh=shhh+rsw(i,j,k)*d2t ! sccc=sccc+rlw(i,j,k)*d2t !jjs !JJS smmm=smmm+(psmlt(i,j)+pgmlt(i,j)+pimlt(i,j)) !JJS sfff=sfff+d2t*(psacw(i,j)+piacr(i,j)+psfw(i,j) !JJS 1 +pgfr(i,j)+dgacw(i,j)+dgacr(i,j)+psacr(i,j)) !JJS 2 -qracs(i,j)+pihom(i,j)+pidw(i,j) sccc=cnd(i,j) seee=dd(i,j)+ern(i,j) sddd=dep(i,j)+pint(i,j)+psdep(i,j)+pgdep(i,j) ssss=dd1(i,j) + pgsub(i,j) smmm=psmlt(i,j)+pgmlt(i,j)+pimlt(i,j) sfff=d2t*(psacw(i,j)+piacr(i,j)+psfw(i,j) & +pgfr(i,j)+dgacw(i,j)+dgacr(i,j)+psacr(i,j) & +wgacr(i,j))+pihom(i,j)+pidw(i,j) physc(i,k,j) = avcp * sccc / d2t physe(i,k,j) = avcp * seee / d2t physd(i,k,j) = ascp * sddd / d2t physs(i,k,j) = ascp * ssss / d2t physm(i,k,j) = afcp * smmm / d2t physf(i,k,j) = afcp * sfff / d2t !JJS modified by JJS on 5/1/2007 ^^^^^ 2000 continue 1000 continue !JJS **************************************************************** !JJS convert from GCE grid back to WRF grid do k=kts,kte do j=jts,jte do i=its,ite ptwrf(i,k,j) = dpt(i,j,k) qvwrf(i,k,j) = dqv(i,j,k) qlwrf(i,k,j) = qcl(i,j,k) qrwrf(i,k,j) = qrn(i,j,k) qiwrf(i,k,j) = qci(i,j,k) qswrf(i,k,j) = qcs(i,j,k) qgwrf(i,k,j) = qcg(i,j,k) enddo !i enddo !j enddo !k ! **************************************************************** return END SUBROUTINE saticel_s !JJS !JJS REAL FUNCTION GAMMA(X) !JJS Y=GAMMLN(X) !JJS GAMMA=EXP(Y) !JJS RETURN !JJS END !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc !JJS real function GAMMLN (xx) real function gammagce (xx) !********************************************************************** real*8 cof(6),stp,half,one,fpf,x,tmp,ser data cof,stp / 76.18009173,-86.50532033,24.01409822, & -1.231739516,.120858003e-2,-.536382e-5, 2.50662827465 / data half,one,fpf / .5, 1., 5.5 / ! x=xx-one tmp=x+fpf tmp=(x+half)*log(tmp)-tmp ser=one do j=1,6 x=x+one ser=ser+cof(j)/x enddo !j gammln=tmp+log(stp*ser) !JJS gammagce=exp(gammln) !JJS return END FUNCTION gammagce END MODULE module_mp_gsfcgce