GFS Operational Physics Documentation  Revision: 81451
gscond.f
Go to the documentation of this file.
1 
5 
40 
53 
85  subroutine gscond (im,ix,km,dt,dtf,prsl,ps,q,cwm,t
86  &, tp, qp, psp, tp1, qp1, psp1, u, lprnt, ipr)
87 !
88 ! ******************************************************************
89 ! * *
90 ! * subroutine for grid-scale condensation & evaporation *
91 ! * for the mrf model at ncep. *
92 ! * *
93 ! ******************************************************************
94 ! * *
95 ! * created by: q. zhao jan. 1995 *
96 ! * modified by: h.-l. pan sep. 1998 *
97 ! * modified by: s. moorthi aug. 1998, 1999, 2000 *
98 ! * *
99 ! * references: *
100 ! * *
101 ! ******************************************************************
102 !
103  use machine , only : kind_phys
104  use funcphys , only : fpvs
105  use physcons, psat => con_psat, hvap => con_hvap, grav => con_g
106  &, hfus => con_hfus, ttp => con_ttp, rd => con_rd
107  &, cp => con_cp, eps => con_eps, epsm1 => con_epsm1
108  &, rv => con_rv
109 ! use namelist_def, only: nsdfi,fhdfi
110  implicit none
111 !
112  real (kind=kind_phys) h1
113  &, d00, elwv, eliv
114  &, epsq
115  &, r, cpr, rcp
116  parameter(h1=1.e0, d00=0.e0
117  &, elwv=hvap, eliv=hvap+hfus
118  &, epsq=2.e-12, r=rd
119  &, cpr=cp*r, rcp=h1/cp)
120 !
121  real(kind=kind_phys), parameter :: cons_0=0.0, cons_m15=-15.0
122 !
123  integer im, ix, km, ipr
124  real (kind=kind_phys) q(ix,km), t(ix,km), cwm(ix,km)
125  &, prsl(ix,km), ps(im), dt, dtf
126  &, tp(ix,km), qp(ix,km), psp(im)
127  &, tp1(ix,km), qp1(ix,km), psp1(im)
128 !
129  real (kind=kind_phys) qi(im), qint(im), u(im,km), ccrik, e0
130  &, cond, rdt, us, cclimit, climit
131  &, tmt0, tmt15, qik, cwmik
132  &, ai, qw, u00ik, tik, pres, pp0, fi
133  &, at, aq, ap, fiw, elv, qc, rqik
134  &, rqikk, tx1, tx2, tx3, es, qs
135  &, tsq, delq, condi, cone0, us00, ccrik1
136  &, aa, ab, ac, ad, ae, af, ag
137  &, el2orc, albycp
138 ! real (kind=kind_phys) vprs(im)
139  integer iw(im,km), i, k, iwik
140  logical lprnt
141 !
142 !-----------------prepare constants for later uses-----------------
143 !
144  el2orc = hvap*hvap / (rv*cp)
145  albycp = hvap / cp
146 ! write(0,*)' in gscond im=',im,' ix=',ix
147 !
148  rdt = h1/dt
149  us = h1
150  cclimit = 1.0e-3
151  climit = 1.0e-20
152 !
153  do i = 1, im
154  iw(i,km) = d00
155  enddo
156 !
157 ! check for first time step
158 !
159 ! if (tp(1,1) < 1.) then
160 ! do k = 1, km
161 ! do i = 1, im
162 ! tp(i,k) = t(i,k)
163 ! qp(i,k) = max(q(i,k),epsq)
164 ! tp1(i,k) = t(i,k)
165 ! qp1(i,k) = max(q(i,k),epsq)
166 ! enddo
167 ! enddo
168 ! do i = 1, im
169 ! psp(i) = ps(i)
170 ! psp1(i) = ps(i)
171 ! enddo
172 ! endif
173 !
174 !*************************************************************
177 !*************************************************************
178 !
179 ! do k = km-1,2,-1
180  do k = km,1,-1
181 ! vprs(:) = 0.001 * fpvs(t(:,k)) ! fpvs in pa
182 !-----------------------------------------------------------------------
183 !------------------qw, qi and qint--------------------------------------
184  do i = 1, im
185  tmt0 = t(i,k)-273.16
186  tmt15 = min(tmt0,cons_m15)
187  qik = max(q(i,k),epsq)
188  cwmik = max(cwm(i,k),climit)
189 !
190 ! ai = 0.008855
191 ! bi = 1.0
192 ! if (tmt0 .lt. -20.0) then
193 ! ai = 0.007225
194 ! bi = 0.9674
195 ! end if
196 !
197 ! the global qsat computation is done in pa
198  pres = prsl(i,k)
199 !
200 ! qw = vprs(i)
201  qw = min(pres, fpvs(t(i,k)))
202 !
203  qw = eps * qw / (pres + epsm1 * qw)
204  qw = max(qw,epsq)
205 ! qi(i) = qw *(bi+ai*min(tmt0,cons_0))
206 ! qint(i) = qw *(1.-0.00032*tmt15*(tmt15+15.))
207  qi(i) = qw
208  qint(i) = qw
209 ! if (tmt0 .le. -40.) qint(i) = qi(i)
226 !-------------------ice-water id number iw------------------------------
227  if(tmt0.lt.-15.0) then
228  u00ik = u(i,k)
229  fi = qik - u00ik*qi(i)
230  if(fi > d00.or.cwmik > climit) then
231  iw(i,k) = 1
232  else
233  iw(i,k) = 0
234  end if
235  end if
236 !
237  if(tmt0.ge.0.0) then
238  iw(i,k) = 0
239  end if
240 !
241  if (tmt0 < 0.0 .and. tmt0 >= -15.0) then
242  iw(i,k) = 0
243  if (k < km) then
244  if (iw(i,k+1) == 1 .and. cwmik > climit) iw(i,k) = 1
245  endif
246  end if
247  enddo
249 !--------------condensation and evaporation of cloud--------------------
250  do i = 1, im
263 !------------------------at, aq and dp/dt-------------------------------
264  qik = max(q(i,k),epsq)
265  cwmik = max(cwm(i,k),climit)
266  iwik = iw(i,k)
267  u00ik = u(i,k)
268  tik = t(i,k)
269  pres = prsl(i,k)
270  pp0 = (pres / ps(i)) * psp(i)
271  at = (tik-tp(i,k)) * rdt
272  aq = (qik-qp(i,k)) * rdt
273  ap = (pres-pp0) * rdt
276 !----------------the satuation specific humidity------------------------
277  fiw = float(iwik)
278  elv = (h1-fiw)*elwv + fiw*eliv
279  qc = (h1-fiw)*qint(i) + fiw*qi(i)
280 ! if (lprnt) print *,' qc=',qc,' qint=',qint(i),' qi=',qi(i)
281 !----------------the relative humidity----------------------------------
282  if(qc.le.1.0e-10) then
283  rqik=d00
284  else
285  rqik = qik/qc
286  endif
370 !----------------cloud cover ratio ccrik--------------------------------
371  if (rqik .lt. u00ik) then
372  ccrik = d00
373  elseif(rqik.ge.us) then
374  ccrik = us
375  else
376  rqikk = min(us,rqik)
377  ccrik = h1-sqrt((us-rqikk)/(us-u00ik))
378  endif
379 !-----------correct ccr if it is too small in large cwm regions--------
380 ! if(ccrik.ge.0.01.and.ccrik.le.0.2.and
381 ! & .cwmik.ge.0.2e-3) then
382 ! ccrik=min(1.0,cwmik*1.0e3)
383 ! end if
384 !----------------------------------------------------------------------
385 ! if no cloud exists then evaporate any existing cloud condensate
386 !----------------evaporation of cloud water-----------------------------
387  e0 = d00
388  if (ccrik <= cclimit.and. cwmik > climit) then
389 !
390 ! first iteration - increment halved
391 !
392  tx1 = tik
393  tx3 = qik
394 !
395  es = min(pres, fpvs(tx1))
396  qs = u00ik * eps * es / (pres + epsm1*es)
397  tsq = tx1 * tx1
398  delq = 0.5 * (qs - tx3) * tsq / (tsq + el2orc * qs)
399 !
400  tx2 = delq
401  tx1 = tx1 - delq * albycp
402  tx3 = tx3 + delq
403 !
404 ! second iteration
405 !
406  es = min(pres, fpvs(tx1))
407  qs = u00ik * eps * es / (pres + epsm1*es)
408  tsq = tx1 * tx1
409  delq = (qs - tx3) * tsq / (tsq + el2orc * qs)
410 !
411  tx2 = tx2 + delq
412  tx1 = tx1 - delq * albycp
413  tx3 = tx3 + delq
414 !
415 ! third iteration
416 !
417  es = min(pres, fpvs(tx1))
418  qs = u00ik * eps * es / (pres + epsm1*es)
419  tsq = tx1 * tx1
420  delq = (qs - tx3) * tsq / (tsq + el2orc * qs)
421  tx2 = tx2 + delq
422 !
423  e0 = max(tx2*rdt, cons_0)
424 ! if (lprnt .and. i .eq. ipr .and. k .eq. 34)
425 ! & print *,' tx2=',tx2,' qc=',qc,' u00ik=',u00ik,' rqik=',rqik
426 ! &,' cwmik=',cwmik,' e0',e0
427 
428 ! e0 = max(qc*(u00ik-rqik)*rdt, cons_0)
429  e0 = min(cwmik*rdt, e0)
430  e0 = max(cons_0,e0)
431  end if
432 ! if cloud cover > 0.2 condense water vapor in to cloud condensate
433 !-----------the eqs. for cond. has been reorganized to reduce cpu------
434  cond = d00
435 ! if (ccrik .gt. 0.20 .and. qc .gt. epsq) then
436  if (ccrik .gt. cclimit .and. qc .gt. epsq) then
437  us00 = us - u00ik
438  ccrik1 = 1.0 - ccrik
439  aa = eps*elv*pres*qik
440  ab = ccrik*ccrik1*qc*us00
441  ac = ab + 0.5*cwmik
442  ad = ab * ccrik1
443  ae = cpr*tik*tik
444  af = ae * pres
445  ag = aa * elv
446  ai = cp * aa
447  cond = (ac-ad)*(af*aq-ai*at+ae*qik*ap)/(ac*(af+ag))
448 !-----------check & correct if over condensation occurs-----------------
449  condi = (qik -u00ik *qc*1.0)*rdt
450  cond = min(cond, condi)
451 !----------check & correct if supersatuation is too high----------------
452 ! qtemp=qik-max(0.,(cond-e0))*dt
453 ! if(qc.le.1.0e-10) then
454 ! rqtmp=0.0
455 ! else
456 ! rqtmp=qtemp/qc
457 ! end if
458 ! if(rqtmp.ge.1.10) then
459 ! cond=(qik-1.10*qc)*rdt
460 ! end if
461 !-----------------------------------------------------------------------
462  cond = max(cond, d00)
463 !-------------------update of t, q and cwm------------------------------
464  end if
465  cone0 = (cond-e0) * dt
466  cwm(i,k) = cwm(i,k) + cone0
467 ! if (lprnt .and. i .eq. ipr) print *,' t=',t(i,k),' cone0',cone0
468 ! &,' cond=',cond,' e0=',e0,' elv=',elv,' rcp=',rcp,' k=',k
469 ! &,' cwm=',cwm(i,k)
470  t(i,k) = t(i,k) + elv*rcp*cone0
471  q(i,k) = q(i,k) - cone0
472  enddo ! end of i-loop!
473  enddo ! end of k-loop!
474 !
475 !*********************************************************************
477 !*********************************************************************
478 !
479 
481 
482  if (dt > dtf+0.001) then ! three time level
483  do k = 1, km
484  do i = 1, im
485  tp(i,k) = tp1(i,k)
486  qp(i,k) = qp1(i,k)
487 !
488  tp1(i,k) = t(i,k)
489  qp1(i,k) = max(q(i,k),epsq)
490  enddo
491  enddo
492  do i = 1, im
493  psp(i) = psp1(i)
494  psp1(i) = ps(i)
495  enddo
496  else ! two time level scheme - tp1, qp1, psp1 not used
497  do k = 1, km
498 ! write(0,*)' in gscond k=',k,' im=',im,' km=',km
499  do i = 1, im
500 ! write(0,*)' in gscond i=',i
501  tp(i,k) = t(i,k)
502  qp(i,k) = max(q(i,k),epsq)
503 ! qp(i,k) = q(i,k)
504  tp1(i,k) = tp(i,k)
505  qp1(i,k) = qp(i,k)
506  enddo
507  enddo
508  do i = 1, im
509  psp(i) = ps(i)
510  psp1(i) = ps(i)
511  enddo
512  endif
513 !-----------------------------------------------------------------------
514  return
515  end
516 
real(kind=kind_phys), parameter con_g
gravity ( )
Definition: physcons.f:59
real(kind=kind_phys), parameter con_rv
gas constant H2O ( )
Definition: physcons.f:78
real(kind=kind_phys), parameter con_hfus
lat heat H2O fusion ( )
Definition: physcons.f:92
real(kind=kind_phys), parameter con_cp
spec heat air at p ( )
Definition: physcons.f:80
real(kind=kind_phys), parameter con_hvap
lat heat H2O cond ( )
Definition: physcons.f:90
real(kind=kind_phys), parameter con_ttp
temp at H2O 3pt (K)
Definition: physcons.f:98
real(kind=kind_phys), parameter con_rd
gas constant air ( )
Definition: physcons.f:76
real(kind=kind_phys), parameter con_psat
pres at H2O 3pt (Pa)
Definition: physcons.f:94
subroutine gscond(im, ix, km, dt, dtf, prsl, ps, q, cwm, t , tp, qp, psp, tp1, qp1, psp1, u, lprnt, ipr)
Definition: gscond.f:87