FV3 Bundle
convection_ad.F90
Go to the documentation of this file.
1 MODULE convection_ad
2 
3 USE convection
4 
5 IMPLICIT NONE
6 
7 PRIVATE
8 PUBLIC :: rase_b, rase_tracer_b
9 
10 CONTAINS
11 
12 ! Generated by TAPENADE (INRIA, Tropics team)
13 ! Tapenade 3.9 (r5096) - 24 Feb 2014 16:53
14 !
15 ! Differentiation of rase in reverse (adjoint) mode:
16 ! gradient of useful results: clw cnv_prc3 tho qho vho cnv_updfrc
17 ! uho flxd
18 ! with respect to varying inputs: clw cnv_prc3 tho qho vho cnv_updfrc
19 ! uho flxd
20 ! RW status of diff variables: clw:in-zero cnv_prc3:in-zero tho:in-out
21 ! qho:in-out vho:in-out cnv_updfrc:in-zero uho:in-out
22 ! flxd:in-zero
23 SUBROUTINE rase_b(idim, irun, k0, icmin, dt, cons_cp, cons_alhl, &
24 & cons_grav, cons_rgas, cons_h2omw, cons_airmw, cons_vireps, seedras, &
25 & sige, kcbl, wgt0, wgt1, frland, ts, tho, thob, qho, qhob, uho, uhob, &
26 & vho, vhob, co_auto, ple, clw, clwb, flxd, flxdb, cnv_prc3, cnv_prc3b, &
27 & cnv_updfrc, cnv_updfrcb, rasparams, estblx)
28  IMPLICIT NONE
29 !INPUTS
30  INTEGER, INTENT(IN) :: idim, irun, k0, icmin
31  REAL*8, DIMENSION(idim, k0 + 1), INTENT(IN) :: ple
32  REAL*8, DIMENSION(k0 + 1), INTENT(IN) :: sige
33  REAL*8, INTENT(IN) :: dt, cons_cp, cons_alhl, cons_grav, cons_rgas
34  REAL*8, INTENT(IN) :: cons_h2omw, cons_airmw, cons_vireps
35  INTEGER, DIMENSION(idim), INTENT(IN) :: seedras
36  INTEGER, DIMENSION(idim), INTENT(IN) :: kcbl
37  REAL*8, DIMENSION(idim), INTENT(IN) :: ts, frland
38  REAL*8, DIMENSION(idim), INTENT(IN) :: co_auto
39  REAL*8, DIMENSION(idim, k0), INTENT(IN) :: wgt0, wgt1
40  REAL*8, DIMENSION(:), INTENT(IN) :: rasparams
41  REAL*8, DIMENSION(:), INTENT(IN) :: estblx
42 !OUTPUTS
43  REAL*8, DIMENSION(idim, k0) :: clw, flxd
44  REAL*8, DIMENSION(idim, k0) :: clwb, flxdb
45  REAL*8, DIMENSION(idim, k0) :: cnv_prc3
46  REAL*8, DIMENSION(idim, k0) :: cnv_prc3b
47  REAL*8, DIMENSION(idim, k0) :: cnv_updfrc
48  REAL*8, DIMENSION(idim, k0) :: cnv_updfrcb
49 !PROGNOSTIC
50  REAL*8, DIMENSION(idim, k0), INTENT(INOUT) :: tho, qho, uho, vho
51  REAL*8, DIMENSION(idim, k0), INTENT(INOUT) :: thob
52 !LOCALS
53  INTEGER :: i, ic, l, kk, k
54 !Parameters
55  REAL*8, PARAMETER :: onepkap=1.+2./7., daylen=86400.0
56  REAL*8, PARAMETER :: rhmax=0.9999
57  REAL*8, PARAMETER :: cbl_qpert=0.0, cbl_tpert=1.0
58  REAL*8, PARAMETER :: cbl_tpert_mxocn=2.0, cbl_tpert_mxlnd=4.0
59 !Constants
60  REAL*8 :: grav, cp, alhl, cpbg, alhi, cpi, gravi, ddt, lbcp
61 !Rasparams
62  REAL*8 :: fricfac, cli_crit, rasal1, rasal2
63  REAL*8 :: friclambda
64  REAL*8 :: sdqv2, sdqv3, sdqvt1
65  REAL*8 :: acritfac, pblfrac, autorampb
66  REAL*8 :: maxdallowed, rhmn, rhmx
67  REAL*8 :: mxdiam
68  REAL*8 :: tx2, tx3, akm, acr, alm, tth, qqh, dqx
69  REAL*8 :: tx2b, tx3b, akmb, almb
70  REAL*8 :: wfn, tem, trg, trgexp, evp, wlq, qcc
71  REAL*8 :: wfnb, temb, trgb, wlqb, qccb
72  REAL*8 :: cli, te_a, c00_x, cli_crit_x, toki
73  REAL*8 :: clib, te_ab, c00_xb, cli_crit_xb, tokib
74  REAL*8 :: dt_lyr, rate, cvw_x, closs, f2, f3, f4
75  REAL*8 :: dt_lyrb, rateb, cvw_xb, clossb, f2b
76  REAL*8 :: wght0, prcbl, rndu
77  REAL*8 :: lambda_min, lambda_max
78  REAL*8 :: tpert, qpert
79  REAL*8 :: tpertb
80  REAL*8 :: uht, vht
81  REAL*8 :: uhtb, vhtb
82  REAL*8, DIMENSION(k0) :: poi_sv, qoi_sv, uoi_sv, voi_sv
83  REAL*8, DIMENSION(k0) :: poi_svb, qoi_svb, uoi_svb, voi_svb
84  REAL*8, DIMENSION(k0) :: poi, qoi, uoi, voi, dqq, bet, gam, cll
85  REAL*8, DIMENSION(k0) :: poib, qoib, uoib, voib, dqqb, betb, gamb, &
86 & cllb
87  REAL*8, DIMENSION(k0) :: poi_c, qoi_c
88  REAL*8, DIMENSION(k0) :: poi_cb, qoi_cb
89  REAL*8, DIMENSION(k0) :: prh, pri, ght, dpt, dpb, pki
90  REAL*8, DIMENSION(k0) :: ghtb
91  REAL*8, DIMENSION(k0) :: ucu, vcu
92  REAL*8, DIMENSION(k0) :: ucub, vcub
93  REAL*8, DIMENSION(k0) :: cln, rns, pol
94  REAL*8, DIMENSION(k0) :: rnsb
95  REAL*8, DIMENSION(k0) :: qst, ssl, rmf, rnn, rn1, rmfc, rmfp
96  REAL*8, DIMENSION(k0) :: qstb, sslb, rnnb, rmfpb
97  REAL*8, DIMENSION(k0) :: gms, eta, gmh, eht, gm1, hcc, rmfd
98  REAL*8, DIMENSION(k0) :: gmsb, etab, gmhb, ehtb, gm1b, hccb, rmfdb
99  REAL*8, DIMENSION(k0) :: hol, hst, qol, zol, hcld, cll0, cllx, clli
100  REAL*8, DIMENSION(k0) :: holb, hstb, qolb, zolb, hcldb, cll0b
101  REAL*8, DIMENSION(k0) :: bke, cvw, updfrc
102  REAL*8, DIMENSION(k0) :: cvwb, updfrcb
103  REAL*8, DIMENSION(k0) :: rasal, updfrp, bk2, dll0, dllx
104  REAL*8, DIMENSION(k0) :: rasalb, updfrpb, bk2b
105  REAL*8, DIMENSION(k0) :: wght, massf
106  REAL*8, DIMENSION(k0) :: qss, dqs, pf, pk, tempf, zlo
107  REAL*8, DIMENSION(k0) :: qssb, dqsb, tempfb, zlob
108  REAL*8, DIMENSION(k0 + 1) :: prj, prs, qht, sht, zet, zle, pke
109  REAL*8, DIMENSION(k0+1) :: qhtb, shtb, zetb, zleb
110  INTRINSIC max
111  INTRINSIC min
112  INTRINSIC sqrt
113  INTRINSIC exp
114  INTRINSIC sum
115  REAL*8 :: arg1
116  REAL*8 :: arg1b
117  INTEGER :: branch
118  INTEGER :: ad_to
119  INTEGER :: ad_from
120  INTEGER :: ad_from0
121  INTEGER :: ad_from1
122  INTEGER :: ad_to0
123  INTEGER :: ad_to1
124  INTEGER :: ad_from2
125  INTEGER :: ad_to2
126  INTEGER :: ad_to3
127  INTEGER :: ad_from3
128  INTEGER :: ad_from4
129  INTEGER :: ad_to4
130  INTEGER :: ad_from5
131  REAL*8, DIMENSION(idim, k0), INTENT(INOUT) :: vhob
132  REAL*8, DIMENSION(idim, k0), INTENT(INOUT) :: uhob
133  REAL*8, DIMENSION(idim, k0), INTENT(INOUT) :: qhob
134  REAL*8 :: temp3
135  REAL*8 :: temp2
136  REAL*8 :: temp1
137  REAL*8 :: temp0
138  REAL*8 :: tempb9
139  REAL*8 :: tempb8
140  REAL*8 :: tempb7
141  REAL*8 :: tempb6
142  REAL*8 :: max2b
143  REAL*8 :: tempb5
144  REAL*8 :: tempb4
145  REAL*8 :: tempb19
146  REAL*8 :: tempb3
147  REAL*8 :: tempb18
148  REAL*8 :: tempb2
149  REAL*8 :: tempb17
150  REAL*8 :: tempb1
151  REAL*8 :: tempb16
152  REAL*8 :: tempb0
153  REAL*8 :: tempb15
154  REAL*8 :: tempb14
155  REAL*8 :: tempb13
156  REAL*8 :: tempb12
157  REAL*8 :: tempb11
158  REAL*8 :: tempb10
159  REAL*8 :: x1
160  REAL*8 :: tempb40
161  REAL*8 :: max1b
162  REAL*8 :: tempb
163  REAL*8 :: tempb39
164  REAL*8 :: tempb38
165  REAL*8 :: tempb37
166  REAL*8 :: tempb36
167  REAL*8 :: tempb35
168  REAL*8 :: tempb34
169  REAL*8 :: tempb33
170  REAL*8 :: x1b
171  REAL*8 :: tempb32
172  REAL*8 :: tempb31
173  REAL*8 :: tempb30
174  REAL*8 :: tempb29
175  REAL*8 :: tempb28
176  REAL*8 :: tempb27
177  REAL*8 :: tempb26
178  REAL*8 :: tempb25
179  REAL*8 :: temp
180  REAL*8 :: tempb24
181  REAL*8 :: tempb23
182  REAL*8 :: max2
183  REAL*8 :: tempb22
184  REAL*8 :: max1
185  REAL*8 :: tempb21
186  REAL*8 :: temp9
187  REAL*8 :: temp8
188  REAL*8 :: tempb20
189  REAL*8 :: temp7
190  REAL*8 :: temp6
191  REAL*8 :: temp5
192  REAL*8 :: y1
193  REAL*8 :: temp4
194 !Initialize Local Arrays
195  poi = 0.0
196  qoi = 0.0
197  uoi = 0.0
198  voi = 0.0
199  dqq = 0.0
200  bet = 0.0
201  gam = 0.0
202  prh = 0.0
203  pri = 0.0
204  ght = 0.0
205  dpt = 0.0
206  dpb = 0.0
207  pki = 0.0
208  ucu = 0.0
209  vcu = 0.0
210  pol = 0.0
211  qst = 0.0
212  ssl = 0.0
213  rnn = 0.0
214  gms = 0.0
215  eta = 0.0
216  gmh = 0.0
217  eht = 0.0
218  gm1 = 0.0
219  hcc = 0.0
220  hst = 0.0
221  qol = 0.0
222  zol = 0.0
223  hcld = 0.0
224  rasal = 0.0
225  bk2 = 0.0
226  qss = 0.0
227  dqs = 0.0
228  prj = 0.0
229  prs = 0.0
230  qht = 0.0
231  sht = 0.0
232  zet = 0.0
233 !Initialize Outputs
234 ! --- 1
235  fricfac = rasparams(1)
236 ! --- 4
237  cli_crit = rasparams(4)
238 ! --- 5
239  rasal1 = rasparams(5)
240 ! --- 6
241  rasal2 = rasparams(6)
242 ! --- 11
243  friclambda = rasparams(11)
244 ! --- 14
245  sdqv2 = rasparams(14)
246 ! --- 15
247  sdqv3 = rasparams(15)
248 ! --- 16
249  sdqvt1 = rasparams(16)
250 ! --- 17
251  acritfac = rasparams(17)
252 ! --- 20
253  pblfrac = rasparams(20)
254 ! --- 21
255  autorampb = rasparams(21)
256 ! --- 24
257  rhmn = rasparams(24)
258 ! --- 24
259  maxdallowed = rasparams(23)
260 ! --- 25
261  rhmx = rasparams(25)
262  grav = cons_grav
263  alhl = cons_alhl
264  cp = cons_cp
265  cpi = 1.0/cp
266  alhi = 1.0/alhl
267  gravi = 1.0/grav
268  cpbg = cp*gravi
269  ddt = daylen/dt
270  lbcp = alhl*cpi
271  i = 1
272 !CALL FINDBASE
273  k = kcbl(i)
274  IF (k .GT. 0) THEN
275 !Get saturation specific humidity and gradient wrt to T
276  pke = (ple(i, :)/1000.)**(cons_rgas/cons_cp)
277  pf = 0.5*(ple(i, 1:k0)+ple(i, 2:k0+1))
278  pk = (pf/1000.)**(cons_rgas/cons_cp)
279  tempf = tho(i, :)*pk
280  zle = 0.0
281  zlo = 0.0
282  zle(k0+1) = 0.
283  DO l=k0,1,-1
284  zle(l) = tho(i, l)*(1.+cons_vireps*qho(i, l))
285  zlo(l) = zle(l+1) + cons_cp/cons_grav*(pke(l+1)-pk(l))*zle(l)
286  zle(l) = zlo(l) + cons_cp/cons_grav*(pk(l)-pke(l))*zle(l)
287  END DO
288  tpert = cbl_tpert*(ts(i)-(tempf(k0)+cons_grav*zlo(k0)/cons_cp))
289 !* ( QSSFC - Q(:,:,K0) ) [CBL_QPERT = 0.0]
290  qpert = cbl_qpert
291  IF (tpert .LT. 0.0) THEN
292  tpert = 0.0
293  CALL pushcontrol1b(0)
294  ELSE
295  CALL pushcontrol1b(1)
296  tpert = tpert
297  END IF
298  IF (qpert .LT. 0.0) THEN
299  qpert = 0.0
300  ELSE
301  qpert = qpert
302  END IF
303  IF (frland(i) .LT. 0.1) THEN
304  IF (tpert .GT. cbl_tpert_mxocn) THEN
305  tpert = cbl_tpert_mxocn
306  CALL pushcontrol2b(1)
307  ELSE
308  CALL pushcontrol2b(0)
309  tpert = tpert
310  END IF
311  ELSE IF (tpert .GT. cbl_tpert_mxlnd) THEN
312  tpert = cbl_tpert_mxlnd
313  CALL pushcontrol2b(3)
314  ELSE
315  CALL pushcontrol2b(2)
316  tpert = tpert
317  END IF
318  CALL dqsat_ras(dqs, qss, tempf, pf, k0, estblx, cons_h2omw, &
319 & cons_airmw)
320  DO kk=icmin,k+1
321  prj(kk) = pke(kk)
322  END DO
323  prs(icmin:k0+1) = ple(i, icmin:k0+1)
324  poi(icmin:k) = tho(i, icmin:k)
325  qoi(icmin:k) = qho(i, icmin:k)
326  uoi(icmin:k) = uho(i, icmin:k)
327  voi(icmin:k) = vho(i, icmin:k)
328  qst(icmin:k) = qss(icmin:k)
329  dqq(icmin:k) = dqs(icmin:k)
330 !Mass fraction of each layer below cloud base
331  massf(:) = wgt0(i, :)
332 !RESET PRESSURE at bottom edge of CBL
333  prcbl = prs(k)
334  DO l=k,k0
335  prcbl = prcbl + massf(l)*(prs(l+1)-prs(l))
336  END DO
337  prs(k+1) = prcbl
338  prj(k+1) = (prs(k+1)/1000.)**(cons_rgas/cons_cp)
339  DO l=k,icmin,-1
340  pol(l) = 0.5*(prs(l)+prs(l+1))
341  prh(l) = (prs(l+1)*prj(l+1)-prs(l)*prj(l))/(onepkap*(prs(l+1)-prs(&
342 & l)))
343  pki(l) = 1.0/prh(l)
344  dpt(l) = prh(l) - prj(l)
345  dpb(l) = prj(l+1) - prh(l)
346  pri(l) = .01/(prs(l+1)-prs(l))
347  END DO
348 !RECALCULATE PROFILE QUAN. IN LOWEST STRAPPED LAYER
349  IF (k .LE. k0) THEN
350  poi(k) = 0.
351  qoi(k) = 0.
352  uoi(k) = 0.
353  voi(k) = 0.
354 !SPECIFY WEIGHTS GIVEN TO EACH LAYER WITHIN SUBCLOUD "SUPERLAYER"
355  wght = 0.
356  DO l=k,k0
357  wght(l) = massf(l)*(ple(i, l+1)-ple(i, l))/(prs(k+1)-prs(k))
358  END DO
359  DO l=k,k0
360  poi(k) = poi(k) + wght(l)*tho(i, l)
361  qoi(k) = qoi(k) + wght(l)*qho(i, l)
362  uoi(k) = uoi(k) + wght(l)*uho(i, l)
363  voi(k) = voi(k) + wght(l)*vho(i, l)
364  END DO
365  arg1 = poi(k)*prh(k)
366  CALL dqsats_ras(dqq(k), qst(k), arg1, pol(k), estblx, cons_h2omw, &
367 & cons_airmw)
368  CALL pushcontrol1b(1)
369  ELSE
370  CALL pushcontrol1b(0)
371  END IF
372  IF (seedras(i)/1000000. .LT. 1e-6) THEN
373  rndu = 1e-6
374  ELSE
375  rndu = seedras(i)/1000000.
376  END IF
377  mxdiam = maxdallowed*rndu**(-(1./2.))
378  DO l=k,icmin,-1
379 !*
380  bet(l) = dqq(l)*pki(l)
381 !*
382  gam(l) = pki(l)/(1.0+lbcp*dqq(l))
383  IF (l .LT. k) THEN
384  ght(l+1) = gam(l)*dpb(l) + gam(l+1)*dpt(l+1)
385  gm1(l+1) = 0.5*lbcp*(dqq(l)/(alhl*(1.0+lbcp*dqq(l)))+dqq(l+1)/(&
386 & alhl*(1.0+lbcp*dqq(l+1))))
387  CALL pushcontrol1b(1)
388  ELSE
389  CALL pushcontrol1b(0)
390  END IF
391  END DO
392  rmf = 0.
393  cvw = 0.0
394 ! HOL initialized here in order not to confuse Valgrind debugger
395  hol = 0.
396  zet(k+1) = 0
397  sht(k+1) = cp*poi(k)*prj(k+1)
398  DO l=k,icmin,-1
399  IF (qst(l)*rhmax .GT. qoi(l)) THEN
400  qol(l) = qoi(l)
401  CALL pushcontrol1b(0)
402  ELSE
403  qol(l) = qst(l)*rhmax
404  CALL pushcontrol1b(1)
405  END IF
406  IF (0.000 .LT. qol(l)) THEN
407  CALL pushcontrol1b(0)
408  qol(l) = qol(l)
409  ELSE
410  qol(l) = 0.000
411  CALL pushcontrol1b(1)
412  END IF
413  ssl(l) = cp*prj(l+1)*poi(l) + grav*zet(l+1)
414  hol(l) = ssl(l) + qol(l)*alhl
415  hst(l) = ssl(l) + qst(l)*alhl
416  tem = poi(l)*(prj(l+1)-prj(l))*cpbg
417  zet(l) = zet(l+1) + tem
418  zol(l) = zet(l+1) + (prj(l+1)-prh(l))*poi(l)*cpbg
419  END DO
420  DO ic=k,icmin+1,-1
421  ucu(icmin:) = 0.
422  vcu(icmin:) = 0.
423  IF (1. .GT. (qoi(k)/qst(k)-rhmn)/(rhmx-rhmn)) THEN
424  CALL pushreal8(trg)
425  trg = (qoi(k)/qst(k)-rhmn)/(rhmx-rhmn)
426  CALL pushcontrol1b(0)
427  ELSE
428  CALL pushreal8(trg)
429  trg = 1.
430  CALL pushcontrol1b(1)
431  END IF
432  IF (0.0 .LT. (autorampb-sige(ic))/0.2) THEN
433  y1 = (autorampb-sige(ic))/0.2
434  ELSE
435  y1 = 0.0
436  END IF
437  IF (1.0 .GT. y1) THEN
438  CALL pushreal8(f4)
439  f4 = y1
440  CALL pushcontrol1b(0)
441  ELSE
442  CALL pushreal8(f4)
443  f4 = 1.0
444  CALL pushcontrol1b(1)
445  END IF
446  IF (trg .LE. 1.0e-5) THEN
447  CALL pushcontrol3b(6)
448  ELSE
449 !================>>
450 !RECOMPUTE SOUNDING UP TO DETRAINMENT LEVEL
451  poi_c = poi
452  qoi_c = qoi
453  poi_c(k) = poi_c(k) + tpert
454  qoi_c(k) = qoi_c(k) + qpert
455  CALL pushreal8(zet(k+1))
456  zet(k+1) = 0.
457  CALL pushreal8(sht(k+1))
458  sht(k+1) = cp*poi_c(k)*prj(k+1)
459  DO l=k,ic,-1
460  IF (qst(l)*rhmax .GT. qoi_c(l)) THEN
461  CALL pushreal8(qol(l))
462  qol(l) = qoi_c(l)
463  CALL pushcontrol1b(0)
464  ELSE
465  CALL pushreal8(qol(l))
466  qol(l) = qst(l)*rhmax
467  CALL pushcontrol1b(1)
468  END IF
469  IF (0.000 .LT. qol(l)) THEN
470  CALL pushcontrol1b(0)
471  qol(l) = qol(l)
472  ELSE
473  qol(l) = 0.000
474  CALL pushcontrol1b(1)
475  END IF
476  CALL pushreal8(ssl(l))
477  ssl(l) = cp*prj(l+1)*poi_c(l) + grav*zet(l+1)
478  CALL pushreal8(hol(l))
479  hol(l) = ssl(l) + qol(l)*alhl
480  CALL pushreal8(hst(l))
481  hst(l) = ssl(l) + qst(l)*alhl
482  CALL pushreal8(tem)
483  tem = poi_c(l)*(prj(l+1)-prj(l))*cpbg
484  CALL pushreal8(zet(l))
485  zet(l) = zet(l+1) + tem
486  CALL pushreal8(zol(l))
487  zol(l) = zet(l+1) + (prj(l+1)-prh(l))*poi_c(l)*cpbg
488  END DO
489  CALL pushinteger4(l + 1)
490  ad_from = ic + 1
491  DO l=ad_from,k
492  CALL pushreal8(tem)
493  tem = (prj(l)-prh(l-1))/(prh(l)-prh(l-1))
494  CALL pushreal8(sht(l))
495  sht(l) = ssl(l-1) + tem*(ssl(l)-ssl(l-1))
496  CALL pushreal8(qht(l))
497  qht(l) = .5*(qol(l)+qol(l-1))
498  END DO
499  CALL pushinteger4(ad_from)
500 !CALCULATE LAMBDA, ETA, AND WORKFUNCTION
501  CALL pushreal8(lambda_min)
502  lambda_min = .2/mxdiam
503  lambda_max = .2/200.
504  IF (hol(k) .LE. hst(ic)) THEN
505  CALL pushcontrol3b(5)
506  ELSE
507 !================>>
508 !LAMBDA CALCULATION: MS-A18
509  CALL pushreal8(tem)
510  tem = (hst(ic)-hol(ic))*(zol(ic)-zet(ic+1))
511  ad_from0 = ic + 1
512  DO l=ad_from0,k-1
513  tem = tem + (hst(ic)-hol(l))*(zet(l)-zet(l+1))
514  END DO
515  CALL pushinteger4(ad_from0)
516  IF (tem .LE. 0.0) THEN
517  CALL pushcontrol3b(4)
518  ELSE
519 !================>>
520  CALL pushreal8(alm)
521  alm = (hol(k)-hst(ic))/tem
522  IF (alm .GT. lambda_max) THEN
523  CALL pushcontrol3b(3)
524  ELSE
525 !================>>
526  CALL pushreal8(toki)
527  toki = 1.0
528  IF (alm .LT. lambda_min) THEN
529  toki = (alm/lambda_min)**2
530  CALL pushcontrol1b(1)
531  ELSE
532  CALL pushcontrol1b(0)
533  END IF
534  ad_from1 = ic + 1
535 !ETA CALCULATION: MS-A2
536  DO l=ad_from1,k
537  CALL pushreal8(eta(l))
538  eta(l) = 1.0 + alm*(zet(l)-zet(k))
539  END DO
540  CALL pushinteger4(ad_from1)
541  CALL pushreal8(eta(ic))
542  eta(ic) = 1.0 + alm*(zol(ic)-zet(k))
543 !WORKFUNCTION CALCULATION: MS-A22
544  wfn = 0.0
545  CALL pushreal8(hcc(k))
546  hcc(k) = hol(k)
547  DO l=k-1,ic+1,-1
548  CALL pushreal8(hcc(l))
549  hcc(l) = hcc(l+1) + (eta(l)-eta(l+1))*hol(l)
550  CALL pushreal8(tem)
551  tem = hcc(l+1)*dpb(l) + hcc(l)*dpt(l)
552  CALL pushreal8(eht(l))
553  eht(l) = eta(l+1)*dpb(l) + eta(l)*dpt(l)
554  wfn = wfn + (tem-eht(l)*hst(l))*gam(l)
555  END DO
556  CALL pushinteger4(l + 1)
557  CALL pushreal8(hcc(ic))
558  hcc(ic) = hst(ic)*eta(ic)
559  wfn = wfn + (hcc(ic+1)-hst(ic)*eta(ic+1))*gam(ic)*dpb(ic)
560 !VERTICAL VELOCITY/KE CALCULATION (ADDED 12/2001 JTB)
561  bk2(k) = 0.0
562  CALL pushreal8(hcld(k))
563  hcld(k) = hol(k)
564  DO l=k-1,ic,-1
565  CALL pushreal8(hcld(l))
566  hcld(l) = (eta(l+1)*hcld(l+1)+(eta(l)-eta(l+1))*hol(l))/&
567 & eta(l)
568  CALL pushreal8(tem)
569  tem = (hcld(l)-hst(l))*(zet(l)-zet(l+1))/(1.0+lbcp*dqq(l&
570 & ))
571  IF (tem .LT. 0.0) THEN
572  CALL pushreal8(max1)
573  max1 = 0.0
574  CALL pushcontrol1b(0)
575  ELSE
576  CALL pushreal8(max1)
577  max1 = tem
578  CALL pushcontrol1b(1)
579  END IF
580  bk2(l) = bk2(l+1) + grav*max1/(cp*prj(l+1)*poi(l))
581  IF (bk2(l) .LT. 0.0) THEN
582  CALL pushreal8(max2)
583  max2 = 0.0
584  CALL pushcontrol1b(0)
585  ELSE
586  CALL pushreal8(max2)
587  max2 = bk2(l)
588  CALL pushcontrol1b(1)
589  END IF
590  CALL pushreal8(cvw(l))
591  cvw(l) = sqrt(2.0*max2)
592  END DO
593  CALL pushinteger4(l + 1)
594 !ALPHA CALCULATION
595  IF (zet(ic) .LT. 2000.) THEN
596  rasal(ic) = rasal1
597  CALL pushcontrol1b(0)
598  ELSE
599  CALL pushcontrol1b(1)
600  END IF
601  IF (zet(ic) .GE. 2000.) THEN
602  rasal(ic) = rasal1 + (rasal2-rasal1)*(zet(ic)-2000.)/&
603 & 8000.
604  CALL pushcontrol1b(1)
605  ELSE
606  CALL pushcontrol1b(0)
607  END IF
608  IF (rasal(ic) .GT. 1.0e5) THEN
609  rasal(ic) = 1.0e5
610  CALL pushcontrol1b(0)
611  ELSE
612  CALL pushcontrol1b(1)
613  rasal(ic) = rasal(ic)
614  END IF
615  CALL pushreal8(rasal(ic))
616  rasal(ic) = dt/rasal(ic)
617  ad_from2 = ic
618  DO l=ad_from2,k
619  IF (cvw(l) .LT. 1.00) THEN
620  CALL pushreal8(cvw(l))
621  cvw(l) = 1.00
622  CALL pushcontrol1b(0)
623  ELSE
624  CALL pushreal8(cvw(l))
625  cvw(l) = cvw(l)
626  CALL pushcontrol1b(1)
627  END IF
628  END DO
629  CALL pushinteger4(ad_from2)
630  CALL pushreal8(acr)
631  CALL acritn(pol(ic), prs(k), acr, acritfac)
632  IF (wfn .LE. acr) THEN
633  CALL pushcontrol3b(2)
634  ELSE
635 !================>>
636  CALL pushreal8(wlq)
637  wlq = qol(k)
638  CALL pushreal8(uht)
639  uht = uoi(k)
640  CALL pushreal8(vht)
641  vht = voi(k)
642  CALL pushreal8(rnn(k))
643  rnn(k) = 0.
644  DO l=k-1,ic,-1
645  CALL pushreal8(tem)
646  tem = eta(l) - eta(l+1)
647  wlq = wlq + tem*qol(l)
648  uht = uht + tem*uoi(l)
649  vht = vht + tem*voi(l)
650  IF (l .GT. ic) THEN
651  CALL pushreal8(tx2)
652  tx2 = 0.5*(qst(l)+qst(l-1))*eta(l)
653  CALL pushreal8(tx3)
654  tx3 = 0.5*(hst(l)+hst(l-1))*eta(l)
655  qcc = tx2 + gm1(l)*(hcc(l)-tx3)
656  CALL pushreal8(cll0(l))
657  cll0(l) = wlq - qcc
658  CALL pushcontrol1b(1)
659  ELSE
660  CALL pushreal8(cll0(l))
661  cll0(l) = wlq - qst(ic)*eta(ic)
662  CALL pushcontrol1b(0)
663  END IF
664  IF (cll0(l) .LT. 0.00) THEN
665  cll0(l) = 0.00
666  CALL pushcontrol1b(0)
667  ELSE
668  CALL pushcontrol1b(1)
669  cll0(l) = cll0(l)
670  END IF
671  cli = cll0(l)/eta(l)
672  te_a = poi(l)*prh(l)
673  CALL pushreal8(f3)
674  CALL pushreal8(f2)
675  CALL sundq3_ice(te_a, sdqv2, sdqv3, sdqvt1, f2, f3)
676  CALL pushreal8(c00_x)
677  c00_x = co_auto(i)*f2*f3*f4
678  cli_crit_x = cli_crit/(f2*f3)
679  CALL pushreal8(rate)
680  rate = c00_x*(1.0-exp(-(cli**2/cli_crit_x**2)))
681  IF (cvw(l) .LT. 1.00) THEN
682  CALL pushreal8(cvw_x)
683  cvw_x = 1.00
684  CALL pushcontrol1b(0)
685  ELSE
686  CALL pushreal8(cvw_x)
687  cvw_x = cvw(l)
688  CALL pushcontrol1b(1)
689  END IF
690  dt_lyr = (zet(l)-zet(l+1))/cvw_x
691  closs = cll0(l)*rate*dt_lyr
692  IF (closs .GT. cll0(l)) THEN
693  closs = cll0(l)
694  CALL pushcontrol1b(0)
695  ELSE
696  closs = closs
697  CALL pushcontrol1b(1)
698  END IF
699  IF (closs .GT. 0.) THEN
700  wlq = wlq - closs
701  CALL pushreal8(rnn(l))
702  rnn(l) = closs
703  CALL pushcontrol1b(1)
704  ELSE
705  CALL pushreal8(rnn(l))
706  rnn(l) = 0.
707  CALL pushcontrol1b(0)
708  END IF
709  END DO
710  CALL pushinteger4(l + 1)
711  wlq = wlq - qst(ic)*eta(ic)
712 !CALCULATE GAMMAS AND KERNEL
713  CALL pushreal8(gms(k))
714  gms(k) = (sht(k)-ssl(k))*pri(k)
715  CALL pushreal8(gmh(k))
716  gmh(k) = gms(k) + (qht(k)-qol(k))*pri(k)*alhl
717  CALL pushreal8(akm)
718  akm = gmh(k)*gam(k-1)*dpb(k-1)
719  CALL pushreal8(tx2)
720  tx2 = gmh(k)
721  DO l=k-1,ic+1,-1
722  CALL pushreal8(gms(l))
723  gms(l) = (eta(l)*(sht(l)-ssl(l))+eta(l+1)*(ssl(l)-sht(&
724 & l+1)))*pri(l)
725  CALL pushreal8(gmh(l))
726  gmh(l) = gms(l) + (eta(l)*(qht(l)-qol(l))+eta(l+1)*(&
727 & qol(l)-qht(l+1)))*alhl*pri(l)
728  CALL pushreal8(tx2)
729  tx2 = tx2 + (eta(l)-eta(l+1))*gmh(l)
730  akm = akm - gms(l)*eht(l)*pki(l) + tx2*ght(l)
731  END DO
732  CALL pushinteger4(l + 1)
733  CALL pushreal8(gms(ic))
734  gms(ic) = eta(ic+1)*(ssl(ic)-sht(ic+1))*pri(ic)
735  akm = akm - gms(ic)*eta(ic+1)*dpb(ic)*pki(ic)
736  CALL pushreal8(gmh(ic))
737  gmh(ic) = gms(ic) + (eta(ic+1)*(qol(ic)-qht(ic+1))*alhl+&
738 & eta(ic)*(hst(ic)-hol(ic)))*pri(ic)
739 !CLOUD BASE MASS FLUX
740  IF (akm .GE. 0.0 .OR. wlq .LT. 0.0) THEN
741  CALL pushcontrol3b(1)
742  ELSE
743 !================>>
744  CALL pushreal8(wfn)
745  wfn = -((wfn-acr)/akm)
746  x1 = rasal(ic)*trg*toki*wfn
747  IF (x1 .GT. (prs(k+1)-prs(k))*(100.*pblfrac)) THEN
748  CALL pushreal8(wfn)
749  wfn = (prs(k+1)-prs(k))*(100.*pblfrac)
750  CALL pushcontrol1b(0)
751  ELSE
752  CALL pushreal8(wfn)
753  wfn = x1
754  CALL pushcontrol1b(1)
755  END IF
756 !CUMULATIVE PRECIP AND CLOUD-BASE MASS FLUX FOR OUTPUT
757  CALL pushreal8(tem)
758  tem = wfn*gravi
759  rmf(ic) = rmf(ic) + tem
760  ad_from3 = ic + 1
761  DO l=ad_from3,k
762  CALL pushreal8(rmfp(l))
763  rmfp(l) = tem*eta(l)
764  IF (cvw(l) .GT. 0.0) THEN
765  CALL pushcontrol1b(0)
766  ELSE
767  CALL pushcontrol1b(1)
768  END IF
769  END DO
770  CALL pushinteger4(ad_from3)
771  ad_from4 = ic
772 !THETA AND Q CHANGE DUE TO CLOUD TYPE IC
773  DO l=ad_from4,k
774  CALL pushreal8(gmh(l))
775  gmh(l) = gmh(l)*wfn
776  CALL pushreal8(gms(l))
777  gms(l) = gms(l)*wfn
778  CALL pushreal8(qoi(l))
779  qoi(l) = qoi(l) + (gmh(l)-gms(l))*alhi
780  CALL pushreal8(poi(l))
781  poi(l) = poi(l) + gms(l)*pki(l)*cpi
782  CALL pushreal8(qst(l))
783  qst(l) = qst(l) + gms(l)*bet(l)*cpi
784  END DO
785  CALL pushinteger4(ad_from4)
786 !*FRICFAC*0.5
787  CALL pushreal8(wfn)
788  wfn = wfn*0.5*1.0
789 !CUMULUS FRICTION
790  IF (fricfac .LE. 0.0) THEN
791  CALL pushcontrol3b(0)
792  ELSE
793 !================>>
794  CALL pushreal8(wfn)
795  wfn = wfn*fricfac*exp(-(alm/friclambda))
796  CALL pushreal8(tem)
797  tem = wfn*pri(k)
798  ucu(k) = ucu(k) + tem*(uoi(k-1)-uoi(k))
799  vcu(k) = vcu(k) + tem*(voi(k-1)-voi(k))
800  DO l=k-1,ic+1,-1
801  CALL pushreal8(tem)
802  tem = wfn*pri(l)
803  ucu(l) = ucu(l) + tem*((uoi(l-1)-uoi(l))*eta(l)+(&
804 & uoi(l)-uoi(l+1))*eta(l+1))
805  vcu(l) = vcu(l) + tem*((voi(l-1)-voi(l))*eta(l)+(&
806 & voi(l)-voi(l+1))*eta(l+1))
807  END DO
808  CALL pushinteger4(l + 1)
809  CALL pushreal8(tem)
810  tem = wfn*pri(ic)
811  ucu(ic) = ucu(ic) + (2.*(uht-uoi(ic)*(eta(ic)-eta(ic&
812 & +1)))-(uoi(ic)+uoi(ic+1))*eta(ic+1))*tem
813  vcu(ic) = vcu(ic) + (2.*(vht-voi(ic)*(eta(ic)-eta(ic&
814 & +1)))-(voi(ic)+voi(ic+1))*eta(ic+1))*tem
815  ad_from5 = ic
816  DO l=ad_from5,k
817  CALL pushreal8(uoi(l))
818  uoi(l) = uoi(l) + ucu(l)
819  CALL pushreal8(voi(l))
820  voi(l) = voi(l) + vcu(l)
821  END DO
822  CALL pushinteger4(ad_from5)
823  CALL pushcontrol3b(7)
824  END IF
825  END IF
826  END IF
827  END IF
828  END IF
829  END IF
830  END IF
831  END DO
832 !CLOUD LOOP
833  IF (sum(rmf(icmin:k)) .GT. 0.0) THEN
834  DO l=icmin,k
835  CALL pushreal8(tem)
836  END DO
837 !De-strap tendencies from RAS
838  CALL pushreal8array(wght, k0)
839  wght = wgt1(i, :)
840 !Scale properly by layer masses
841  wght0 = 0.
842  DO l=k,k0
843  wght0 = wght0 + wght(l)*(ple(i, l+1)-ple(i, l))
844  END DO
845  wght0 = (prs(k+1)-prs(k))/wght0
846  wght = wght0*wght
847  IF (k .LT. k0) THEN
848  clwb(i, k:k0) = 0.0_8
849  flxdb(i, k:k0) = 0.0_8
850  END IF
851  clwb(i, 1:icmin-1) = 0.0_8
852  flxdb(i, 1:icmin-1) = 0.0_8
853  cllb = 0.0_8
854  cllb(icmin:k) = cllb(icmin:k) + ddt*clwb(i, icmin:k)/daylen
855  rmfdb = 0.0_8
856  rmfdb(icmin:k) = rmfdb(icmin:k) + ddt*flxdb(i, icmin:k)/daylen
857  qoi_svb = 0.0_8
858  uoi_svb = 0.0_8
859  qoib = 0.0_8
860  voib = 0.0_8
861  poib = 0.0_8
862  poi_svb = 0.0_8
863  uoib = 0.0_8
864  voi_svb = 0.0_8
865  DO l=k0,k,-1
866  voib(k) = voib(k) + wght(l)*vhob(i, l)
867  voi_svb(k) = voi_svb(k) - wght(l)*vhob(i, l)
868  uoib(k) = uoib(k) + wght(l)*uhob(i, l)
869  uoi_svb(k) = uoi_svb(k) - wght(l)*uhob(i, l)
870  qoib(k) = qoib(k) + wght(l)*qhob(i, l)
871  qoi_svb(k) = qoi_svb(k) - wght(l)*qhob(i, l)
872  poib(k) = poib(k) + wght(l)*thob(i, l)
873  poi_svb(k) = poi_svb(k) - wght(l)*thob(i, l)
874  END DO
875  CALL popreal8array(wght, k0)
876  updfrcb = 0.0_8
877  updfrcb(icmin:k-1) = updfrcb(icmin:k-1) + cnv_updfrcb(i, icmin:k-1&
878 & )
879  voib(icmin:k-1) = voib(icmin:k-1) + vhob(i, icmin:k-1)
880  vhob(i, icmin:k-1) = 0.0_8
881  uoib(icmin:k-1) = uoib(icmin:k-1) + uhob(i, icmin:k-1)
882  uhob(i, icmin:k-1) = 0.0_8
883  qoib(icmin:k-1) = qoib(icmin:k-1) + qhob(i, icmin:k-1)
884  qhob(i, icmin:k-1) = 0.0_8
885  poib(icmin:k-1) = poib(icmin:k-1) + thob(i, icmin:k-1)
886  thob(i, icmin:k-1) = 0.0_8
887  rnsb = 0.0_8
888  DO l=k,icmin,-1
889  tem = pri(l)*grav
890  rnsb(l) = rnsb(l) + tem*cnv_prc3b(i, l)
891  cnv_prc3b(i, l) = 0.0_8
892  CALL popreal8(tem)
893  END DO
894  ehtb = 0.0_8
895  gm1b = 0.0_8
896  hccb = 0.0_8
897  f2b = 0.0_8
898  cvwb = 0.0_8
899  dqqb = 0.0_8
900  ucub = 0.0_8
901  ghtb = 0.0_8
902  hstb = 0.0_8
903  betb = 0.0_8
904  qhtb = 0.0_8
905  tpertb = 0.0_8
906  qolb = 0.0_8
907  bk2b = 0.0_8
908  rasalb = 0.0_8
909  hcldb = 0.0_8
910  etab = 0.0_8
911  shtb = 0.0_8
912  gmhb = 0.0_8
913  rnnb = 0.0_8
914  qstb = 0.0_8
915  gmsb = 0.0_8
916  vcub = 0.0_8
917  sslb = 0.0_8
918  zetb = 0.0_8
919  updfrpb = 0.0_8
920  zolb = 0.0_8
921  cll0b = 0.0_8
922  holb = 0.0_8
923  rmfpb = 0.0_8
924  gamb = 0.0_8
925  DO ic=icmin+1,k,1
926  CALL popcontrol3b(branch)
927  IF (branch .LT. 4) THEN
928  IF (branch .LT. 2) THEN
929  IF (branch .EQ. 0) THEN
930  wfnb = 0.0_8
931  vhtb = 0.0_8
932  almb = 0.0_8
933  uhtb = 0.0_8
934  ELSE
935  trgb = 0.0_8
936  wlqb = 0.0_8
937  wfnb = 0.0_8
938  vhtb = 0.0_8
939  akmb = 0.0_8
940  tokib = 0.0_8
941  almb = 0.0_8
942  uhtb = 0.0_8
943  GOTO 100
944  END IF
945  ELSE IF (branch .EQ. 2) THEN
946  trgb = 0.0_8
947  wfnb = 0.0_8
948  tokib = 0.0_8
949  almb = 0.0_8
950  GOTO 110
951  ELSE
952  trgb = 0.0_8
953  almb = 0.0_8
954  GOTO 120
955  END IF
956  ELSE IF (branch .LT. 6) THEN
957  IF (branch .EQ. 4) THEN
958  trgb = 0.0_8
959  temb = 0.0_8
960  GOTO 130
961  ELSE
962  trgb = 0.0_8
963  GOTO 140
964  END IF
965  ELSE IF (branch .EQ. 6) THEN
966  trgb = 0.0_8
967  GOTO 150
968  ELSE
969  CALL popinteger4(ad_from5)
970  DO l=k,ad_from5,-1
971  CALL popreal8(voi(l))
972  vcub(l) = vcub(l) + voib(l)
973  CALL popreal8(uoi(l))
974  ucub(l) = ucub(l) + uoib(l)
975  END DO
976  tempb35 = tem*vcub(ic)
977  tempb36 = 2.*tempb35
978  tempb37 = -(eta(ic+1)*tempb35)
979  vhtb = tempb36
980  voib(ic) = voib(ic) + tempb37 - (eta(ic)-eta(ic+1))*tempb36
981  etab(ic) = etab(ic) - voi(ic)*tempb36
982  etab(ic+1) = etab(ic+1) + voi(ic)*tempb36 - (voi(ic)+voi(ic+1))*&
983 & tempb35
984  voib(ic+1) = voib(ic+1) + tempb37
985  temb = (2.*(uht-uoi(ic)*(eta(ic)-eta(ic+1)))-(uoi(ic)+uoi(ic+1))&
986 & *eta(ic+1))*ucub(ic) + (2.*(vht-voi(ic)*(eta(ic)-eta(ic+1)))-(&
987 & voi(ic)+voi(ic+1))*eta(ic+1))*vcub(ic)
988  tempb38 = tem*ucub(ic)
989  tempb39 = 2.*tempb38
990  tempb40 = -(eta(ic+1)*tempb38)
991  uhtb = tempb39
992  uoib(ic) = uoib(ic) + tempb40 - (eta(ic)-eta(ic+1))*tempb39
993  etab(ic) = etab(ic) - uoi(ic)*tempb39
994  etab(ic+1) = etab(ic+1) + uoi(ic)*tempb39 - (uoi(ic)+uoi(ic+1))*&
995 & tempb38
996  uoib(ic+1) = uoib(ic+1) + tempb40
997  CALL popreal8(tem)
998  wfnb = pri(ic)*temb
999  CALL popinteger4(ad_to4)
1000  DO l=ad_to4,k-1,1
1001  tempb31 = tem*vcub(l)
1002  tempb32 = eta(l+1)*tempb31
1003  temb = ((uoi(l-1)-uoi(l))*eta(l)+(uoi(l)-uoi(l+1))*eta(l+1))*&
1004 & ucub(l) + ((voi(l-1)-voi(l))*eta(l)+(voi(l)-voi(l+1))*eta(l+&
1005 & 1))*vcub(l)
1006  voib(l-1) = voib(l-1) + eta(l)*tempb31
1007  voib(l) = voib(l) + tempb32 - eta(l)*tempb31
1008  etab(l) = etab(l) + (voi(l-1)-voi(l))*tempb31
1009  voib(l+1) = voib(l+1) - tempb32
1010  etab(l+1) = etab(l+1) + (voi(l)-voi(l+1))*tempb31
1011  tempb33 = tem*ucub(l)
1012  tempb34 = eta(l+1)*tempb33
1013  uoib(l-1) = uoib(l-1) + eta(l)*tempb33
1014  uoib(l) = uoib(l) + tempb34 - eta(l)*tempb33
1015  etab(l) = etab(l) + (uoi(l-1)-uoi(l))*tempb33
1016  uoib(l+1) = uoib(l+1) - tempb34
1017  etab(l+1) = etab(l+1) + (uoi(l)-uoi(l+1))*tempb33
1018  CALL popreal8(tem)
1019  wfnb = wfnb + pri(l)*temb
1020  END DO
1021  temb = (uoi(k-1)-uoi(k))*ucub(k) + (voi(k-1)-voi(k))*vcub(k)
1022  voib(k-1) = voib(k-1) + tem*vcub(k)
1023  voib(k) = voib(k) - tem*vcub(k)
1024  uoib(k-1) = uoib(k-1) + tem*ucub(k)
1025  uoib(k) = uoib(k) - tem*ucub(k)
1026  CALL popreal8(tem)
1027  wfnb = wfnb + pri(k)*temb
1028  CALL popreal8(wfn)
1029  almb = -(exp(-(alm/friclambda))*wfn*fricfac*wfnb/friclambda)
1030  wfnb = fricfac*exp(-(alm/friclambda))*wfnb
1031  END IF
1032  CALL popreal8(wfn)
1033  wfnb = 0.5*wfnb
1034  temb = 0.0_8
1035  CALL popinteger4(ad_from4)
1036  DO l=k,ad_from4,-1
1037  CALL popreal8(qst(l))
1038  gmsb(l) = gmsb(l) + pki(l)*cpi*poib(l) - alhi*qoib(l) + cpi*bet(&
1039 & l)*qstb(l)
1040  betb(l) = betb(l) + cpi*gms(l)*qstb(l)
1041  CALL popreal8(poi(l))
1042  CALL popreal8(qoi(l))
1043  gmhb(l) = gmhb(l) + alhi*qoib(l)
1044  CALL popreal8(gms(l))
1045  CALL popreal8(gmh(l))
1046  wfnb = wfnb + gmh(l)*gmhb(l) + gms(l)*gmsb(l)
1047  gmsb(l) = wfn*gmsb(l)
1048  gmhb(l) = wfn*gmhb(l)
1049  rnnb(l) = rnnb(l) + tem*rnsb(l)
1050  temb = temb + rnn(l)*rnsb(l)
1051  END DO
1052  CALL popinteger4(ad_from3)
1053  DO l=k,ad_from3,-1
1054  updfrpb(l) = updfrpb(l) + updfrcb(l)
1055  CALL popcontrol1b(branch)
1056  IF (branch .EQ. 0) THEN
1057  temp9 = daylen*prs(l)*cvw(l)
1058  tempb30 = ddt*1000.*updfrpb(l)/temp9
1059  rmfpb(l) = rmfpb(l) + tempb30
1060  cvwb(l) = cvwb(l) - rmfp(l)*daylen*prs(l)*tempb30/temp9
1061  updfrpb(l) = 0.0_8
1062  ELSE
1063  updfrpb(l) = 0.0_8
1064  END IF
1065  CALL popreal8(rmfp(l))
1066  temb = temb + eta(l)*rmfpb(l)
1067  etab(l) = etab(l) + tem*rmfpb(l)
1068  rmfpb(l) = 0.0_8
1069  END DO
1070  temb = temb + wlq*cllb(ic) + eta(ic)*rmfdb(ic)
1071  etab(ic) = etab(ic) + tem*rmfdb(ic)
1072  wlqb = tem*cllb(ic)
1073  CALL popreal8(tem)
1074  wfnb = wfnb + gravi*temb
1075  CALL popcontrol1b(branch)
1076  IF (branch .EQ. 0) THEN
1077  CALL popreal8(wfn)
1078  x1b = 0.0_8
1079  ELSE
1080  CALL popreal8(wfn)
1081  x1b = wfnb
1082  END IF
1083  tempb28 = trg*toki*x1b
1084  tempb29 = rasal(ic)*wfn*x1b
1085  rasalb(ic) = rasalb(ic) + wfn*tempb28
1086  wfnb = rasal(ic)*tempb28
1087  trgb = toki*tempb29
1088  tokib = trg*tempb29
1089  CALL popreal8(wfn)
1090  akmb = (wfn-acr)*wfnb/akm**2
1091  wfnb = -(wfnb/akm)
1092  100 tempb26 = -(dpb(ic)*pki(ic)*akmb)
1093  CALL popreal8(gmh(ic))
1094  tempb24 = pri(ic)*gmhb(ic)
1095  tempb25 = alhl*eta(ic+1)*tempb24
1096  gmsb(ic) = gmsb(ic) + eta(ic+1)*tempb26 + gmhb(ic)
1097  etab(ic+1) = etab(ic+1) + alhl*(qol(ic)-qht(ic+1))*tempb24
1098  qolb(ic) = qolb(ic) + tempb25
1099  qhtb(ic+1) = qhtb(ic+1) - tempb25
1100  etab(ic) = etab(ic) + (hst(ic)-hol(ic))*tempb24
1101  hstb(ic) = hstb(ic) + eta(ic)*tempb24
1102  holb(ic) = holb(ic) - eta(ic)*tempb24
1103  gmhb(ic) = 0.0_8
1104  etab(ic+1) = etab(ic+1) + pri(ic)*(ssl(ic)-sht(ic+1))*gmsb(ic) + &
1105 & gms(ic)*tempb26
1106  CALL popreal8(gms(ic))
1107  tempb27 = pri(ic)*eta(ic+1)*gmsb(ic)
1108  sslb(ic) = sslb(ic) + tempb27
1109  shtb(ic+1) = shtb(ic+1) - tempb27
1110  gmsb(ic) = 0.0_8
1111  tx2b = 0.0_8
1112  CALL popinteger4(ad_to3)
1113  DO l=ad_to3,k-1,1
1114  tx2b = tx2b + ght(l)*akmb
1115  gmhb(l) = gmhb(l) + (eta(l)-eta(l+1))*tx2b
1116  gmsb(l) = gmsb(l) + gmhb(l) - pki(l)*eht(l)*akmb
1117  ehtb(l) = ehtb(l) - pki(l)*gms(l)*akmb
1118  ghtb(l) = ghtb(l) + tx2*akmb
1119  CALL popreal8(tx2)
1120  etab(l) = etab(l) + gmh(l)*tx2b
1121  etab(l+1) = etab(l+1) - gmh(l)*tx2b
1122  CALL popreal8(gmh(l))
1123  tempb20 = alhl*pri(l)*gmhb(l)
1124  tempb21 = eta(l+1)*tempb20
1125  etab(l) = etab(l) + (qht(l)-qol(l))*tempb20
1126  qhtb(l) = qhtb(l) + eta(l)*tempb20
1127  qolb(l) = qolb(l) + tempb21 - eta(l)*tempb20
1128  etab(l+1) = etab(l+1) + (qol(l)-qht(l+1))*tempb20
1129  qhtb(l+1) = qhtb(l+1) - tempb21
1130  gmhb(l) = 0.0_8
1131  CALL popreal8(gms(l))
1132  tempb22 = pri(l)*gmsb(l)
1133  tempb23 = eta(l+1)*tempb22
1134  etab(l) = etab(l) + (sht(l)-ssl(l))*tempb22
1135  shtb(l) = shtb(l) + eta(l)*tempb22
1136  sslb(l) = sslb(l) + tempb23 - eta(l)*tempb22
1137  etab(l+1) = etab(l+1) + (ssl(l)-sht(l+1))*tempb22
1138  shtb(l+1) = shtb(l+1) - tempb23
1139  gmsb(l) = 0.0_8
1140  END DO
1141  tempb18 = dpb(k-1)*akmb
1142  CALL popreal8(tx2)
1143  gmhb(k) = gmhb(k) + gam(k-1)*tempb18 + tx2b
1144  CALL popreal8(akm)
1145  gamb(k-1) = gamb(k-1) + gmh(k)*tempb18
1146  CALL popreal8(gmh(k))
1147  tempb19 = pri(k)*alhl*gmhb(k)
1148  gmsb(k) = gmsb(k) + gmhb(k)
1149  qhtb(k) = qhtb(k) + tempb19
1150  qolb(k) = qolb(k) - tempb19
1151  gmhb(k) = 0.0_8
1152  CALL popreal8(gms(k))
1153  shtb(k) = shtb(k) + pri(k)*gmsb(k)
1154  sslb(k) = sslb(k) - pri(k)*gmsb(k)
1155  gmsb(k) = 0.0_8
1156  qstb(ic) = qstb(ic) - eta(ic)*wlqb
1157  etab(ic) = etab(ic) - qst(ic)*wlqb
1158  CALL popinteger4(ad_to2)
1159  DO l=ad_to2,k-1,1
1160  CALL popcontrol1b(branch)
1161  IF (branch .EQ. 0) THEN
1162  CALL popreal8(rnn(l))
1163  rnnb(l) = 0.0_8
1164  clossb = 0.0_8
1165  ELSE
1166  CALL popreal8(rnn(l))
1167  clossb = rnnb(l) - wlqb
1168  rnnb(l) = 0.0_8
1169  END IF
1170  clossb = clossb - cll0b(l)
1171  CALL popcontrol1b(branch)
1172  IF (branch .EQ. 0) THEN
1173  dt_lyr = (zet(l)-zet(l+1))/cvw_x
1174  cll0b(l) = cll0b(l) + clossb
1175  clossb = 0.0_8
1176  ELSE
1177  dt_lyr = (zet(l)-zet(l+1))/cvw_x
1178  END IF
1179  cll0b(l) = cll0b(l) + rate*dt_lyr*clossb
1180  rateb = cll0(l)*dt_lyr*clossb
1181  dt_lyrb = cll0(l)*rate*clossb
1182  tempb17 = dt_lyrb/cvw_x
1183  zetb(l) = zetb(l) + tempb17
1184  zetb(l+1) = zetb(l+1) - tempb17
1185  cvw_xb = -((zet(l)-zet(l+1))*tempb17/cvw_x)
1186  CALL popcontrol1b(branch)
1187  IF (branch .EQ. 0) THEN
1188  CALL popreal8(cvw_x)
1189  ELSE
1190  CALL popreal8(cvw_x)
1191  cvwb(l) = cvwb(l) + cvw_xb
1192  END IF
1193  cli_crit_x = cli_crit/(f2*f3)
1194  cli = cll0(l)/eta(l)
1195  CALL popreal8(rate)
1196  temp8 = cli_crit_x**2
1197  temp7 = cli**2/temp8
1198  tempb15 = exp(-temp7)*c00_x*rateb/temp8
1199  c00_xb = (1.0-exp(-temp7))*rateb
1200  clib = 2*cli*tempb15
1201  cli_crit_xb = -(temp7*2*cli_crit_x*tempb15)
1202  f2b = f2b + f3*f4*co_auto(i)*c00_xb - cli_crit*cli_crit_xb/(f3*&
1203 & f2**2)
1204  CALL popreal8(c00_x)
1205  te_a = poi(l)*prh(l)
1206  CALL popreal8(f2)
1207  CALL popreal8(f3)
1208  CALL sundq3_ice_b(te_a, te_ab, sdqv2, sdqv3, sdqvt1, f2, f2b, f3&
1209 & )
1210  poib(l) = poib(l) + prh(l)*te_ab
1211  tempb16 = clib/eta(l)
1212  cll0b(l) = cll0b(l) + tempb16
1213  etab(l) = etab(l) - cll0(l)*tempb16/eta(l)
1214  CALL popcontrol1b(branch)
1215  IF (branch .EQ. 0) cll0b(l) = 0.0_8
1216  CALL popcontrol1b(branch)
1217  IF (branch .EQ. 0) THEN
1218  CALL popreal8(cll0(l))
1219  wlqb = wlqb + cll0b(l)
1220  qstb(ic) = qstb(ic) - eta(ic)*cll0b(l)
1221  etab(ic) = etab(ic) - qst(ic)*cll0b(l)
1222  cll0b(l) = 0.0_8
1223  ELSE
1224  CALL popreal8(cll0(l))
1225  wlqb = wlqb + cll0b(l)
1226  qccb = -cll0b(l)
1227  cll0b(l) = 0.0_8
1228  tx2b = qccb
1229  gm1b(l) = gm1b(l) + (hcc(l)-tx3)*qccb
1230  hccb(l) = hccb(l) + gm1(l)*qccb
1231  tx3b = -(gm1(l)*qccb)
1232  CALL popreal8(tx3)
1233  tempb13 = 0.5*eta(l)*tx3b
1234  hstb(l) = hstb(l) + tempb13
1235  hstb(l-1) = hstb(l-1) + tempb13
1236  etab(l) = etab(l) + 0.5*(qst(l)+qst(l-1))*tx2b + 0.5*(hst(l)+&
1237 & hst(l-1))*tx3b
1238  CALL popreal8(tx2)
1239  tempb14 = 0.5*eta(l)*tx2b
1240  qstb(l) = qstb(l) + tempb14
1241  qstb(l-1) = qstb(l-1) + tempb14
1242  END IF
1243  tem = eta(l) - eta(l+1)
1244  temb = uoi(l)*uhtb + qol(l)*wlqb + voi(l)*vhtb
1245  voib(l) = voib(l) + tem*vhtb
1246  uoib(l) = uoib(l) + tem*uhtb
1247  qolb(l) = qolb(l) + tem*wlqb
1248  CALL popreal8(tem)
1249  etab(l) = etab(l) + temb
1250  etab(l+1) = etab(l+1) - temb
1251  END DO
1252  cll0b(k) = 0.0_8
1253  CALL popreal8(rnn(k))
1254  rnnb(k) = 0.0_8
1255  CALL popreal8(vht)
1256  voib(k) = voib(k) + vhtb
1257  CALL popreal8(uht)
1258  uoib(k) = uoib(k) + uhtb
1259  CALL popreal8(wlq)
1260  qolb(k) = qolb(k) + wlqb
1261  110 CALL popreal8(acr)
1262  CALL popinteger4(ad_from2)
1263  DO l=k,ad_from2,-1
1264  CALL popcontrol1b(branch)
1265  IF (branch .EQ. 0) THEN
1266  CALL popreal8(cvw(l))
1267  cvwb(l) = 0.0_8
1268  ELSE
1269  CALL popreal8(cvw(l))
1270  END IF
1271  END DO
1272  CALL popreal8(rasal(ic))
1273  rasalb(ic) = -(dt*rasalb(ic)/rasal(ic)**2)
1274  CALL popcontrol1b(branch)
1275  IF (branch .EQ. 0) rasalb(ic) = 0.0_8
1276  CALL popcontrol1b(branch)
1277  IF (branch .NE. 0) THEN
1278  zetb(ic) = zetb(ic) + (rasal2-rasal1)*rasalb(ic)/8000.
1279  rasalb(ic) = 0.0_8
1280  END IF
1281  CALL popcontrol1b(branch)
1282  IF (branch .EQ. 0) rasalb(ic) = 0.0_8
1283  CALL popinteger4(ad_to1)
1284  DO l=ad_to1,k-1,1
1285  CALL popreal8(cvw(l))
1286  IF (2.0*max2 .EQ. 0.0) THEN
1287  max2b = 0.0
1288  ELSE
1289  max2b = cvwb(l)/sqrt(2.0*max2)
1290  END IF
1291  cvwb(l) = 0.0_8
1292  CALL popcontrol1b(branch)
1293  IF (branch .EQ. 0) THEN
1294  CALL popreal8(max2)
1295  ELSE
1296  CALL popreal8(max2)
1297  bk2b(l) = bk2b(l) + max2b
1298  END IF
1299  temp6 = cp*prj(l+1)
1300  temp5 = temp6*poi(l)
1301  tempb12 = grav*bk2b(l)/temp5
1302  bk2b(l+1) = bk2b(l+1) + bk2b(l)
1303  max1b = tempb12
1304  poib(l) = poib(l) - max1*temp6*tempb12/temp5
1305  bk2b(l) = 0.0_8
1306  CALL popcontrol1b(branch)
1307  IF (branch .EQ. 0) THEN
1308  CALL popreal8(max1)
1309  temb = 0.0_8
1310  ELSE
1311  CALL popreal8(max1)
1312  temb = max1b
1313  END IF
1314  CALL popreal8(tem)
1315  temp4 = lbcp*dqq(l) + 1.0
1316  tempb10 = temb/temp4
1317  temp3 = zet(l) - zet(l+1)
1318  temp2 = hcld(l) - hst(l)
1319  hcldb(l) = hcldb(l) + temp3*tempb10
1320  hstb(l) = hstb(l) - temp3*tempb10
1321  zetb(l) = zetb(l) + temp2*tempb10
1322  zetb(l+1) = zetb(l+1) - temp2*tempb10
1323  dqqb(l) = dqqb(l) - temp2*temp3*lbcp*tempb10/temp4
1324  CALL popreal8(hcld(l))
1325  tempb11 = hcldb(l)/eta(l)
1326  etab(l+1) = etab(l+1) + (hcld(l+1)-hol(l))*tempb11
1327  hcldb(l+1) = hcldb(l+1) + eta(l+1)*tempb11
1328  etab(l) = etab(l) + (hol(l)-(eta(l+1)*hcld(l+1)+(eta(l)-eta(l+1)&
1329 & )*hol(l))/eta(l))*tempb11
1330  holb(l) = holb(l) + (eta(l)-eta(l+1))*tempb11
1331  hcldb(l) = 0.0_8
1332  END DO
1333  CALL popreal8(hcld(k))
1334  holb(k) = holb(k) + hcldb(k)
1335  hcldb(k) = 0.0_8
1336  bk2b(k) = 0.0_8
1337  tempb9 = dpb(ic)*gam(ic)*wfnb
1338  hccb(ic+1) = hccb(ic+1) + tempb9
1339  hstb(ic) = hstb(ic) + eta(ic)*hccb(ic) - eta(ic+1)*tempb9
1340  etab(ic+1) = etab(ic+1) - hst(ic)*tempb9
1341  gamb(ic) = gamb(ic) + dpb(ic)*(hcc(ic+1)-hst(ic)*eta(ic+1))*wfnb
1342  CALL popreal8(hcc(ic))
1343  etab(ic) = etab(ic) + hst(ic)*hccb(ic)
1344  hccb(ic) = 0.0_8
1345  CALL popinteger4(ad_to0)
1346  DO l=ad_to0,k-1,1
1347  tem = hcc(l+1)*dpb(l) + hcc(l)*dpt(l)
1348  tempb8 = gam(l)*wfnb
1349  temb = tempb8
1350  ehtb(l) = ehtb(l) - hst(l)*tempb8
1351  hstb(l) = hstb(l) - eht(l)*tempb8
1352  gamb(l) = gamb(l) + (tem-eht(l)*hst(l))*wfnb
1353  CALL popreal8(eht(l))
1354  etab(l+1) = etab(l+1) + dpb(l)*ehtb(l)
1355  CALL popreal8(tem)
1356  hccb(l+1) = hccb(l+1) + dpb(l)*temb
1357  hccb(l) = hccb(l) + dpt(l)*temb
1358  CALL popreal8(hcc(l))
1359  hccb(l+1) = hccb(l+1) + hccb(l)
1360  etab(l) = etab(l) + hol(l)*hccb(l) + dpt(l)*ehtb(l)
1361  ehtb(l) = 0.0_8
1362  etab(l+1) = etab(l+1) - hol(l)*hccb(l)
1363  holb(l) = holb(l) + (eta(l)-eta(l+1))*hccb(l)
1364  hccb(l) = 0.0_8
1365  END DO
1366  CALL popreal8(hcc(k))
1367  holb(k) = holb(k) + hccb(k)
1368  hccb(k) = 0.0_8
1369  CALL popreal8(eta(ic))
1370  almb = almb + (zol(ic)-zet(k))*etab(ic)
1371  zolb(ic) = zolb(ic) + alm*etab(ic)
1372  zetb(k) = zetb(k) - alm*etab(ic)
1373  etab(ic) = 0.0_8
1374  CALL popinteger4(ad_from1)
1375  DO l=k,ad_from1,-1
1376  CALL popreal8(eta(l))
1377  almb = almb + (zet(l)-zet(k))*etab(l)
1378  zetb(l) = zetb(l) + alm*etab(l)
1379  zetb(k) = zetb(k) - alm*etab(l)
1380  etab(l) = 0.0_8
1381  END DO
1382  CALL popcontrol1b(branch)
1383  IF (branch .NE. 0) almb = almb + 2*alm*tokib/lambda_min**2
1384  CALL popreal8(toki)
1385  120 CALL popreal8(alm)
1386  tempb7 = almb/tem
1387  holb(k) = holb(k) + tempb7
1388  hstb(ic) = hstb(ic) - tempb7
1389  temb = -((hol(k)-hst(ic))*tempb7/tem)
1390  130 CALL popinteger4(ad_from0)
1391  DO l=k-1,ad_from0,-1
1392  tempb5 = (zet(l)-zet(l+1))*temb
1393  tempb6 = (hst(ic)-hol(l))*temb
1394  hstb(ic) = hstb(ic) + tempb5
1395  holb(l) = holb(l) - tempb5
1396  zetb(l) = zetb(l) + tempb6
1397  zetb(l+1) = zetb(l+1) - tempb6
1398  END DO
1399  CALL popreal8(tem)
1400  tempb3 = (zol(ic)-zet(ic+1))*temb
1401  tempb4 = (hst(ic)-hol(ic))*temb
1402  hstb(ic) = hstb(ic) + tempb3
1403  holb(ic) = holb(ic) - tempb3
1404  zolb(ic) = zolb(ic) + tempb4
1405  zetb(ic+1) = zetb(ic+1) - tempb4
1406  140 CALL popreal8(lambda_min)
1407  CALL popinteger4(ad_from)
1408  DO l=k,ad_from,-1
1409  CALL popreal8(qht(l))
1410  qolb(l) = qolb(l) + .5*qhtb(l)
1411  qolb(l-1) = qolb(l-1) + .5*qhtb(l)
1412  qhtb(l) = 0.0_8
1413  tem = (prj(l)-prh(l-1))/(prh(l)-prh(l-1))
1414  CALL popreal8(sht(l))
1415  sslb(l-1) = sslb(l-1) + (1.0_8-tem)*shtb(l)
1416  sslb(l) = sslb(l) + tem*shtb(l)
1417  shtb(l) = 0.0_8
1418  CALL popreal8(tem)
1419  END DO
1420  poi_cb = 0.0_8
1421  qoi_cb = 0.0_8
1422  CALL popinteger4(ad_to)
1423  DO l=ad_to,k,1
1424  sslb(l) = sslb(l) + holb(l) + hstb(l)
1425  CALL popreal8(zol(l))
1426  zetb(l+1) = zetb(l+1) + zetb(l) + zolb(l)
1427  CALL popreal8(zet(l))
1428  temb = zetb(l)
1429  poi_cb(l) = poi_cb(l) + (prj(l+1)-prj(l))*cpbg*temb + prj(l+1)*&
1430 & cp*sslb(l) + (prj(l+1)-prh(l))*cpbg*zolb(l)
1431  zolb(l) = 0.0_8
1432  zetb(l) = 0.0_8
1433  CALL popreal8(tem)
1434  CALL popreal8(hst(l))
1435  qstb(l) = qstb(l) + alhl*hstb(l)
1436  hstb(l) = 0.0_8
1437  CALL popreal8(hol(l))
1438  qolb(l) = qolb(l) + alhl*holb(l)
1439  holb(l) = 0.0_8
1440  CALL popreal8(ssl(l))
1441  zetb(l+1) = zetb(l+1) + grav*sslb(l)
1442  sslb(l) = 0.0_8
1443  CALL popcontrol1b(branch)
1444  IF (branch .NE. 0) qolb(l) = 0.0_8
1445  CALL popcontrol1b(branch)
1446  IF (branch .EQ. 0) THEN
1447  CALL popreal8(qol(l))
1448  qoi_cb(l) = qoi_cb(l) + qolb(l)
1449  qolb(l) = 0.0_8
1450  ELSE
1451  CALL popreal8(qol(l))
1452  qstb(l) = qstb(l) + rhmax*qolb(l)
1453  qolb(l) = 0.0_8
1454  END IF
1455  END DO
1456  CALL popreal8(sht(k+1))
1457  poi_cb(k) = poi_cb(k) + prj(k+1)*cp*shtb(k+1)
1458  shtb(k+1) = 0.0_8
1459  CALL popreal8(zet(k+1))
1460  zetb(k+1) = 0.0_8
1461  tpertb = tpertb + poi_cb(k)
1462  qoib = qoib + qoi_cb
1463  poib = poib + poi_cb
1464  150 CALL popcontrol1b(branch)
1465  IF (branch .EQ. 0) THEN
1466  CALL popreal8(f4)
1467  ELSE
1468  CALL popreal8(f4)
1469  END IF
1470  CALL popcontrol1b(branch)
1471  IF (branch .EQ. 0) THEN
1472  CALL popreal8(trg)
1473  tempb2 = trgb/((rhmx-rhmn)*qst(k))
1474  qoib(k) = qoib(k) + tempb2
1475  qstb(k) = qstb(k) - qoi(k)*tempb2/qst(k)
1476  ELSE
1477  CALL popreal8(trg)
1478  END IF
1479  vcub(icmin:k0) = 0.0_8
1480  ucub(icmin:k0) = 0.0_8
1481  END DO
1482  DO l=icmin,k,1
1483  sslb(l) = sslb(l) + holb(l) + hstb(l)
1484  zetb(l+1) = zetb(l+1) + zetb(l) + zolb(l)
1485  temb = zetb(l)
1486  poib(l) = poib(l) + (prj(l+1)-prj(l))*cpbg*temb + prj(l+1)*cp*sslb&
1487 & (l) + (prj(l+1)-prh(l))*cpbg*zolb(l)
1488  zolb(l) = 0.0_8
1489  zetb(l) = 0.0_8
1490  qstb(l) = qstb(l) + alhl*hstb(l)
1491  hstb(l) = 0.0_8
1492  qolb(l) = qolb(l) + alhl*holb(l)
1493  holb(l) = 0.0_8
1494  zetb(l+1) = zetb(l+1) + grav*sslb(l)
1495  sslb(l) = 0.0_8
1496  CALL popcontrol1b(branch)
1497  IF (branch .NE. 0) qolb(l) = 0.0_8
1498  CALL popcontrol1b(branch)
1499  IF (branch .EQ. 0) THEN
1500  qoib(l) = qoib(l) + qolb(l)
1501  qolb(l) = 0.0_8
1502  ELSE
1503  qstb(l) = qstb(l) + rhmax*qolb(l)
1504  qolb(l) = 0.0_8
1505  END IF
1506  END DO
1507  poib(k) = poib(k) + prj(k+1)*cp*shtb(k+1)
1508  voib = voib + voi_svb
1509  uoib = uoib + uoi_svb
1510  qoib = qoib + qoi_svb
1511  poib = poib + poi_svb
1512  DO l=icmin,k,1
1513  CALL popcontrol1b(branch)
1514  IF (branch .NE. 0) THEN
1515  temp1 = alhl*(lbcp*dqq(l+1)+1.0)
1516  temp0 = alhl*(lbcp*dqq(l)+1.0)
1517  tempb = lbcp*0.5*gm1b(l+1)
1518  tempb0 = tempb/temp0
1519  tempb1 = tempb/temp1
1520  dqqb(l) = dqqb(l) + (1.0_8-alhl*dqq(l)*lbcp/temp0)*tempb0
1521  dqqb(l+1) = dqqb(l+1) + (1.0_8-alhl*dqq(l+1)*lbcp/temp1)*tempb1
1522  gm1b(l+1) = 0.0_8
1523  gamb(l) = gamb(l) + dpb(l)*ghtb(l+1)
1524  gamb(l+1) = gamb(l+1) + dpt(l+1)*ghtb(l+1)
1525  ghtb(l+1) = 0.0_8
1526  END IF
1527  temp = lbcp*dqq(l) + 1.0
1528  dqqb(l) = dqqb(l) + pki(l)*betb(l) - pki(l)*lbcp*gamb(l)/temp**2
1529  gamb(l) = 0.0_8
1530  betb(l) = 0.0_8
1531  END DO
1532  CALL popcontrol1b(branch)
1533  IF (branch .NE. 0) THEN
1534  CALL dqsats_ras_b(dqq(k), dqqb(k), qst(k), qstb(k), arg1, arg1b, &
1535 & pol(k), estblx, cons_h2omw, cons_airmw)
1536  dqqb(k) = 0.0_8
1537  qstb(k) = 0.0_8
1538  poib(k) = poib(k) + prh(k)*arg1b
1539  DO l=k0,k,-1
1540  vhob(i, l) = vhob(i, l) + wght(l)*voib(k)
1541  uhob(i, l) = uhob(i, l) + wght(l)*uoib(k)
1542  qhob(i, l) = qhob(i, l) + wght(l)*qoib(k)
1543  thob(i, l) = thob(i, l) + wght(l)*poib(k)
1544  END DO
1545  voib(k) = 0.0_8
1546  uoib(k) = 0.0_8
1547  qoib(k) = 0.0_8
1548  poib(k) = 0.0_8
1549  END IF
1550  dqsb = 0.0_8
1551  dqsb(icmin:k) = dqsb(icmin:k) + dqqb(icmin:k)
1552  qssb = 0.0_8
1553  qssb(icmin:k) = qssb(icmin:k) + qstb(icmin:k)
1554  vhob(i, icmin:k) = vhob(i, icmin:k) + voib(icmin:k)
1555  uhob(i, icmin:k) = uhob(i, icmin:k) + uoib(icmin:k)
1556  qhob(i, icmin:k) = qhob(i, icmin:k) + qoib(icmin:k)
1557  thob(i, icmin:k) = thob(i, icmin:k) + poib(icmin:k)
1558  CALL dqsat_ras_b(dqs, dqsb, qss, qssb, tempf, tempfb, pf, k0, estblx&
1559 & , cons_h2omw, cons_airmw)
1560  CALL popcontrol2b(branch)
1561  IF (branch .LT. 2) THEN
1562  IF (branch .NE. 0) tpertb = 0.0_8
1563  ELSE IF (branch .NE. 2) THEN
1564  tpertb = 0.0_8
1565  END IF
1566  CALL popcontrol1b(branch)
1567  IF (branch .EQ. 0) tpertb = 0.0_8
1568  zlob = 0.0_8
1569  tempfb(k0) = tempfb(k0) - cbl_tpert*tpertb
1570  zlob(k0) = zlob(k0) - cons_grav*cbl_tpert*tpertb/cons_cp
1571  zleb = 0.0_8
1572  DO l=1,k0,1
1573  zlob(l) = zlob(l) + zleb(l)
1574  zleb(l) = cons_cp*(pk(l)-pke(l))*zleb(l)/cons_grav
1575  zleb(l+1) = zleb(l+1) + zlob(l)
1576  zleb(l) = zleb(l) + cons_cp*(pke(l+1)-pk(l))*zlob(l)/cons_grav
1577  zlob(l) = 0.0_8
1578  thob(i, l) = thob(i, l) + (cons_vireps*qho(i, l)+1.)*zleb(l)
1579  qhob(i, l) = qhob(i, l) + tho(i, l)*cons_vireps*zleb(l)
1580  zleb(l) = 0.0_8
1581  END DO
1582  thob(i, :) = thob(i, :) + pk*tempfb
1583  END IF
1584  clwb = 0.0_8
1585  cnv_prc3b = 0.0_8
1586  cnv_updfrcb = 0.0_8
1587  flxdb = 0.0_8
1588  ELSE
1589  qoi_svb = 0.0_8
1590  uoi_svb = 0.0_8
1591  qoib = 0.0_8
1592  voib = 0.0_8
1593  updfrcb = 0.0_8
1594  poib = 0.0_8
1595  rnsb = 0.0_8
1596  poi_svb = 0.0_8
1597  uoib = 0.0_8
1598  rmfdb = 0.0_8
1599  voi_svb = 0.0_8
1600  cllb = 0.0_8
1601  END IF
1602 END SUBROUTINE rase_b
1603 
1604 ! Differentiation of sundq3_ice in reverse (adjoint) mode:
1605 ! gradient of useful results: f2
1606 ! with respect to varying inputs: temp f2
1607 SUBROUTINE sundq3_ice_b(temp, tempb, rate2, rate3, te1, f2, f2b, f3)
1608  IMPLICIT NONE
1609  REAL*8, INTENT(IN) :: temp, rate2, rate3, te1
1610  REAL*8 :: tempb
1611  REAL*8 :: f2, f3
1612  REAL*8 :: f2b
1613 !,RATE2,RATE3,TE1
1614  REAL*8 :: xx, yy, te0, te2, jump1
1615  INTEGER :: branch
1616  te0 = 273.
1617  te2 = 200.
1618  jump1 = (rate2-1.0)/(te0-te1)**0.333
1619 ! Ice - phase treatment
1620  IF (temp .GE. te0) THEN
1621  CALL pushreal8(f2)
1622  f2 = 1.0
1623  CALL pushcontrol1b(0)
1624  ELSE
1625  CALL pushcontrol1b(1)
1626  END IF
1627  IF (temp .GE. te1 .AND. temp .LT. te0) THEN
1628  CALL pushreal8(f2)
1629  f2 = 1.0 + jump1*(te0-temp)**0.3333
1630  CALL pushcontrol1b(0)
1631  ELSE
1632  CALL pushcontrol1b(1)
1633  END IF
1634  IF (temp .LT. te1) THEN
1635  CALL pushreal8(f2)
1636  f2 = rate2 + (rate3-rate2)*(te1-temp)/(te1-te2)
1637  CALL pushcontrol1b(0)
1638  ELSE
1639  CALL pushcontrol1b(1)
1640  END IF
1641  IF (f2 .GT. 27.0) f2b = 0.0_8
1642  CALL popcontrol1b(branch)
1643  IF (branch .EQ. 0) THEN
1644  CALL popreal8(f2)
1645  tempb = -((rate3-rate2)*f2b/(te1-te2))
1646  f2b = 0.0_8
1647  ELSE
1648  tempb = 0.0_8
1649  END IF
1650  CALL popcontrol1b(branch)
1651  IF (branch .EQ. 0) THEN
1652  CALL popreal8(f2)
1653  tempb = tempb - 0.3333*(te0-temp)**(-0.6667)*jump1*f2b
1654  f2b = 0.0_8
1655  END IF
1656  CALL popcontrol1b(branch)
1657  IF (branch .EQ. 0) THEN
1658  CALL popreal8(f2)
1659  f2b = 0.0_8
1660  END IF
1661 END SUBROUTINE sundq3_ice_b
1662 
1663 ! Differentiation of dqsat_ras in reverse (adjoint) mode:
1664 ! gradient of useful results: dqsi qssi
1665 ! with respect to varying inputs: temp
1666 SUBROUTINE dqsat_ras_b(dqsi, dqsib, qssi, qssib, temp, tempb, plo, lm, &
1667 & estblx, cons_h2omw, cons_airmw)
1668  IMPLICIT NONE
1669 !Inputs
1670  INTEGER :: lm
1671  REAL*8, DIMENSION(lm) :: temp, plo
1672  REAL*8, DIMENSION(lm) :: tempb
1673  REAL*8 :: estblx(:)
1674  REAL*8 :: cons_h2omw, cons_airmw
1675 !Outputs
1676  REAL*8, DIMENSION(lm) :: dqsi, qssi
1677  REAL*8, DIMENSION(lm) :: dqsib, qssib
1678 !Locals
1679  REAL*8, PARAMETER :: max_mixing_ratio=1.0
1680  REAL*8 :: esfac
1681  INTEGER :: k
1682  REAL*8 :: tl, tt, ti, dqsat, qsat, dqq, qq, pl, pp, dd
1683  REAL*8 :: tlb, ttb, tib, dqsatb, qsatb, qqb, ddb
1684  INTEGER :: it
1685  INTEGER, PARAMETER :: degsubs=100
1686  REAL*8, PARAMETER :: tmintbl=150.0, tmaxtbl=333.0
1687  INTEGER, PARAMETER :: tablesize=nint(tmaxtbl-tmintbl)*degsubs+1
1688  INTRINSIC nint
1689  INTRINSIC int
1690  INTEGER :: branch
1691  REAL*8 :: temp0
1692  esfac = cons_h2omw/cons_airmw
1693  DO k=1,lm
1694  tl = temp(k)
1695  pl = plo(k)
1696  pp = pl*100.0
1697  IF (tl .LE. tmintbl) THEN
1698  ti = tmintbl
1699  CALL pushcontrol2b(0)
1700  ELSE IF (tl .GE. tmaxtbl - .001) THEN
1701  ti = tmaxtbl - .001
1702  CALL pushcontrol2b(1)
1703  ELSE
1704  ti = tl
1705  CALL pushcontrol2b(2)
1706  END IF
1707  tt = (ti-tmintbl)*degsubs + 1
1708  it = int(tt)
1709  CALL pushreal8(dqq)
1710  dqq = estblx(it+1) - estblx(it)
1711  CALL pushreal8(qq)
1712  qq = (tt-it)*dqq + estblx(it)
1713  IF (pp .LE. qq) THEN
1714  CALL pushcontrol1b(0)
1715  ELSE
1716  CALL pushcontrol1b(1)
1717  END IF
1718  END DO
1719  tempb = 0.0_8
1720  DO k=lm,1,-1
1721  qsatb = qssib(k)
1722  qssib(k) = 0.0_8
1723  dqsatb = dqsib(k)
1724  dqsib(k) = 0.0_8
1725  CALL popcontrol1b(branch)
1726  IF (branch .EQ. 0) THEN
1727  qqb = 0.0_8
1728  ELSE
1729  pl = plo(k)
1730  pp = pl*100.0
1731  dd = 1.0/(pp-(1.0-esfac)*qq)
1732  ddb = esfac*qq*qsatb + esfac*degsubs*dqq*pp*2*dd*dqsatb
1733  temp0 = pp - (-esfac+1.0)*qq
1734  qqb = (1.0-esfac)*ddb/temp0**2 + esfac*dd*qsatb
1735  END IF
1736  CALL popreal8(qq)
1737  ttb = dqq*qqb
1738  CALL popreal8(dqq)
1739  tib = degsubs*ttb
1740  CALL popcontrol2b(branch)
1741  IF (branch .EQ. 0) THEN
1742  tlb = 0.0_8
1743  ELSE IF (branch .EQ. 1) THEN
1744  tlb = 0.0_8
1745  ELSE
1746  tlb = tib
1747  END IF
1748  tempb(k) = tempb(k) + tlb
1749  END DO
1750 END SUBROUTINE dqsat_ras_b
1751 
1752 ! Differentiation of dqsats_ras in reverse (adjoint) mode:
1753 ! gradient of useful results: dqsi qssi
1754 ! with respect to varying inputs: temp
1755 SUBROUTINE dqsats_ras_b(dqsi, dqsib, qssi, qssib, temp, tempb, plo, &
1756 & estblx, cons_h2omw, cons_airmw)
1757  IMPLICIT NONE
1758 !Inputs
1759  REAL*8 :: temp, plo
1760  REAL*8 :: tempb
1761  REAL*8 :: estblx(:)
1762  REAL*8 :: cons_h2omw, cons_airmw
1763 !Outputs
1764  REAL*8 :: dqsi, qssi
1765  REAL*8 :: dqsib, qssib
1766 !Locals
1767  REAL*8, PARAMETER :: max_mixing_ratio=1.0
1768  REAL*8 :: esfac
1769  REAL*8 :: tl, tt, ti, dqsat, qsat, dqq, qq, pl, pp, dd
1770  REAL*8 :: tlb, ttb, tib, dqsatb, qsatb, qqb, ddb
1771  INTEGER :: it
1772  INTEGER, PARAMETER :: degsubs=100
1773  REAL*8, PARAMETER :: tmintbl=150.0, tmaxtbl=333.0
1774  INTEGER, PARAMETER :: tablesize=nint(tmaxtbl-tmintbl)*degsubs+1
1775  INTRINSIC nint
1776  INTRINSIC int
1777  INTEGER :: branch
1778  REAL*8 :: temp0
1779  esfac = cons_h2omw/cons_airmw
1780  tl = temp
1781  pl = plo
1782  pp = pl*100.0
1783  IF (tl .LE. tmintbl) THEN
1784  ti = tmintbl
1785  CALL pushcontrol2b(0)
1786  ELSE IF (tl .GE. tmaxtbl - .001) THEN
1787  ti = tmaxtbl - .001
1788  CALL pushcontrol2b(1)
1789  ELSE
1790  ti = tl
1791  CALL pushcontrol2b(2)
1792  END IF
1793  tt = (ti-tmintbl)*degsubs + 1
1794  it = int(tt)
1795  dqq = estblx(it+1) - estblx(it)
1796  qq = (tt-it)*dqq + estblx(it)
1797  IF (pp .LE. qq) THEN
1798  CALL pushcontrol1b(0)
1799  ELSE
1800  dd = 1.0/(pp-(1.0-esfac)*qq)
1801  CALL pushcontrol1b(1)
1802  END IF
1803  qsatb = qssib
1804  dqsatb = dqsib
1805  CALL popcontrol1b(branch)
1806  IF (branch .EQ. 0) THEN
1807  qqb = 0.0_8
1808  ELSE
1809  temp0 = pp - (-esfac+1.0)*qq
1810  ddb = esfac*qq*qsatb + esfac*degsubs*dqq*pp*2*dd*dqsatb
1811  qqb = (1.0-esfac)*ddb/temp0**2 + esfac*dd*qsatb
1812  END IF
1813  ttb = dqq*qqb
1814  tib = degsubs*ttb
1815  CALL popcontrol2b(branch)
1816  IF (branch .EQ. 0) THEN
1817  tlb = 0.0_8
1818  ELSE IF (branch .EQ. 1) THEN
1819  tlb = 0.0_8
1820  ELSE
1821  tlb = tib
1822  END IF
1823  tempb = tlb
1824 END SUBROUTINE dqsats_ras_b
1825 
1826 SUBROUTINE rase_tracer_b(idim, irun, k0, icmin, dt, cons_cp, cons_alhl, &
1827 & cons_grav, cons_rgas, cons_h2omw, cons_airmw, cons_vireps, seedras, &
1828 & sige, kcbl, wgt0, wgt1, frland, ts, thoin, qhoin, uhoin, vhoin, &
1829 & co_auto, ple, rasparams, estblx, itrcr, xho, xhob, fscav)
1830  IMPLICIT NONE
1831 !INPUTS
1832  INTEGER, INTENT(IN) :: idim, irun, k0, icmin
1833  REAL*8, DIMENSION(idim, k0 + 1), INTENT(IN) :: ple
1834  REAL*8, DIMENSION(k0 + 1), INTENT(IN) :: sige
1835  REAL*8, INTENT(IN) :: dt, cons_cp, cons_alhl, cons_grav, cons_rgas
1836  REAL*8, INTENT(IN) :: cons_h2omw, cons_airmw, cons_vireps
1837  INTEGER, DIMENSION(idim), INTENT(IN) :: seedras
1838  INTEGER, DIMENSION(idim), INTENT(IN) :: kcbl
1839  REAL*8, DIMENSION(idim), INTENT(IN) :: ts, frland
1840  REAL*8, DIMENSION(idim), INTENT(IN) :: co_auto
1841  REAL*8, DIMENSION(idim, k0), INTENT(IN) :: wgt0, wgt1
1842  REAL*8, DIMENSION(:), INTENT(IN) :: rasparams
1843  REAL*8, DIMENSION(:), INTENT(IN) :: estblx
1844  INTEGER, INTENT(IN) :: itrcr
1845  REAL*8, DIMENSION(itrcr), INTENT(IN) :: fscav
1846  REAL*8, DIMENSION(idim, k0), INTENT(IN) :: thoin, qhoin, uhoin, vhoin
1847 !PROGNOSTIC
1848  REAL*8, DIMENSION(idim, k0, itrcr), INTENT(INOUT) :: xho
1849  REAL*8, DIMENSION(idim, k0, itrcr), INTENT(INOUT) :: xhob
1850 !LOCALS
1851  INTEGER :: i, ic, l, kk, k
1852 !Parameters
1853  REAL*8, PARAMETER :: onepkap=1.+2./7., daylen=86400.0
1854  REAL*8, PARAMETER :: rhmax=0.9999
1855  REAL*8, PARAMETER :: cbl_qpert=0.0, cbl_tpert=1.0
1856  REAL*8, PARAMETER :: cbl_tpert_mxocn=2.0, cbl_tpert_mxlnd=4.0
1857 !Constants
1858  REAL*8 :: grav, cp, alhl, cpbg, alhi, cpi, gravi, ddt, lbcp
1859 !Rasparams
1860  REAL*8 :: fricfac, cli_crit, rasal1, rasal2
1861  REAL*8 :: friclambda
1862  REAL*8 :: sdqv2, sdqv3, sdqvt1
1863  REAL*8 :: acritfac, pblfrac, autorampb
1864  REAL*8 :: maxdallowed, rhmn, rhmx
1865  REAL*8 :: mxdiam
1866  REAL*8 :: tx2, tx3, akm, acr, alm, tth, qqh, dqx
1867  REAL*8 :: wfn, tem, trg, trgexp, evp, wlq, qcc
1868  REAL*8 :: cli, te_a, c00_x, cli_crit_x, toki
1869  REAL*8 :: dt_lyr, rate, cvw_x, closs, f2, f3, f4
1870  REAL*8 :: wght0, prcbl, rndu
1871  REAL*8 :: lambda_min, lambda_max
1872  REAL*8 :: tpert, qpert
1873  REAL*8 :: uht, vht
1874  REAL*8, DIMENSION(k0) :: poi_sv, qoi_sv, uoi_sv, voi_sv
1875  REAL*8, DIMENSION(k0) :: poi, qoi, uoi, voi, dqq, bet, gam, cll
1876  REAL*8, DIMENSION(k0) :: poi_c, qoi_c
1877  REAL*8, DIMENSION(k0) :: prh, pri, ght, dpt, dpb, pki
1878  REAL*8, DIMENSION(k0) :: ucu, vcu
1879  REAL*8, DIMENSION(k0) :: cln, rns, pol
1880  REAL*8, DIMENSION(k0) :: qst, ssl, rmf, rnn, rn1, rmfc, rmfp
1881  REAL*8, DIMENSION(k0) :: gms, eta, gmh, eht, gm1, hcc, rmfd
1882  REAL*8, DIMENSION(k0) :: hol, hst, qol, zol, hcld, cll0, cllx, clli
1883  REAL*8, DIMENSION(k0) :: bke, cvw, updfrc
1884  REAL*8, DIMENSION(k0) :: rasal, updfrp, bk2, dll0, dllx
1885  REAL*8, DIMENSION(k0) :: wght, massf
1886  REAL*8, DIMENSION(k0) :: qss, dqs, pf, pk, tempf, zlo
1887  REAL*8, DIMENSION(k0 + 1) :: prj, prs, qht, sht, zet, zle, pke
1888  REAL*8, DIMENSION(idim, k0) :: tho, qho, uho, vho
1889 !Tracer scavenging
1890  INTEGER :: itr
1891 !Layer thickness in km
1892  REAL*8 :: delzkm
1893 !Fraction of tracer *not* scavenged
1894  REAL*8 :: fnoscav
1895  REAL*8, DIMENSION(k0, itrcr) :: xoi, xcu, xoi_sv
1896  REAL*8, DIMENSION(k0, itrcr) :: xoib, xcub, xoi_svb
1897  REAL*8, DIMENSION(itrcr) :: xht
1898  REAL*8, DIMENSION(itrcr) :: xhtb
1899  INTRINSIC max
1900  INTRINSIC min
1901  INTRINSIC sqrt
1902  INTRINSIC exp
1903  INTRINSIC sum
1904  REAL*8 :: arg1
1905  INTEGER :: ad_to
1906  INTEGER :: ad_from
1907  INTEGER :: ad_from0
1908  INTEGER :: branch
1909  INTEGER :: ad_to0
1910  INTEGER :: ad_to1
1911  INTEGER :: ad_from1
1912  REAL*8 :: tempb2
1913  REAL*8 :: tempb1
1914  REAL*8 :: tempb0
1915  REAL*8 :: x5
1916  REAL*8 :: x4
1917  REAL*8 :: x3
1918  REAL*8 :: x2
1919  REAL*8 :: x1
1920  REAL*8 :: tempb
1921  REAL*8 :: max2
1922  REAL*8 :: max1
1923  REAL*8 :: y1
1924 !Pass meteorology to internal arrays so it is not updated
1925  tho = thoin
1926  qho = qhoin
1927 !Initialize Local Arrays
1928  poi = 0.0
1929  qoi = 0.0
1930  dqq = 0.0
1931  bet = 0.0
1932  gam = 0.0
1933  prh = 0.0
1934  pri = 0.0
1935  ght = 0.0
1936  dpt = 0.0
1937  dpb = 0.0
1938  pki = 0.0
1939  pol = 0.0
1940  qst = 0.0
1941  ssl = 0.0
1942  gms = 0.0
1943  eta = 0.0
1944  gmh = 0.0
1945  eht = 0.0
1946  gm1 = 0.0
1947  hcc = 0.0
1948  hst = 0.0
1949  qol = 0.0
1950  zol = 0.0
1951  hcld = 0.0
1952  rasal = 0.0
1953  bk2 = 0.0
1954  qss = 0.0
1955  dqs = 0.0
1956  prj = 0.0
1957  prs = 0.0
1958  qht = 0.0
1959  sht = 0.0
1960  zet = 0.0
1961 ! --- 1
1962 ! --- 4
1963  cli_crit = rasparams(4)
1964 ! --- 5
1965  rasal1 = rasparams(5)
1966 ! --- 6
1967  rasal2 = rasparams(6)
1968 ! --- 11
1969 ! --- 14
1970  sdqv2 = rasparams(14)
1971 ! --- 15
1972  sdqv3 = rasparams(15)
1973 ! --- 16
1974  sdqvt1 = rasparams(16)
1975 ! --- 17
1976  acritfac = rasparams(17)
1977 ! --- 20
1978  pblfrac = rasparams(20)
1979 ! --- 21
1980  autorampb = rasparams(21)
1981 ! --- 24
1982  rhmn = rasparams(24)
1983 ! --- 24
1984  maxdallowed = rasparams(23)
1985 ! --- 25
1986  rhmx = rasparams(25)
1987  grav = cons_grav
1988  alhl = cons_alhl
1989  cp = cons_cp
1990  cpi = 1.0/cp
1991  alhi = 1.0/alhl
1992  gravi = 1.0/grav
1993  cpbg = cp*gravi
1994  lbcp = alhl*cpi
1995  i = 1
1996 !CALL FINDBASE
1997  k = kcbl(i)
1998  IF (k .GT. 0) THEN
1999 !Get saturation specific humidity and gradient wrt to T
2000  pke = (ple(i, :)/1000.)**(cons_rgas/cons_cp)
2001  pf = 0.5*(ple(i, 1:k0)+ple(i, 2:k0+1))
2002  pk = (pf/1000.)**(cons_rgas/cons_cp)
2003  tempf = tho(i, :)*pk
2004  zle = 0.0
2005  zlo = 0.0
2006  zle(k0+1) = 0.
2007  DO l=k0,1,-1
2008  zle(l) = tho(i, l)*(1.+cons_vireps*qho(i, l))
2009  zlo(l) = zle(l+1) + cons_cp/cons_grav*(pke(l+1)-pk(l))*zle(l)
2010  zle(l) = zlo(l) + cons_cp/cons_grav*(pk(l)-pke(l))*zle(l)
2011  END DO
2012  tpert = cbl_tpert*(ts(i)-(tempf(k0)+cons_grav*zlo(k0)/cons_cp))
2013 !* ( QSSFC - Q(:,:,K0) ) [CBL_QPERT = 0.0]
2014  qpert = cbl_qpert
2015  IF (tpert .LT. 0.0) THEN
2016  tpert = 0.0
2017  ELSE
2018  tpert = tpert
2019  END IF
2020  IF (qpert .LT. 0.0) THEN
2021  qpert = 0.0
2022  ELSE
2023  qpert = qpert
2024  END IF
2025  IF (frland(i) .LT. 0.1) THEN
2026  IF (tpert .GT. cbl_tpert_mxocn) THEN
2027  tpert = cbl_tpert_mxocn
2028  ELSE
2029  tpert = tpert
2030  END IF
2031  ELSE IF (tpert .GT. cbl_tpert_mxlnd) THEN
2032  tpert = cbl_tpert_mxlnd
2033  ELSE
2034  tpert = tpert
2035  END IF
2036  CALL dqsat_ras(dqs, qss, tempf, pf, k0, estblx, cons_h2omw, &
2037 & cons_airmw)
2038  DO kk=icmin,k+1
2039  prj(kk) = pke(kk)
2040  END DO
2041  prs(icmin:k0+1) = ple(i, icmin:k0+1)
2042  poi(icmin:k) = tho(i, icmin:k)
2043  qoi(icmin:k) = qho(i, icmin:k)
2044  qst(icmin:k) = qss(icmin:k)
2045  dqq(icmin:k) = dqs(icmin:k)
2046 !Mass fraction of each layer below cloud base
2047  massf(:) = wgt0(i, :)
2048 !RESET PRESSURE at bottom edge of CBL
2049  prcbl = prs(k)
2050  DO l=k,k0
2051  prcbl = prcbl + massf(l)*(prs(l+1)-prs(l))
2052  END DO
2053  prs(k+1) = prcbl
2054  prj(k+1) = (prs(k+1)/1000.)**(cons_rgas/cons_cp)
2055  DO l=k,icmin,-1
2056  pol(l) = 0.5*(prs(l)+prs(l+1))
2057  prh(l) = (prs(l+1)*prj(l+1)-prs(l)*prj(l))/(onepkap*(prs(l+1)-prs(&
2058 & l)))
2059  pki(l) = 1.0/prh(l)
2060  dpt(l) = prh(l) - prj(l)
2061  dpb(l) = prj(l+1) - prh(l)
2062  pri(l) = .01/(prs(l+1)-prs(l))
2063  END DO
2064 !RECALCULATE PROFILE QUAN. IN LOWEST STRAPPED LAYER
2065  IF (k .LE. k0) THEN
2066  poi(k) = 0.
2067  qoi(k) = 0.
2068 !SPECIFY WEIGHTS GIVEN TO EACH LAYER WITHIN SUBCLOUD "SUPERLAYER"
2069  wght = 0.
2070  DO l=k,k0
2071  wght(l) = massf(l)*(ple(i, l+1)-ple(i, l))/(prs(k+1)-prs(k))
2072  END DO
2073  DO l=k,k0
2074  poi(k) = poi(k) + wght(l)*tho(i, l)
2075  qoi(k) = qoi(k) + wght(l)*qho(i, l)
2076  END DO
2077  CALL pushcontrol1b(1)
2078  arg1 = poi(k)*prh(k)
2079  CALL dqsats_ras(dqq(k), qst(k), arg1, pol(k), estblx, cons_h2omw, &
2080 & cons_airmw)
2081  ELSE
2082  CALL pushcontrol1b(0)
2083  END IF
2084  IF (seedras(i)/1000000. .LT. 1e-6) THEN
2085  rndu = 1e-6
2086  ELSE
2087  rndu = seedras(i)/1000000.
2088  END IF
2089  mxdiam = maxdallowed*rndu**(-(1./2.))
2090  DO l=k,icmin,-1
2091 !*
2092  bet(l) = dqq(l)*pki(l)
2093 !*
2094  gam(l) = pki(l)/(1.0+lbcp*dqq(l))
2095  IF (l .LT. k) THEN
2096  ght(l+1) = gam(l)*dpb(l) + gam(l+1)*dpt(l+1)
2097  gm1(l+1) = 0.5*lbcp*(dqq(l)/(alhl*(1.0+lbcp*dqq(l)))+dqq(l+1)/(&
2098 & alhl*(1.0+lbcp*dqq(l+1))))
2099  END IF
2100  END DO
2101  rmf = 0.
2102 !DO_TRACERS
2103  cvw = 0.0
2104 ! HOL initialized here in order not to confuse Valgrind debugger
2105  hol = 0.
2106  zet(k+1) = 0
2107  sht(k+1) = cp*poi(k)*prj(k+1)
2108  DO l=k,icmin,-1
2109  IF (qst(l)*rhmax .GT. qoi(l)) THEN
2110  qol(l) = qoi(l)
2111  ELSE
2112  qol(l) = qst(l)*rhmax
2113  END IF
2114  IF (0.000 .LT. qol(l)) THEN
2115  qol(l) = qol(l)
2116  ELSE
2117  qol(l) = 0.000
2118  END IF
2119  ssl(l) = cp*prj(l+1)*poi(l) + grav*zet(l+1)
2120  hol(l) = ssl(l) + qol(l)*alhl
2121  hst(l) = ssl(l) + qst(l)*alhl
2122  tem = poi(l)*(prj(l+1)-prj(l))*cpbg
2123  zet(l) = zet(l+1) + tem
2124  zol(l) = zet(l+1) + (prj(l+1)-prh(l))*poi(l)*cpbg
2125  END DO
2126  DO ic=k,icmin+1,-1
2127 !DO_TRACERS
2128  IF (1. .GT. (qoi(k)/qst(k)-rhmn)/(rhmx-rhmn)) THEN
2129  trg = (qoi(k)/qst(k)-rhmn)/(rhmx-rhmn)
2130  ELSE
2131  trg = 1.
2132  END IF
2133  IF (0.0 .LT. (autorampb-sige(ic))/0.2) THEN
2134  y1 = (autorampb-sige(ic))/0.2
2135  ELSE
2136  y1 = 0.0
2137  END IF
2138  IF (1.0 .GT. y1) THEN
2139  f4 = y1
2140  ELSE
2141  f4 = 1.0
2142  END IF
2143  IF (trg .LE. 1.0e-5) THEN
2144  CALL pushcontrol3b(5)
2145  ELSE
2146 !================>>
2147 !RECOMPUTE SOUNDING UP TO DETRAINMENT LEVEL
2148  poi_c = poi
2149  qoi_c = qoi
2150  poi_c(k) = poi_c(k) + tpert
2151  qoi_c(k) = qoi_c(k) + qpert
2152  zet(k+1) = 0.
2153  sht(k+1) = cp*poi_c(k)*prj(k+1)
2154  DO l=k,ic,-1
2155  IF (qst(l)*rhmax .GT. qoi_c(l)) THEN
2156  qol(l) = qoi_c(l)
2157  ELSE
2158  qol(l) = qst(l)*rhmax
2159  END IF
2160  IF (0.000 .LT. qol(l)) THEN
2161  qol(l) = qol(l)
2162  ELSE
2163  qol(l) = 0.000
2164  END IF
2165  ssl(l) = cp*prj(l+1)*poi_c(l) + grav*zet(l+1)
2166  hol(l) = ssl(l) + qol(l)*alhl
2167  hst(l) = ssl(l) + qst(l)*alhl
2168  CALL pushreal8(tem)
2169  tem = poi_c(l)*(prj(l+1)-prj(l))*cpbg
2170  zet(l) = zet(l+1) + tem
2171  zol(l) = zet(l+1) + (prj(l+1)-prh(l))*poi_c(l)*cpbg
2172  END DO
2173  CALL pushinteger4(l + 1)
2174  ad_from = ic + 1
2175  DO l=ad_from,k
2176  CALL pushreal8(tem)
2177  tem = (prj(l)-prh(l-1))/(prh(l)-prh(l-1))
2178  sht(l) = ssl(l-1) + tem*(ssl(l)-ssl(l-1))
2179  qht(l) = .5*(qol(l)+qol(l-1))
2180  END DO
2181  CALL pushinteger4(ad_from)
2182 !CALCULATE LAMBDA, ETA, AND WORKFUNCTION
2183  lambda_min = .2/mxdiam
2184  lambda_max = .2/200.
2185  IF (hol(k) .LE. hst(ic)) THEN
2186  CALL pushcontrol3b(4)
2187  ELSE
2188 !================>>
2189 !LAMBDA CALCULATION: MS-A18
2190  CALL pushreal8(tem)
2191  tem = (hst(ic)-hol(ic))*(zol(ic)-zet(ic+1))
2192  DO l=ic+1,k-1
2193  tem = tem + (hst(ic)-hol(l))*(zet(l)-zet(l+1))
2194  END DO
2195  IF (tem .LE. 0.0) THEN
2196  CALL pushcontrol3b(3)
2197  ELSE
2198 !================>>
2199  alm = (hol(k)-hst(ic))/tem
2200  IF (alm .GT. lambda_max) THEN
2201  CALL pushcontrol3b(2)
2202  ELSE
2203 !================>>
2204  toki = 1.0
2205  IF (alm .LT. lambda_min) toki = (alm/lambda_min)**2
2206  ad_from0 = ic + 1
2207 !ETA CALCULATION: MS-A2
2208  DO l=ad_from0,k
2209  CALL pushreal8(eta(l))
2210  eta(l) = 1.0 + alm*(zet(l)-zet(k))
2211  END DO
2212  CALL pushinteger4(ad_from0)
2213  CALL pushreal8(eta(ic))
2214  eta(ic) = 1.0 + alm*(zol(ic)-zet(k))
2215 !WORKFUNCTION CALCULATION: MS-A22
2216  wfn = 0.0
2217  hcc(k) = hol(k)
2218  DO l=k-1,ic+1,-1
2219  hcc(l) = hcc(l+1) + (eta(l)-eta(l+1))*hol(l)
2220  tem = hcc(l+1)*dpb(l) + hcc(l)*dpt(l)
2221  eht(l) = eta(l+1)*dpb(l) + eta(l)*dpt(l)
2222  wfn = wfn + (tem-eht(l)*hst(l))*gam(l)
2223  END DO
2224  hcc(ic) = hst(ic)*eta(ic)
2225  wfn = wfn + (hcc(ic+1)-hst(ic)*eta(ic+1))*gam(ic)*dpb(ic)
2226 !VERTICAL VELOCITY/KE CALCULATION (ADDED 12/2001 JTB)
2227  bk2(k) = 0.0
2228  hcld(k) = hol(k)
2229  DO l=k-1,ic,-1
2230  hcld(l) = (eta(l+1)*hcld(l+1)+(eta(l)-eta(l+1))*hol(l))/&
2231 & eta(l)
2232  tem = (hcld(l)-hst(l))*(zet(l)-zet(l+1))/(1.0+lbcp*dqq(l&
2233 & ))
2234  IF (tem .LT. 0.0) THEN
2235  max1 = 0.0
2236  ELSE
2237  max1 = tem
2238  END IF
2239  bk2(l) = bk2(l+1) + grav*max1/(cp*prj(l+1)*poi(l))
2240  IF (bk2(l) .LT. 0.0) THEN
2241  max2 = 0.0
2242  ELSE
2243  max2 = bk2(l)
2244  END IF
2245  cvw(l) = sqrt(2.0*max2)
2246  END DO
2247 !ALPHA CALCULATION
2248  IF (zet(ic) .LT. 2000.) rasal(ic) = rasal1
2249  IF (zet(ic) .GE. 2000.) rasal(ic) = rasal1 + (rasal2-&
2250 & rasal1)*(zet(ic)-2000.)/8000.
2251  IF (rasal(ic) .GT. 1.0e5) THEN
2252  rasal(ic) = 1.0e5
2253  ELSE
2254  rasal(ic) = rasal(ic)
2255  END IF
2256  rasal(ic) = dt/rasal(ic)
2257  DO l=ic,k
2258  IF (cvw(l) .LT. 1.00) THEN
2259  cvw(l) = 1.00
2260  ELSE
2261  cvw(l) = cvw(l)
2262  END IF
2263  END DO
2264  CALL acritn(pol(ic), prs(k), acr, acritfac)
2265  IF (wfn .LE. acr) THEN
2266  CALL pushcontrol3b(1)
2267  ELSE
2268 !================>>
2269 !DO_TRACERS
2270  DO itr=1,itrcr
2271 !Scavenging of the below cloud tracer
2272  delzkm = (zet(ic)-zet(k))/1000.
2273  x4 = exp(-(fscav(itr)*delzkm))
2274  IF (x4 .GT. 1.) THEN
2275  x1 = 1.
2276  ELSE
2277  x1 = x4
2278  END IF
2279  IF (x1 .LT. 0.) THEN
2280  CALL pushreal8(fnoscav)
2281  fnoscav = 0.
2282  CALL pushcontrol1b(0)
2283  ELSE
2284  CALL pushreal8(fnoscav)
2285  fnoscav = x1
2286  CALL pushcontrol1b(1)
2287  END IF
2288  END DO
2289  wlq = qol(k)
2290  DO l=k-1,ic,-1
2291  CALL pushreal8(tem)
2292  tem = eta(l) - eta(l+1)
2293  wlq = wlq + tem*qol(l)
2294 !DO_TRACERS
2295  DO itr=1,itrcr
2296 !Scavenging of the entrained tracer. Updates transported tracer mass.
2297  delzkm = (zet(ic)-zet(l+1))/1000.
2298  x5 = exp(-(fscav(itr)*delzkm))
2299  IF (x5 .GT. 1.) THEN
2300  x2 = 1.
2301  ELSE
2302  x2 = x5
2303  END IF
2304  IF (x2 .LT. 0.) THEN
2305  CALL pushreal8(fnoscav)
2306  fnoscav = 0.
2307  CALL pushcontrol1b(0)
2308  ELSE
2309  CALL pushreal8(fnoscav)
2310  fnoscav = x2
2311  CALL pushcontrol1b(1)
2312  END IF
2313  END DO
2314  IF (l .GT. ic) THEN
2315  tx2 = 0.5*(qst(l)+qst(l-1))*eta(l)
2316  tx3 = 0.5*(hst(l)+hst(l-1))*eta(l)
2317  qcc = tx2 + gm1(l)*(hcc(l)-tx3)
2318  cll0(l) = wlq - qcc
2319  ELSE
2320  cll0(l) = wlq - qst(ic)*eta(ic)
2321  END IF
2322  IF (cll0(l) .LT. 0.00) THEN
2323  cll0(l) = 0.00
2324  ELSE
2325  cll0(l) = cll0(l)
2326  END IF
2327  cli = cll0(l)/eta(l)
2328  te_a = poi(l)*prh(l)
2329  CALL sundq3_ice(te_a, sdqv2, sdqv3, sdqvt1, f2, f3)
2330  c00_x = co_auto(i)*f2*f3*f4
2331  cli_crit_x = cli_crit/(f2*f3)
2332  rate = c00_x*(1.0-exp(-(cli**2/cli_crit_x**2)))
2333  IF (cvw(l) .LT. 1.00) THEN
2334  cvw_x = 1.00
2335  ELSE
2336  cvw_x = cvw(l)
2337  END IF
2338  dt_lyr = (zet(l)-zet(l+1))/cvw_x
2339  closs = cll0(l)*rate*dt_lyr
2340  IF (closs .GT. cll0(l)) THEN
2341  closs = cll0(l)
2342  ELSE
2343  closs = closs
2344  END IF
2345  IF (closs .GT. 0.) wlq = wlq - closs
2346  END DO
2347  CALL pushinteger4(l + 1)
2348  wlq = wlq - qst(ic)*eta(ic)
2349 !CALCULATE GAMMAS AND KERNEL
2350  gms(k) = (sht(k)-ssl(k))*pri(k)
2351  gmh(k) = gms(k) + (qht(k)-qol(k))*pri(k)*alhl
2352  akm = gmh(k)*gam(k-1)*dpb(k-1)
2353  tx2 = gmh(k)
2354  DO l=k-1,ic+1,-1
2355  gms(l) = (eta(l)*(sht(l)-ssl(l))+eta(l+1)*(ssl(l)-sht(&
2356 & l+1)))*pri(l)
2357  gmh(l) = gms(l) + (eta(l)*(qht(l)-qol(l))+eta(l+1)*(&
2358 & qol(l)-qht(l+1)))*alhl*pri(l)
2359  tx2 = tx2 + (eta(l)-eta(l+1))*gmh(l)
2360  akm = akm - gms(l)*eht(l)*pki(l) + tx2*ght(l)
2361  END DO
2362  gms(ic) = eta(ic+1)*(ssl(ic)-sht(ic+1))*pri(ic)
2363  akm = akm - gms(ic)*eta(ic+1)*dpb(ic)*pki(ic)
2364  gmh(ic) = gms(ic) + (eta(ic+1)*(qol(ic)-qht(ic+1))*alhl+&
2365 & eta(ic)*(hst(ic)-hol(ic)))*pri(ic)
2366 !CLOUD BASE MASS FLUX
2367  IF (akm .GE. 0.0 .OR. wlq .LT. 0.0) THEN
2368  CALL pushcontrol3b(0)
2369  ELSE
2370 !================>>
2371  wfn = -((wfn-acr)/akm)
2372  x3 = rasal(ic)*trg*toki*wfn
2373  IF (x3 .GT. (prs(k+1)-prs(k))*(100.*pblfrac)) THEN
2374  wfn = (prs(k+1)-prs(k))*(100.*pblfrac)
2375  ELSE
2376  wfn = x3
2377  END IF
2378 !CUMULATIVE PRECIP AND CLOUD-BASE MASS FLUX FOR OUTPUT
2379  CALL pushreal8(tem)
2380  tem = wfn*gravi
2381  rmf(ic) = rmf(ic) + tem
2382 !THETA AND Q CHANGE DUE TO CLOUD TYPE IC
2383  DO l=ic,k
2384  gmh(l) = gmh(l)*wfn
2385  gms(l) = gms(l)*wfn
2386  qoi(l) = qoi(l) + (gmh(l)-gms(l))*alhi
2387  poi(l) = poi(l) + gms(l)*pki(l)*cpi
2388  qst(l) = qst(l) + gms(l)*bet(l)*cpi
2389  END DO
2390 !*FRICFAC*0.5
2391  wfn = wfn*0.5*1.0
2392 !DO_TRACERS
2393  tem = wfn*pri(k)
2394  DO itr=1,itrcr
2395  DO l=k-1,ic+1,-1
2396  CALL pushreal8(tem)
2397  tem = wfn*pri(l)
2398  END DO
2399  CALL pushinteger4(l + 1)
2400  END DO
2401  CALL pushreal8(tem)
2402  tem = wfn*pri(ic)
2403  DO itr=1,itrcr
2404  ad_from1 = ic
2405  CALL pushinteger4(ad_from1)
2406  END DO
2407  CALL pushcontrol3b(6)
2408  END IF
2409  END IF
2410  END IF
2411  END IF
2412  END IF
2413  END IF
2414  END DO
2415 !CLOUD LOOP
2416  IF (sum(rmf(icmin:k)) .GT. 0.0) THEN
2417 !De-strap tendencies from RAS
2418  CALL pushreal8array(wght, k0)
2419  wght = wgt1(i, :)
2420 !Scale properly by layer masses
2421  wght0 = 0.
2422  DO l=k,k0
2423  wght0 = wght0 + wght(l)*(ple(i, l+1)-ple(i, l))
2424  END DO
2425  wght0 = (prs(k+1)-prs(k))/wght0
2426  wght = wght0*wght
2427  xoib = 0.0_8
2428  xoi_svb = 0.0_8
2429  DO itr=itrcr,1,-1
2430  DO l=k0,k,-1
2431  xoib(k, itr) = xoib(k, itr) + wght(l)*xhob(i, l, itr)
2432  xoi_svb(k, itr) = xoi_svb(k, itr) - wght(l)*xhob(i, l, itr)
2433  END DO
2434  END DO
2435  xoib(icmin:k-1, :) = xoib(icmin:k-1, :) + xhob(i, icmin:k-1, :)
2436  xhob(i, icmin:k-1, :) = 0.0_8
2437  CALL popreal8array(wght, k0)
2438  ELSE
2439  xoib = 0.0_8
2440  xoi_svb = 0.0_8
2441  END IF
2442  xcub = 0.0_8
2443  xhtb = 0.0_8
2444  DO ic=icmin+1,k,1
2445  CALL popcontrol3b(branch)
2446  IF (branch .LT. 3) THEN
2447  IF (branch .NE. 0) THEN
2448  IF (branch .EQ. 1) THEN
2449  GOTO 100
2450  ELSE
2451  GOTO 110
2452  END IF
2453  END IF
2454  ELSE IF (branch .LT. 5) THEN
2455  IF (branch .EQ. 3) THEN
2456  GOTO 110
2457  ELSE
2458  GOTO 120
2459  END IF
2460  ELSE IF (branch .EQ. 5) THEN
2461  GOTO 130
2462  ELSE
2463  DO itr=itrcr,1,-1
2464  CALL popinteger4(ad_from1)
2465  DO l=k,ad_from1,-1
2466  xcub(l, itr) = xcub(l, itr) + xoib(l, itr)
2467  END DO
2468  END DO
2469  DO itr=itrcr,1,-1
2470  tempb1 = tem*xcub(ic, itr)
2471  tempb2 = -(eta(ic+1)*tempb1)
2472  xhtb(itr) = xhtb(itr) + 2.*tempb1
2473  xoib(ic, itr) = xoib(ic, itr) + tempb2 - 2.*(eta(ic)-eta(ic+1)&
2474 & )*tempb1
2475  xoib(ic+1, itr) = xoib(ic+1, itr) + tempb2
2476  END DO
2477  CALL popreal8(tem)
2478  DO itr=itrcr,1,-1
2479  CALL popinteger4(ad_to1)
2480  DO l=ad_to1,k-1,1
2481  tempb = tem*xcub(l, itr)
2482  tempb0 = eta(l+1)*tempb
2483  xoib(l-1, itr) = xoib(l-1, itr) + eta(l)*tempb
2484  xoib(l, itr) = xoib(l, itr) + tempb0 - eta(l)*tempb
2485  xoib(l+1, itr) = xoib(l+1, itr) - tempb0
2486  CALL popreal8(tem)
2487  END DO
2488  END DO
2489  DO itr=itrcr,1,-1
2490  xoib(k-1, itr) = xoib(k-1, itr) + tem*xcub(k, itr)
2491  xoib(k, itr) = xoib(k, itr) - tem*xcub(k, itr)
2492  END DO
2493  CALL popreal8(tem)
2494  END IF
2495  CALL popinteger4(ad_to0)
2496  DO l=ad_to0,k-1,1
2497  DO itr=itrcr,1,-1
2498  xoib(l, itr) = xoib(l, itr) + tem*fnoscav*xhtb(itr)
2499  CALL popcontrol1b(branch)
2500  IF (branch .EQ. 0) THEN
2501  CALL popreal8(fnoscav)
2502  ELSE
2503  CALL popreal8(fnoscav)
2504  END IF
2505  END DO
2506  CALL popreal8(tem)
2507  END DO
2508  DO itr=itrcr,1,-1
2509  xoib(k, itr) = xoib(k, itr) + fnoscav*xhtb(itr)
2510  xhtb(itr) = 0.0_8
2511  CALL popcontrol1b(branch)
2512  IF (branch .EQ. 0) THEN
2513  CALL popreal8(fnoscav)
2514  ELSE
2515  CALL popreal8(fnoscav)
2516  END IF
2517  END DO
2518  100 CALL popreal8(eta(ic))
2519  CALL popinteger4(ad_from0)
2520  DO l=k,ad_from0,-1
2521  CALL popreal8(eta(l))
2522  END DO
2523  110 CALL popreal8(tem)
2524  120 CALL popinteger4(ad_from)
2525  DO l=k,ad_from,-1
2526  CALL popreal8(tem)
2527  END DO
2528  CALL popinteger4(ad_to)
2529  DO l=ad_to,k,1
2530  CALL popreal8(tem)
2531  END DO
2532  130 xcub(icmin:k0, :) = 0.0_8
2533  END DO
2534  xoib = xoib + xoi_svb
2535  CALL popcontrol1b(branch)
2536  IF (branch .NE. 0) THEN
2537  DO itr=itrcr,1,-1
2538  DO l=k0,k,-1
2539  xhob(i, l, itr) = xhob(i, l, itr) + wght(l)*xoib(k, itr)
2540  END DO
2541  END DO
2542  xoib(k, :) = 0.0_8
2543  END IF
2544  DO itr=itrcr,1,-1
2545  xhob(i, icmin:k, itr) = xhob(i, icmin:k, itr) + xoib(icmin:k, itr)
2546  xoib(icmin:k, itr) = 0.0_8
2547  END DO
2548  END IF
2549 END SUBROUTINE rase_tracer_b
2550 
2551 END MODULE convection_ad
convection::acritn
subroutine, public acritn(PL, PLB, ACR, ACRITFAC)
Definition: convection.F90:641
popinteger4
subroutine popinteger4(x)
Definition: adBuffer.f:541
convection_ad::rase_tracer_b
subroutine, public rase_tracer_b(idim, irun, k0, icmin, dt, cons_cp, cons_alhl, cons_grav, cons_rgas, cons_h2omw, cons_airmw, cons_vireps, seedras, sige, kcbl, wgt0, wgt1, frland, ts, thoin, qhoin, uhoin, vhoin, co_auto, ple, rasparams, estblx, itrcr, xho, xhob, fscav)
Definition: convection_ad.F90:1830
popcontrol2b
subroutine popcontrol2b(cc)
Definition: adBuffer.f:146
convection::dqsat_ras
subroutine, public dqsat_ras(DQSi, QSSi, TEMP, PLO, lm, ESTBLX, CONS_H2OMW, CONS_AIRMW)
Definition: convection.F90:706
popreal8array
void popreal8array(double *x, int n)
Definition: adStack.c:375
convection::dqsats_ras
subroutine, public dqsats_ras(DQSi, QSSi, TEMP, PLO, ESTBLX, CONS_H2OMW, CONS_AIRMW)
Definition: convection.F90:774
convection_ad::dqsats_ras_b
subroutine dqsats_ras_b(dqsi, dqsib, qssi, qssib, temp, tempb, plo, estblx, cons_h2omw, cons_airmw)
Definition: convection_ad.F90:1757
pushcontrol1b
subroutine pushcontrol1b(cc)
Definition: adBuffer.f:115
convection_ad::sundq3_ice_b
subroutine sundq3_ice_b(temp, tempb, rate2, rate3, te1, f2, f2b, f3)
Definition: convection_ad.F90:1608
convection_ad::dqsat_ras_b
subroutine dqsat_ras_b(dqsi, dqsib, qssi, qssib, temp, tempb, plo, lm, estblx, cons_h2omw, cons_airmw)
Definition: convection_ad.F90:1668
pushcontrol2b
subroutine pushcontrol2b(cc)
Definition: adBuffer.f:140
pushreal8array
void pushreal8array(double *x, int n)
Definition: adStack.c:372
popreal8
subroutine popreal8(x)
Definition: adBuffer.f:820
convection_ad
Definition: convection_ad.F90:1
convection_ad::rase_b
subroutine, public rase_b(idim, irun, k0, icmin, dt, cons_cp, cons_alhl, cons_grav, cons_rgas, cons_h2omw, cons_airmw, cons_vireps, seedras, sige, kcbl, wgt0, wgt1, frland, ts, tho, thob, qho, qhob, uho, uhob, vho, vhob, co_auto, ple, clw, clwb, flxd, flxdb, cnv_prc3, cnv_prc3b, cnv_updfrc, cnv_updfrcb, rasparams, estblx)
Definition: convection_ad.F90:28
convection::sundq3_ice
subroutine, public sundq3_ice(TEMP, RATE2, RATE3, TE1, F2, F3)
Definition: convection.F90:671
popcontrol3b
subroutine popcontrol3b(cc)
Definition: adBuffer.f:175
pushreal8
subroutine pushreal8(x)
Definition: adBuffer.f:763
popcontrol1b
subroutine popcontrol1b(cc)
Definition: adBuffer.f:120
max
#define max(a, b)
Definition: mosaic_util.h:33
pushcontrol3b
subroutine pushcontrol3b(cc)
Definition: adBuffer.f:168
min
#define min(a, b)
Definition: mosaic_util.h:32
pushinteger4
subroutine pushinteger4(x)
Definition: adBuffer.f:484