LMDZ
rrtm_rtrn1a_140gp.F90
Go to the documentation of this file.
1 SUBROUTINE rrtm_rtrn1a_140gp (KLEV,ISTART,IEND,ICLDLYR,CLDFRAC,TAUCLD,ABSS1 &
2  &, od,tausf1,clfnet,clhtr,fnet,htr,totdfluc,totdflux,totufluc,totuflux &
3  &, tavel,pz,tz,tbound,pfrac,semiss,semislw,ireflect)
4 
5 ! Reformatted for F90 by JJMorcrette, ECMWF, 980714
6 ! Speed-up by D.Salmond, ECMWF, 9907
7 ! Bug-fix by M.J. Iacono, AER, Inc., 9911
8 ! Bug-fix by JJMorcrette, ECMWF, 991209 (RAT1, RAT2 initialization)
9 ! Speed-up by D. Salmond, ECMWF, 9912
10 ! Bug-fix by JJMorcrette, ECMWF, 0005 (extrapolation T<160K)
11 ! Speed-up by D. Salmond, ECMWF, 000515
12 
13 !-* This program calculates the upward fluxes, downward fluxes,
14 ! and heating rates for an arbitrary atmosphere. The input to
15 ! this program is the atmospheric profile and all Planck function
16 ! information. First-order "numerical" quadrature is used for the
17 ! angle integration, i.e. only one exponential is computed per layer
18 ! per g-value per band. Cloud overlap is treated with a generalized
19 ! maximum/random method in which adjacent cloud layers are treated
20 ! with maximum overlap, and non-adjacent cloud groups are treated
21 ! with random overlap. For adjacent cloud layers, cloud information
22 ! is carried from the previous two layers.
23 
24 
25 #include "tsmbkind.h"
26 
27 USE parrrtm , ONLY : jpband ,jpgpt ,jplay
28 USE yoerrtab , ONLY : bpade
29 USE yoerrtwn , ONLY : totplnk ,delwave
30 USE yoerrtftr, ONLY : ngb
31 
32 IMPLICIT NONE
33 
34 ! DUMMY INTEGER SCALARS
35 integer_m :: klev
36 integer_m :: istart
37 integer_m :: iend
38 
39 integer_m :: icldlyr(jplay) ! Cloud indicator
40 real_b :: cldfrac(jplay) ! Cloud fraction
41 real_b :: taucld(jplay,jpband) ! Spectral optical thickness
42 real_b :: abss1(jpgpt*jplay)
43 real_b :: od(jpgpt,jplay)
44 real_b :: tausf1(jpgpt*jplay)
45 real_b :: clfnet(0:jplay)
46 real_b :: clhtr(0:jplay)
47 real_b :: fnet(0:jplay)
48 real_b :: htr(0:jplay)
49 real_b :: totdfluc(0:jplay)
50 real_b :: totdflux(0:jplay)
51 real_b :: totufluc(0:jplay)
52 real_b :: totuflux(0:jplay)
53 
54 !- from PROFILE
55 real_b :: tavel(jplay)
56 real_b :: pz(0:jplay)
57 real_b :: tz(0:jplay)
58 real_b :: tbound
59 
60 !- from SP
61 real_b :: pfrac(jpgpt,jplay)
62 
63 !- from SURFACE
64 real_b :: semiss(jpband)
65 real_b :: semislw
66 integer_m :: ireflect
67 
68 integer_m :: indlay(jplay),indlev(0:jplay)
69 
70 real_b :: bbu1(jpgpt*jplay),bbutot1(jpgpt*jplay)
71 real_b :: tlayfrac(jplay),tlevfrac(0:jplay)
72 real_b :: bglev(jpgpt)
73 !-- DS_000515
74 real_b :: plvl(0:jplay,jpband+1),play(0:jplay,jpband+1),wtnum(3)
75 !-- DS_000515
76 real_b :: odcld(jpband,jplay),efclfr1(jpband,jplay)
77 real_b :: odcldnw(jpgpt,jplay)
78 real_b :: semis(jpgpt),raduemit(jpgpt)
79 
80 real_b :: radclru1(jpgpt) ,radclrd1(jpgpt)
81 real_b :: radlu1(jpgpt) ,radld1(jpgpt)
82 real_b :: abscld1(jpband,jplay)
83 !-- DS_000515
84 real_b :: trncld(jplay,jpband+1)
85 !-- DS_000515
86 real_b :: abscldnw(jpgpt,jplay)
87 real_b :: atot1(jpgpt*jplay)
88 
89 real_b :: surfemis(jpband),plnkemit(jpband)
90 
91 ! dimension of arrays required for cloud overlap calculations
92 
93 real_b :: clrradu(jpgpt),cldradu(jpgpt),oldcld(jpgpt)
94 real_b :: oldclr(jpgpt),rad(jpgpt),faccld1(jplay+1),faccld2(jplay+1)
95 real_b :: facclr1(jplay+1),facclr2(jplay+1)
96 real_b :: faccmb1(jplay+1),faccmb2(jplay+1)
97 real_b :: faccld1d(0:jplay),faccld2d(0:jplay),facclr1d(0:jplay)
98 real_b :: facclr2d(0:jplay),faccmb1d(0:jplay),faccmb2d(0:jplay)
99 real_b :: clrradd(jpgpt),cldradd(jpgpt)
100 integer_m :: istcld(jplay+1),istcldd(0:jplay)
101 !******
102 
103 real_b :: zplvl(jpgpt+1,jplay) ,zplay(jpgpt+1,jplay)
104 real_b :: ztrncld(jpgpt+1,jplay),ztaucld(jpgpt+1,jplay)
105 
106 ! LOCAL INTEGER SCALARS
107 integer_m :: iband, iclddn, ient, indbound, index, ipr, lay, lev, nbi
108 
109 ! LOCAL REAL SCALARS
110 real_b :: bbd, bbdtot, bglay, cldsrc, dbdtlay, dbdtlev,&
111  &delbgdn, delbgup, drad1, dradcl1, factot1, &
112  &fmax, fmin, gassrc, odsm, plankbnd, radcld, &
113  &radclu, radd, radmod, radu, rat1, rat2, sumpl, &
114  &sumplem, tbndfrac, trns, ttot, urad1, uradcl1
115 
116 !--------------------------------------------------------------------------
117 ! Input
118 ! JPLAY ! Maximum number of model layers
119 ! JPGPT ! Total number of g-point subintervals
120 ! JPBAND ! Number of longwave spectral bands
121 ! SECANG ! Diffusivity angle
122 ! WTNUM ! Weight for radiance to flux conversion
123 ! KLEV ! Number of model layers
124 ! PAVEL(JPLAY) ! Mid-layer pressures (hPa)
125 ! PZ(0:JPLAY) ! Interface pressures (hPa)
126 ! TAVEL(JPLAY) ! Mid-layer temperatures (K)
127 ! TZ(0:JPLAY) ! Interface temperatures (K)
128 ! TBOUND ! Surface temperature
129 ! CLDFRAC(JPLAY) ! Layer cloud fraction
130 ! TAUCLD(JPLAY,JPBAND) ! Layer cloud optical thickness
131 ! ITR
132 ! PFRAC(JPGPT,JPLAY) ! Planck function fractions
133 ! ICLDLYR(JPLAY) ! Flag for cloudy layers
134 ! ICLD ! Flag for cloudy column
135 ! IREFLECT ! Flag for specular reflection
136 ! SEMISS(JPBAND) ! Surface spectral emissivity
137 ! BPADE ! Pade constant
138 ! OD ! Clear-sky optical thickness
139 ! TAUSF1 !
140 ! ABSS1 !
141 !
142 ! Local
143 ! ABSS(JPGPT*JPLAY) !
144 ! ABSCLD(JPLAY) !
145 ! ATOT(JPGPT*JPLAY) !
146 ! ODCLR(JPGPT,JPLAY) !
147 ! ODCLD(JPBAND,JPLAY) !
148 ! EFCLFR1(JPBAND,JPLAY) ! Effective cloud fraction
149 ! RADLU(JPGPT) ! Upward radiance
150 ! URAD ! Spectrally summed upward radiance
151 ! RADCLRU(JPGPT) ! Clear-sky upward radiance
152 ! CLRURAD ! Spectrally summed clear-sky upward radiance
153 ! RADLD(JPGPT) ! Downward radiance
154 ! DRAD ! Spectrally summed downward radiance
155 ! RADCLRD(JPGPT) ! Clear-sky downward radiance
156 ! CLRDRAD ! Spectrally summed clear-sky downward radiance
157 !
158 ! Output
159 ! TOTUFLUX(0:JPLAY) ! Upward longwave flux
160 ! TOTDFLUX(0:JPLAY) ! Downward longwave flux
161 ! TOTUFLUC(0:JPLAY) ! Clear-sky upward longwave flux
162 ! TOTDFLUC(0:JPLAY) ! Clear-sky downward longwave flux
163 !
164 ! Maximum/Random cloud overlap variables
165 ! for upward radiaitve transfer
166 ! FACCLR2 fraction of clear radiance from previous layer that needs to
167 ! be switched to cloudy stream
168 ! FACCLR1 fraction of the radiance that had been switched in the previous
169 ! layer from cloudy to clear that needs to be switched back to
170 ! cloudy in the current layer
171 ! FACCLD2 fraction of cloudy radiance from previous layer that needs to
172 ! be switched to clear stream
173 ! be switched to cloudy stream
174 ! FACCLD1 fraction of the radiance that had been switched in the previous
175 ! layer from clear to cloudy that needs to be switched back to
176 ! clear in the current layer
177 ! for downward radiaitve transfer
178 ! FACCLR2D fraction of clear radiance from previous layer that needs to
179 ! be switched to cloudy stream
180 ! FACCLR1D fraction of the radiance that had been switched in the previous
181 ! layer from cloudy to clear that needs to be switched back to
182 ! cloudy in the current layer
183 ! FACCLD2D fraction of cloudy radiance from previous layer that needs to
184 ! be switched to clear stream
185 ! be switched to cloudy stream
186 ! FACCLD1D fraction of the radiance that had been switched in the previous
187 ! layer from clear to cloudy that needs to be switched back to
188 ! clear in the current layer
189 !
190 !--------------------------------------------------------------------------
191 
192 wtnum(1)=_half_
193 wtnum(2)=_zero_
194 wtnum(3)=_zero_
195 
196 !-start JJM_000511
197 IF (tbound < 339._jprb .AND. tbound >= 160._jprb ) THEN
198  indbound = tbound - 159._jprb
199  tbndfrac = tbound - int(tbound)
200 ELSE IF (tbound >= 339._jprb ) THEN
201  indbound = 180
202  tbndfrac = tbound - 339._jprb
203 ELSE IF (tbound < 160._jprb ) THEN
204  indbound = 1
205  tbndfrac = tbound - 160._jprb
206 ENDIF
207 !-end JJM_000511
208 
209 DO lay = 0, klev
210  totufluc(lay) = _zero_
211  totdfluc(lay) = _zero_
212  totuflux(lay) = _zero_
213  totdflux(lay) = _zero_
214 !-start JJM_000511
215  IF (tz(lay) < 339._jprb .AND. tz(lay) >= 160._jprb ) THEN
216  indlev(lay) = tz(lay) - 159._jprb
217  tlevfrac(lay) = tz(lay) - int(tz(lay))
218  ELSE IF (tz(lay) >= 339._jprb ) THEN
219  indlev(lay) = 180
220  tlevfrac(lay) = tz(lay) - 339._jprb
221  ELSE IF (tz(lay) < 160._jprb ) THEN
222  indlev(lay) = 1
223  tlevfrac(lay) = tz(lay) - 160._jprb
224  ENDIF
225 !-end JJM_000511
226 ENDDO
227 
228 !_start_jjm 991209
229 DO lev=0,klev
230  faccld1(lev+1) = _zero_
231  faccld2(lev+1) = _zero_
232  facclr1(lev+1) = _zero_
233  facclr2(lev+1) = _zero_
234  faccmb1(lev+1) = _zero_
235  faccmb2(lev+1) = _zero_
236  faccld1d(lev) = _zero_
237  faccld2d(lev) = _zero_
238  facclr1d(lev) = _zero_
239  facclr2d(lev) = _zero_
240  faccmb1d(lev) = _zero_
241  faccmb2d(lev) = _zero_
242 END DO
243 rat1 = _zero_
244 rat2 = _zero_
245 !_end_jjm 991209
246 
247 
248 
249 sumpl = _zero_
250 sumplem = _zero_
251 
252 istcld(1) = 1
253 istcldd(klev) = 1
254 
255 DO lev = 1, klev
256 !-- DS_000515
257 !-start JJM_000511
258  IF (tavel(lev) < 339._jprb .AND. tavel(lev) >= 160._jprb ) THEN
259  indlay(lev) = tavel(lev) - 159._jprb
260  tlayfrac(lev) = tavel(lev) - int(tavel(lev))
261  ELSE IF (tavel(lev) >= 339._jprb ) THEN
262  indlay(lev) = 180
263  tlayfrac(lev) = tavel(lev) - 339._jprb
264  ELSE IF (tavel(lev) < 160._jprb ) THEN
265  indlay(lev) = 1
266  tlayfrac(lev) = tavel(lev) - 160._jprb
267  ENDIF
268 !-end JJM_000511
269 END DO
270 !-- DS_000515
271 
272 !-- DS_000515
273 !OCL SCALAR
274 
275 DO lev = 1, klev
276  IF (icldlyr(lev) == 1) THEN
277 
278 !mji
279  istcld(lev+1) = 0
280  IF (lev == klev) THEN
281  faccld1(lev+1) = _zero_
282  faccld2(lev+1) = _zero_
283  facclr1(lev+1) = _zero_
284  facclr2(lev+1) = _zero_
285 !-- DS_000515
286 ! FACCMB1(LEV+1) = _ZERO_
287 ! FACCMB2(LEV+1) = _ZERO_
288 !mji ISTCLD(LEV+1) = _ZERO_
289  ELSEIF (cldfrac(lev+1) >= cldfrac(lev)) THEN
290  faccld1(lev+1) = _zero_
291  faccld2(lev+1) = _zero_
292  IF (istcld(lev) == 1) THEN
293 !mji ISTCLD(LEV+1) = 0
294  facclr1(lev+1) = _zero_
295 !mji
296  facclr2(lev+1) = _zero_
297  IF (cldfrac(lev) < _one_) THEN
298  facclr2(lev+1) = (cldfrac(lev+1)-cldfrac(lev))/&
299  &(_one_-cldfrac(lev))
300  END IF
301  ELSE
302  fmax = max(cldfrac(lev),cldfrac(lev-1))
303 !mji
304  IF (cldfrac(lev+1) > fmax) THEN
305  facclr1(lev+1) = rat2
306  facclr2(lev+1) = (cldfrac(lev+1)-fmax)/(_one_-fmax)
307 !mji
308  ELSE IF (cldfrac(lev+1) < fmax) THEN
309  facclr1(lev+1) = (cldfrac(lev+1)-cldfrac(lev))/&
310  &(cldfrac(lev-1)-cldfrac(lev))
311  facclr2(lev+1) = _zero_
312 !mji
313  ELSE
314  facclr1(lev+1) = rat2
315  facclr2(lev+1) = _zero_
316  ENDIF
317  ENDIF
318  IF (facclr1(lev+1) > _zero_ .OR. facclr2(lev+1) > _zero_) THEN
319  rat1 = _one_
320  rat2 = _zero_
321  ENDIF
322  ELSE
323  facclr1(lev+1) = _zero_
324  facclr2(lev+1) = _zero_
325  IF (istcld(lev) == 1) THEN
326 !mji ISTCLD(LEV+1) = 0
327  faccld1(lev+1) = _zero_
328  faccld2(lev+1) = (cldfrac(lev)-cldfrac(lev+1))/cldfrac(lev)
329  ELSE
330  fmin = min(cldfrac(lev),cldfrac(lev-1))
331  IF (cldfrac(lev+1) <= fmin) THEN
332  faccld1(lev+1) = rat1
333  faccld2(lev+1) = (fmin-cldfrac(lev+1))/fmin
334  ELSE
335  faccld1(lev+1) = (cldfrac(lev)-cldfrac(lev+1))/&
336  &(cldfrac(lev)-fmin)
337  faccld2(lev+1) = _zero_
338  ENDIF
339  ENDIF
340  IF (faccld1(lev+1) > _zero_ .OR. faccld2(lev+1) > _zero_) THEN
341  rat1 = _zero_
342  rat2 = _one_
343  ENDIF
344  ENDIF
345 !fcc
346  IF (lev == 1) THEN
347  faccmb1(lev+1) = 0.
348  faccmb2(lev+1) = faccld1(lev+1) * facclr2(lev)
349  ELSE
350  faccmb1(lev+1) = facclr1(lev+1) * faccld2(lev) *cldfrac(lev-1)
351  faccmb2(lev+1) = faccld1(lev+1) * facclr2(lev) *&
352  &(_one_ - cldfrac(lev-1))
353  ENDIF
354 !end fcc
355  ELSE
356 !-- DS_000515
357  istcld(lev+1) = 1
358  ENDIF
359 ENDDO
360 
361 !_start_jjm 991209
362 rat1 = _zero_
363 rat2 = _zero_
364 !_end_jjm 991209
365 
366 !-- DS_000515
367 !OCL SCALAR
368 
369 DO lev = klev, 1, -1
370  IF (icldlyr(lev) == 1) THEN
371 !mji
372  istcldd(lev-1) = 0
373  IF (lev == 1) THEN
374  faccld1d(lev-1) = _zero_
375  faccld2d(lev-1) = _zero_
376  facclr1d(lev-1) = _zero_
377  facclr2d(lev-1) = _zero_
378  faccmb1d(lev-1) = _zero_
379  faccmb2d(lev-1) = _zero_
380 !mji ISTCLDD(LEV-1) = _ZERO_
381  ELSEIF (cldfrac(lev-1) >= cldfrac(lev)) THEN
382  faccld1d(lev-1) = _zero_
383  faccld2d(lev-1) = _zero_
384  IF (istcldd(lev) == 1) THEN
385 !mji ISTCLDD(LEV-1) = 0
386  facclr1d(lev-1) = _zero_
387  facclr2d(lev-1) = _zero_
388  IF (cldfrac(lev) < _one_) THEN
389  facclr2d(lev-1) = (cldfrac(lev-1)-cldfrac(lev))/&
390  &(_one_-cldfrac(lev))
391  END IF
392  ELSE
393  fmax = max(cldfrac(lev),cldfrac(lev+1))
394 !mji
395  IF (cldfrac(lev-1) > fmax) THEN
396  facclr1d(lev-1) = rat2
397  facclr2d(lev-1) = (cldfrac(lev-1)-fmax)/(_one_-fmax)
398 !mji
399  ELSE IF (cldfrac(lev-1) < fmax) THEN
400  facclr1d(lev-1) = (cldfrac(lev-1)-cldfrac(lev))/&
401  &(cldfrac(lev+1)-cldfrac(lev))
402  facclr2d(lev-1) = _zero_
403 !mji
404  ELSE
405  facclr1d(lev-1) = rat2
406  facclr2d(lev-1) = _zero_
407  ENDIF
408  ENDIF
409  IF (facclr1d(lev-1) > _zero_ .OR. facclr2d(lev-1) > _zero_)THEN
410  rat1 = _one_
411  rat2 = _zero_
412  ENDIF
413  ELSE
414  facclr1d(lev-1) = _zero_
415  facclr2d(lev-1) = _zero_
416  IF (istcldd(lev) == 1) THEN
417 !mji ISTCLDD(LEV-1) = 0
418  faccld1d(lev-1) = _zero_
419  faccld2d(lev-1) = (cldfrac(lev)-cldfrac(lev-1))/cldfrac(lev)
420  ELSE
421  fmin = min(cldfrac(lev),cldfrac(lev+1))
422  IF (cldfrac(lev-1) <= fmin) THEN
423  faccld1d(lev-1) = rat1
424  faccld2d(lev-1) = (fmin-cldfrac(lev-1))/fmin
425  ELSE
426  faccld1d(lev-1) = (cldfrac(lev)-cldfrac(lev-1))/&
427  &(cldfrac(lev)-fmin)
428  faccld2d(lev-1) = _zero_
429  ENDIF
430  ENDIF
431  IF (faccld1d(lev-1) > _zero_ .OR. faccld2d(lev-1) > _zero_)THEN
432  rat1 = _zero_
433  rat2 = _one_
434  ENDIF
435  ENDIF
436  faccmb1d(lev-1) = facclr1d(lev-1) * faccld2d(lev) *cldfrac(lev+1)
437  faccmb2d(lev-1) = faccld1d(lev-1) * facclr2d(lev) *&
438  &(_one_ - cldfrac(lev+1))
439  ELSE
440  istcldd(lev-1) = 1
441  ENDIF
442 ENDDO
443 
444 
445 !- Loop over frequency bands.
446 
447 DO iband = istart, iend
448  dbdtlev = totplnk(indbound+1,iband)-totplnk(indbound,iband)
449  plankbnd = delwave(iband) * (totplnk(indbound,iband) + tbndfrac * dbdtlev)
450  dbdtlev = totplnk(indlev(0)+1,iband) -totplnk(indlev(0),iband)
451 !-- DS_000515
452  plvl(0,iband) = delwave(iband)&
453  &* (totplnk(indlev(0),iband) + tlevfrac(0)*dbdtlev)
454 
455  surfemis(iband) = semiss(iband)
456  plnkemit(iband) = surfemis(iband) * plankbnd
457  sumplem = sumplem + plnkemit(iband)
458  sumpl = sumpl + plankbnd
459 !--DS
460 ENDDO
461 !---
462 
463 !-- DS_000515
464 DO iband = istart, iend
465  DO lev = 1, klev
466 !----
467 !- Calculate the integrated Planck functions for at the
468 ! level and layer temperatures.
469 ! Compute cloud transmittance for cloudy layers.
470  dbdtlev = totplnk(indlev(lev)+1,iband) - totplnk(indlev(lev),iband)
471  dbdtlay = totplnk(indlay(lev)+1,iband) - totplnk(indlay(lev),iband)
472 !-- DS_000515
473  play(lev,iband) = delwave(iband)&
474  &*(totplnk(indlay(lev),iband)+tlayfrac(lev)*dbdtlay)
475  plvl(lev,iband) = delwave(iband)&
476  &*(totplnk(indlev(lev),iband)+tlevfrac(lev)*dbdtlev)
477  IF (icldlyr(lev) > 0) THEN
478  trncld(lev,iband) = exp(-taucld(lev,iband))
479  ENDIF
480 !-- DS_000515
481  ENDDO
482 
483 ENDDO
484 
485 semislw = sumplem / sumpl
486 
487 !--DS
488 DO ipr = 1, jpgpt
489  nbi = ngb(ipr)
490  DO lev = 1 , klev
491 !-- DS_000515
492  zplay(ipr,lev) = play(lev,nbi)
493  zplvl(ipr,lev) = plvl(lev-1,nbi)
494  ztaucld(ipr,lev) = taucld(lev,nbi)
495  ztrncld(ipr,lev) = trncld(lev,nbi)
496 !-- DS_000515
497  ENDDO
498 ENDDO
499 !----
500 
501 !- For cloudy layers, set cloud parameters for radiative transfer.
502 DO lev = 1, klev
503  IF (icldlyr(lev) > 0) THEN
504  DO ipr = 1, jpgpt
505 !--DS
506 ! NBI = NGB(IPR)
507  odcldnw(ipr,lev) = ztaucld(ipr,lev)
508  abscldnw(ipr,lev) = _one_ - ztrncld(ipr,lev)
509 !----
510 ! EFCLFRNW(IPR,LEV) = ABSCLDNW(IPR,LEV) * CLDFRAC(LEV)
511  ENDDO
512  ENDIF
513 ENDDO
514 
515 !- Initialize for radiative transfer.
516 DO ipr = 1, jpgpt
517  radclrd1(ipr) = _zero_
518  radld1(ipr) = _zero_
519  nbi = ngb(ipr)
520  semis(ipr) = surfemis(nbi)
521  raduemit(ipr) = pfrac(ipr,1) * plnkemit(nbi)
522 !-- DS_000515
523  bglev(ipr) = pfrac(ipr,klev) * plvl(klev,nbi)
524 ENDDO
525 
526 !- Downward radiative transfer.
527 ! *** DRAD1 holds summed radiance for total sky stream
528 ! *** DRADCL1 holds summed radiance for clear sky stream
529 
530 iclddn = 0
531 DO lev = klev, 1, -1
532  drad1 = _zero_
533  dradcl1 = _zero_
534 
535  IF (icldlyr(lev) == 1) THEN
536 
537 ! *** Cloudy layer
538  iclddn = 1
539  ient = jpgpt * (lev-1)
540  DO ipr = 1, jpgpt
541  index = ient + ipr
542 !--DS
543 ! NBI = NGB(IPR)
544  bglay = pfrac(ipr,lev) * zplay(ipr,lev)
545 !----
546  delbgup = bglev(ipr) - bglay
547  bbu1(index) = bglay + tausf1(index) * delbgup
548 !--DS
549  bglev(ipr) = pfrac(ipr,lev) * zplvl(ipr,lev)
550 !----
551  delbgdn = bglev(ipr) - bglay
552  bbd = bglay + tausf1(index) * delbgdn
553 !- total-sky downward flux
554  odsm = od(ipr,lev) + odcldnw(ipr,lev)
555  factot1 = odsm / (bpade + odsm)
556  bbutot1(index) = bglay + factot1 * delbgup
557  atot1(index) = abss1(index) + abscldnw(ipr,lev)&
558  &- abss1(index) * abscldnw(ipr,lev)
559  bbdtot = bglay + factot1 * delbgdn
560  gassrc = bbd * abss1(index)
561 !***
562  IF (istcldd(lev) == 1) THEN
563  cldradd(ipr) = cldfrac(lev) * radld1(ipr)
564  clrradd(ipr) = radld1(ipr) - cldradd(ipr)
565  oldcld(ipr) = cldradd(ipr)
566  oldclr(ipr) = clrradd(ipr)
567  rad(ipr) = _zero_
568  ENDIF
569  ttot = _one_ - atot1(index)
570  cldsrc = bbdtot * atot1(index)
571 
572 ! Separate RT equations for clear and cloudy streams
573  cldradd(ipr) = cldradd(ipr) * ttot + cldfrac(lev) * cldsrc
574  clrradd(ipr) = clrradd(ipr) * (_one_-abss1(index)) +&
575  &(_one_ - cldfrac(lev)) * gassrc
576 
577 ! Total sky downward radiance
578  radld1(ipr) = cldradd(ipr) + clrradd(ipr)
579  drad1 = drad1 + radld1(ipr)
580 
581 ! Clear-sky downward radiance
582  radclrd1(ipr) = radclrd1(ipr)+(bbd-radclrd1(ipr))*abss1(index)
583  dradcl1 = dradcl1 + radclrd1(ipr)
584 
585 !* Code to account for maximum/random overlap:
586 ! Performs RT on the radiance most recently switched between clear and
587 ! cloudy streams
588  radmod = rad(ipr) * (facclr1d(lev-1) * (_one_-abss1(index)) +&
589  &faccld1d(lev-1) * ttot) - &
590  &faccmb1d(lev-1) * gassrc + &
591  &faccmb2d(lev-1) * cldsrc
592 
593 ! Computes what the clear and cloudy streams would have been had no
594 ! radiance been switched
595  oldcld(ipr) = cldradd(ipr) - radmod
596  oldclr(ipr) = clrradd(ipr) + radmod
597 
598 ! Computes the radiance to be switched between clear and cloudy.
599  rad(ipr) = -radmod + facclr2d(lev-1)*oldclr(ipr) -&
600  &faccld2d(lev-1)*oldcld(ipr)
601  cldradd(ipr) = cldradd(ipr) + rad(ipr)
602  clrradd(ipr) = clrradd(ipr) - rad(ipr)
603 !***
604 
605  ENDDO
606 
607  ELSE
608 
609 ! *** Clear layer
610 ! *** DRAD1 holds summed radiance for total sky stream
611 ! *** DRADCL1 holds summed radiance for clear sky stream
612 
613  ient = jpgpt * (lev-1)
614  IF (iclddn == 1) THEN
615  DO ipr = 1, jpgpt
616  index = ient + ipr
617 !--DS
618 ! NBI = NGB(IPR)
619  bglay = pfrac(ipr,lev) * zplay(ipr,lev)
620 !----
621  delbgup = bglev(ipr) - bglay
622  bbu1(index) = bglay + tausf1(index) * delbgup
623 !--DS
624  bglev(ipr) = pfrac(ipr,lev) * zplvl(ipr,lev)
625 !----
626  delbgdn = bglev(ipr) - bglay
627  bbd = bglay + tausf1(index) * delbgdn
628 
629 !- total-sky downward radiance
630  radld1(ipr) = radld1(ipr)+(bbd-radld1(ipr))*abss1(index)
631  drad1 = drad1 + radld1(ipr)
632 
633 !- clear-sky downward radiance
634 !- Set clear sky stream to total sky stream as long as layers
635 !- remain clear. Streams diverge when a cloud is reached.
636  radclrd1(ipr) = radclrd1(ipr)+(bbd-radclrd1(ipr))*abss1(index)
637  dradcl1 = dradcl1 + radclrd1(ipr)
638  ENDDO
639 
640  ELSE
641 
642  DO ipr = 1, jpgpt
643  index = ient + ipr
644 !--DS
645 ! NBI = NGB(IPR)
646  bglay = pfrac(ipr,lev) * zplay(ipr,lev)
647 !----
648  delbgup = bglev(ipr) - bglay
649  bbu1(index) = bglay + tausf1(index) * delbgup
650 !--DS
651  bglev(ipr) = pfrac(ipr,lev) * zplvl(ipr,lev)
652 !----
653  delbgdn = bglev(ipr) - bglay
654  bbd = bglay + tausf1(index) * delbgdn
655 !- total-sky downward flux
656  radld1(ipr) = radld1(ipr)+(bbd-radld1(ipr))*abss1(index)
657  drad1 = drad1 + radld1(ipr)
658 !- clear-sky downward flux
659 !- Set clear sky stream to total sky stream as long as layers
660 !- remain clear. Streams diverge when a cloud is reached.
661  radclrd1(ipr) = radld1(ipr)
662  ENDDO
663  dradcl1 = drad1
664  ENDIF
665 
666  ENDIF
667 
668  totdfluc(lev-1) = dradcl1 * wtnum(1)
669  totdflux(lev-1) = drad1 * wtnum(1)
670 
671 ENDDO
672 
673 
674 
675 
676 
677 ! Spectral reflectivity and reflectance
678 ! Includes the contribution of spectrally varying longwave emissivity
679 ! and reflection from the surface to the upward radiative transfer.
680 ! Note: Spectral and Lambertian reflections are identical for the one
681 ! angle flux integration used here.
682 
683 urad1 = _zero_
684 uradcl1 = _zero_
685 
686 !start JJM_000511
687 !IF (IREFLECT == 0) THEN
688 !- Lambertian reflection.
689  DO ipr = 1, jpgpt
690 ! Clear-sky radiance
691 ! RADCLD = _TWO_ * (RADCLRD1(IPR) * WTNUM(1) )
692  radcld = radclrd1(ipr)
693  radclru1(ipr) = raduemit(ipr) + (_one_ - semis(ipr)) * radcld
694  uradcl1 = uradcl1 + radclru1(ipr)
695 
696 ! Total sky radiance
697 ! RADD = _TWO_ * (RADLD1(IPR) * WTNUM(1) )
698  radd = radld1(ipr)
699  radlu1(ipr) = raduemit(ipr) + (_one_ - semis(ipr)) * radd
700  urad1 = urad1 + radlu1(ipr)
701  ENDDO
702  totufluc(0) = uradcl1 * _half_
703  totuflux(0) = urad1 * _half_
704 !ELSE
705 !!- Specular reflection.
706 ! DO IPR = 1, JPGPT
707 ! RADCLU = RADUEMIT(IPR)
708 ! RADCLRU1(IPR) = RADCLU + (_ONE_ - SEMIS(IPR)) * RADCLRD1(IPR)
709 ! URADCL1 = URADCL1 + RADCLRU1(IPR)
710 !
711 ! RADU = RADUEMIT(IPR)
712 ! RADLU1(IPR) = RADU + (_ONE_ - SEMIS(IPR)) * RADLD1(IPR)
713 ! URAD1 = URAD1 + RADLU1(IPR)
714 ! ENDDO
715 ! TOTUFLUC(0) = URADCL1 * WTNUM(1)
716 ! TOTUFLUX(0) = URAD1 * WTNUM(1)
717 !ENDIF
718 
719 !- Upward radiative transfer.
720 !- *** URAD1 holds the summed radiance for total sky stream
721 !- *** URADCL1 holds the summed radiance for clear sky stream
722 DO lev = 1, klev
723  urad1 = _zero_
724  uradcl1 = _zero_
725 
726 ! Check flag for cloud in current layer
727  IF (icldlyr(lev) == 1) THEN
728 
729 !- *** Cloudy layer
730  ient = jpgpt * (lev-1)
731  DO ipr = 1, jpgpt
732  index = ient + ipr
733 !- total-sky upward flux
734  gassrc = bbu1(index) * abss1(index)
735 !
736 !- If first cloudy layer in sequence, split up radiance into clear and
737 ! cloudy streams depending on cloud fraction
738  IF (istcld(lev) == 1) THEN
739  cldradu(ipr) = cldfrac(lev) * radlu1(ipr)
740  clrradu(ipr) = radlu1(ipr) - cldradu(ipr)
741  oldcld(ipr) = cldradu(ipr)
742  oldclr(ipr) = clrradu(ipr)
743  rad(ipr) = _zero_
744  ENDIF
745  ttot = _one_ - atot1(index)
746  trns = _one_ - abss1(index)
747  cldsrc = bbutot1(index) * atot1(index)
748 !
749 !- Separate RT equations for clear and cloudy streams
750  cldradu(ipr) = cldradu(ipr) * ttot + cldfrac(lev) * cldsrc
751  clrradu(ipr) = clrradu(ipr) * trns +(_one_ - cldfrac(lev)) * gassrc
752 !***
753 
754 !- total sky upward flux
755  radlu1(ipr) = cldradu(ipr) + clrradu(ipr)
756  urad1 = urad1 + radlu1(ipr)
757 
758 !- clear-sky upward flux
759  radclru1(ipr) = radclru1(ipr) + (bbu1(index)-radclru1(ipr))&
760  &*abss1(index)
761  uradcl1 = uradcl1 + radclru1(ipr)
762 
763 !* Code to account for maximum/random overlap:
764 ! Performs RT on the radiance most recently switched between clear and
765 ! cloudy streams
766  radmod = rad(ipr) * (facclr1(lev+1) * trns +&
767  &faccld1(lev+1) * ttot) - &
768  &faccmb1(lev+1) * gassrc + &
769  &faccmb2(lev+1) * cldsrc
770 
771 ! Computes what the clear and cloudy streams would have been had no
772 ! radiance been switched
773  oldcld(ipr) = cldradu(ipr) - radmod
774  oldclr(ipr) = clrradu(ipr) + radmod
775 
776 ! Computes the radiance to be switched between clear and cloudy.
777  rad(ipr) = -radmod + facclr2(lev+1)*oldclr(ipr) -&
778  &faccld2(lev+1)*oldcld(ipr)
779  cldradu(ipr) = cldradu(ipr) + rad(ipr)
780  clrradu(ipr) = clrradu(ipr) - rad(ipr)
781 !***
782  ENDDO
783 
784  ELSE
785 
786 !- *** Clear layer
787  ient = jpgpt * (lev-1)
788  DO ipr = 1, jpgpt
789  index = ient + ipr
790 !- total-sky upward flux
791  radlu1(ipr) = radlu1(ipr)+(bbu1(index)-radlu1(ipr))*abss1(index)
792  urad1 = urad1 + radlu1(ipr)
793 !- clear-sky upward flux
794 ! Upward clear and total sky streams must be separate because surface
795 ! reflectance is different for each.
796  radclru1(ipr) = radclru1(ipr)+(bbu1(index)-radclru1(ipr))*abss1(index)
797  uradcl1 = uradcl1 + radclru1(ipr)
798  ENDDO
799 
800  ENDIF
801 
802  totufluc(lev) = uradcl1 * wtnum(1)
803  totuflux(lev) = urad1 * wtnum(1)
804 
805 ENDDO
806 
807 
808 !* Convert radiances to fluxes and heating rates for total and clear sky.
809 ! ** NB: moved to calling routine
810 ! TOTUFLUC(0) = TOTUFLUC(0) * FLUXFAC
811 ! TOTDFLUC(0) = TOTDFLUC(0) * FLUXFAC
812 ! TOTUFLUX(0) = TOTUFLUX(0) * FLUXFAC
813 ! TOTDFLUX(0) = TOTDFLUX(0) * FLUXFAC
814 
815 ! CLFNET(0) = TOTUFLUC(0) - TOTDFLUC(0)
816 ! FNET(0) = TOTUFLUX(0) - TOTDFLUX(0)
817 ! DO LEV = 1, KLEV
818 ! TOTUFLUC(LEV) = TOTUFLUC(LEV) * FLUXFAC
819 ! TOTDFLUC(LEV) = TOTDFLUC(LEV) * FLUXFAC
820 ! CLFNET(LEV) = TOTUFLUC(LEV) - TOTDFLUC(LEV)
821 
822 ! TOTUFLUX(LEV) = TOTUFLUX(LEV) * FLUXFAC
823 ! TOTDFLUX(LEV) = TOTDFLUX(LEV) * FLUXFAC
824 ! FNET(LEV) = TOTUFLUX(LEV) - TOTDFLUX(LEV)
825 ! L = LEV - 1
826 
827 !- Calculate Heating Rates.
828 ! CLHTR(L)=HEATFAC*(CLFNET(L)-CLFNET(LEV))/(PZ(L)-PZ(LEV))
829 ! HTR(L) =HEATFAC*(FNET(L) -FNET(LEV)) /(PZ(L)-PZ(LEV))
830 ! END DO
831 ! CLHTR(KLEV) = 0.0
832 ! HTR(KLEV) = 0.0
833 
834 RETURN
835 END SUBROUTINE rrtm_rtrn1a_140gp
yoerrtftr::ngb
integer(kind=jpim), dimension(jpgpt) ngb
Definition: yoerrtftr.F90:18
dimphy::klev
integer, save klev
Definition: dimphy.F90:7
parrrtm::jpgpt
integer(kind=jpim), parameter jpgpt
Definition: parrrtm.F90:21
parrrtm::jpband
integer(kind=jpim), parameter jpband
Definition: parrrtm.F90:18
rad
!$Id mode_top_bound COMMON comconstr rad
Definition: comconst.h:7
yoerrtwn::totplnk
real(kind=jprb), dimension(181, 16) totplnk
Definition: yoerrtwn.F90:19
parrrtm::jplay
integer(kind=jpim), parameter jplay
Definition: parrrtm.F90:15
yoerrtwn::delwave
real(kind=jprb), dimension(16) delwave
Definition: yoerrtwn.F90:17
play
!$Id Turb_fcg!implicit none!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc!cette routine permet d obtenir hq et ainsi de!pouvoir calculer la convergence et le cisaillement dans la physiq!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc INTEGER klev REAL in CHARACTER file_fordat COMMON com1_phys_gcss play
Definition: 1Dconv.h:27
yoerrtab::bpade
real(kind=jprb) bpade
Definition: yoerrtab.F90:14
rrtm_rtrn1a_140gp
subroutine rrtm_rtrn1a_140gp(KLEV, K_ISTART, K_IEND, K_ICLDLYR, P_CLDFRAC, P_TAUCLD, P_ABSS1, P_OD, P_TAUSF1, P_CLFNET, P_CLHTR, P_FNET, P_HTR, P_TOTDFLUC, P_TOTDFLUX, P_TOTUFLUC, P_TOTUFLUX, P_TAVEL, PZ, P_TZ, P_TBOUND, PFRAC, P_SEMISS, P_SEMISLW, K_IREFLECT)
Definition: rrtm_rtrn1a_140gp.F90:4