LMDZ
srtm_spcvrt.F90
Go to the documentation of this file.
1 #ifdef RS6K
2 @process hot nostrict
3 #endif
4 SUBROUTINE srtm_spcvrt &
5  & ( klev , kmol , ksw , poneminus, &
6  & pavel , ptavel , pz , ptz , ptbound , palbd , palbp, &
7  & pfrcl , ptauc , pasyc , pomgc , ptaua , pasya , pomga , prmu0, &
8  & pcoldry , pwkl, &
9  & klaytrop, klayswtch, klaylow ,&
10  & pco2mult, pcolch4 , pcolco2 , pcolh2o , pcolmol , pcoln2o , pcolo2 , pcolo3 ,&
11  & pforfac , pforfrac , kindfor , pselffac, pselffrac, kindself ,&
12  & pfac00 , pfac01 , pfac10 , pfac11 ,&
13  & kjp , kjt , kjt1 ,&
14 !-- output arrays
15  & pbbfd, pbbfu, puvfd, puvfu, pvsfd, pvsfu , pnifd , pnifu ,&
16  & pbbcd, pbbcu, puvcd, puvcu, pvscd, pvscu , pnicd , pnicu &
17  & )
18 
19 !**** *SRTM_SPCVRT* - SPECTRAL LOOP TO COMPUTE THE SHORTWAVE RADIATION FLUXES.
20 
21 ! PURPOSE.
22 ! --------
23 
24 ! THIS ROUTINE COMPUTES THE TWO-STREAM METHOD OF BARKER
25 
26 !** INTERFACE.
27 ! ----------
28 
29 ! *SRTM_SPCVRT* IS CALLED FROM *SRTM_SRTM_224GP*
30 
31 ! IMPLICIT ARGUMENTS :
32 ! --------------------
33 
34 ! ==== INPUTS ===
35 ! ==== OUTPUTS ===
36 
37 ! METHOD.
38 ! -------
39 
40 ! EXTERNALS.
41 ! ----------
42 
43 ! *SWVRTQDR*
44 
45 ! REFERENCE.
46 ! ----------
47 
48 ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
49 ! DOCUMENTATION
50 ! AUTHOR.
51 ! -------
52 ! from Howard Barker
53 ! JEAN-JACQUES MORCRETTE *ECMWF*
54 
55 ! MODIFICATIONS.
56 ! --------------
57 ! ORIGINAL : 03-02-27
58 ! M.Hamrud 01-Oct-2003 CY28 Cleaning
59 ! ------------------------------------------------------------------
60 
61 USE parkind1 ,ONLY : jpim ,jprb
62 USE yomhook ,ONLY : lhook, dr_hook
63 
64 USE parsrtm , ONLY : jplay, jpb1, jpb2, jpgpt
65 
66 USE yoesrtwn , ONLY : ngc
67 USE yoerdi , ONLY : repclc
68 
69 !USE YOERAD , ONLY : NSW
70 !USE YOERDU , ONLY : RCDAY
71 !USE YOESWN , ONLY : NTBANDS, NBANDS, NGS, NUV, NVS, RWGT, NDBUG
72 
73 IMPLICIT NONE
74 
75 ! ------------------------------------------------------------------
76 
77 !* 0.1 ARGUMENTS
78 ! ---------
79 
80 INTEGER(KIND=JPIM),INTENT(IN) :: KSW
81 INTEGER(KIND=JPIM) :: KLEV ! UNDETERMINED INTENT
82 INTEGER(KIND=JPIM) :: KMOL ! Argument NOT used
83 REAL(KIND=JPRB) :: PONEMINUS ! UNDETERMINED INTENT
84 REAL(KIND=JPRB) :: PAVEL(jplay) ! Argument NOT used
85 REAL(KIND=JPRB) :: PTAVEL(jplay) ! Argument NOT used
86 REAL(KIND=JPRB) :: PZ(0:jplay) ! Argument NOT used
87 REAL(KIND=JPRB) :: PTZ(0:jplay) ! Argument NOT used
88 REAL(KIND=JPRB) :: PTBOUND ! Argument NOT used
89 REAL(KIND=JPRB) ,INTENT(IN) :: PALBD(ksw)
90 REAL(KIND=JPRB) ,INTENT(IN) :: PALBP(ksw)
91 REAL(KIND=JPRB) ,INTENT(IN) :: PFRCL(jplay) ! bottom to top
92 REAL(KIND=JPRB) ,INTENT(IN) :: PTAUC(jplay,ksw) ! bottom to top
93 REAL(KIND=JPRB) ,INTENT(IN) :: PASYC(jplay,ksw) ! bottom to top
94 REAL(KIND=JPRB) ,INTENT(IN) :: POMGC(jplay,ksw) ! bottom to top
95 REAL(KIND=JPRB) ,INTENT(IN) :: PTAUA(jplay,ksw) ! bottom to top
96 REAL(KIND=JPRB) ,INTENT(IN) :: PASYA(jplay,ksw) ! bottom to top
97 REAL(KIND=JPRB) ,INTENT(IN) :: POMGA(jplay,ksw) ! bottom to top
98 REAL(KIND=JPRB) :: PRMU0 ! UNDETERMINED INTENT
99 REAL(KIND=JPRB) :: PCOLDRY(jplay) ! Argument NOT used
100 REAL(KIND=JPRB) :: PWKL(35,jplay) ! Argument NOT used
101 INTEGER(KIND=JPIM) :: KLAYTROP ! UNDETERMINED INTENT
102 INTEGER(KIND=JPIM) :: KLAYSWTCH ! Argument NOT used
103 INTEGER(KIND=JPIM) :: KLAYLOW ! Argument NOT used
104 REAL(KIND=JPRB) :: PCO2MULT(jplay) ! Argument NOT used
105 REAL(KIND=JPRB) :: PCOLCH4(jplay) ! UNDETERMINED INTENT
106 REAL(KIND=JPRB) :: PCOLCO2(jplay) ! UNDETERMINED INTENT
107 REAL(KIND=JPRB) :: PCOLH2O(jplay) ! UNDETERMINED INTENT
108 REAL(KIND=JPRB) :: PCOLMOL(jplay) ! UNDETERMINED INTENT
109 REAL(KIND=JPRB) :: PCOLN2O(jplay) ! Argument NOT used
110 REAL(KIND=JPRB) :: PCOLO2(jplay) ! UNDETERMINED INTENT
111 REAL(KIND=JPRB) :: PCOLO3(jplay) ! UNDETERMINED INTENT
112 REAL(KIND=JPRB) :: PFORFAC(jplay) ! UNDETERMINED INTENT
113 REAL(KIND=JPRB) :: PFORFRAC(jplay) ! UNDETERMINED INTENT
114 INTEGER(KIND=JPIM) :: KINDFOR(jplay) ! UNDETERMINED INTENT
115 REAL(KIND=JPRB) :: PSELFFAC(jplay) ! UNDETERMINED INTENT
116 REAL(KIND=JPRB) :: PSELFFRAC(jplay) ! UNDETERMINED INTENT
117 INTEGER(KIND=JPIM) :: KINDSELF(jplay) ! UNDETERMINED INTENT
118 REAL(KIND=JPRB) :: PFAC00(jplay) ! UNDETERMINED INTENT
119 REAL(KIND=JPRB) :: PFAC01(jplay) ! UNDETERMINED INTENT
120 REAL(KIND=JPRB) :: PFAC10(jplay) ! UNDETERMINED INTENT
121 REAL(KIND=JPRB) :: PFAC11(jplay) ! UNDETERMINED INTENT
122 INTEGER(KIND=JPIM) :: KJP(jplay) ! UNDETERMINED INTENT
123 INTEGER(KIND=JPIM) :: KJT(jplay) ! UNDETERMINED INTENT
124 INTEGER(KIND=JPIM) :: KJT1(jplay) ! UNDETERMINED INTENT
125 REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBFD(jplay+1)
126 REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBFU(jplay+1)
127 REAL(KIND=JPRB) :: PUVFD(jplay+1) ! Argument NOT used
128 REAL(KIND=JPRB) :: PUVFU(jplay+1) ! Argument NOT used
129 REAL(KIND=JPRB) :: PVSFD(jplay+1) ! Argument NOT used
130 REAL(KIND=JPRB) :: PVSFU(jplay+1) ! Argument NOT used
131 REAL(KIND=JPRB) :: PNIFD(jplay+1) ! Argument NOT used
132 REAL(KIND=JPRB) :: PNIFU(jplay+1) ! Argument NOT used
133 REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBCD(jplay+1)
134 REAL(KIND=JPRB) ,INTENT(INOUT) :: PBBCU(jplay+1)
135 REAL(KIND=JPRB) :: PUVCD(jplay+1) ! Argument NOT used
136 REAL(KIND=JPRB) :: PUVCU(jplay+1) ! Argument NOT used
137 REAL(KIND=JPRB) :: PVSCD(jplay+1) ! Argument NOT used
138 REAL(KIND=JPRB) :: PVSCU(jplay+1) ! Argument NOT used
139 REAL(KIND=JPRB) :: PNICD(jplay+1) ! Argument NOT used
140 REAL(KIND=JPRB) :: PNICU(jplay+1) ! Argument NOT used
141 ! ------------------------------------------------------------------
142 
143 ! ------------
144 
145 LOGICAL :: LLRTCHK(jplay)
146 
147 REAL(KIND=JPRB) :: &
148  & ZCLEAR , ZCLOUD &
149  & , ZDBT(JPLAY+1) &
150  & , ZGCC(JPLAY) , ZGCO(JPLAY) &
151  & , ZOMCC(JPLAY) , ZOMCO(JPLAY) &
152  & , ZRDND(JPLAY+1), ZRDNDC(JPLAY+1)&
153  & , ZREF(JPLAY+1) , ZREFC(JPLAY+1) , ZREFO(JPLAY+1) &
154  & , ZREFD(JPLAY+1), ZREFDC(JPLAY+1), ZREFDO(JPLAY+1) &
155  & , ZRUP(JPLAY+1) , ZRUPD(JPLAY+1) &
156  & , ZRUPC(JPLAY+1), ZRUPDC(JPLAY+1)&
157  & , ZTAUC(JPLAY) , ZTAUO(JPLAY) &
158  & , ZTDBT(JPLAY+1) &
159  & , ZTRA(JPLAY+1) , ZTRAC(JPLAY+1) , ZTRAO(JPLAY+1) &
160  & , ZTRAD(JPLAY+1), ZTRADC(JPLAY+1), ZTRADO(JPLAY+1)
161 REAL(KIND=JPRB) :: &
162  & ZDBTC(JPLAY+1), ZTDBTC(JPLAY+1), ZINCFLX(JPGPT) &
163  & , ZINCF14(14) , ZINCTOT
164 
165 INTEGER(KIND=JPIM) :: IB1, IB2, IBM, IGT, IKL, IW, JB, JG, JK, I_KMODTS
166 
167 REAL(KIND=JPRB) :: ZDBTMC, ZDBTMO, ZF, ZINCFLUX, ZWF
168 
169 !-- Output of SRTM_TAUMOLn routines
170 
171 REAL(KIND=JPRB) :: ZTAUG(jplay,16), ZTAUR(jplay,16), ZSFLXZEN(16)
172 
173 !-- Output of SRTM_VRTQDR routine
174 REAL(KIND=JPRB) :: &
175  & ZCD(JPLAY+1,JPGPT), ZCU(JPLAY+1,JPGPT) &
176  & , ZFD(JPLAY+1,JPGPT), ZFU(JPLAY+1,JPGPT)
177 REAL(KIND=JPRB) :: ZHOOK_HANDLE
178 
179 
180 #include "srtm_taumol16.intfb.h"
181 #include "srtm_taumol17.intfb.h"
182 #include "srtm_taumol18.intfb.h"
183 #include "srtm_taumol19.intfb.h"
184 #include "srtm_taumol20.intfb.h"
185 #include "srtm_taumol21.intfb.h"
186 #include "srtm_taumol22.intfb.h"
187 #include "srtm_taumol23.intfb.h"
188 #include "srtm_taumol24.intfb.h"
189 #include "srtm_taumol25.intfb.h"
190 #include "srtm_taumol26.intfb.h"
191 #include "srtm_taumol27.intfb.h"
192 #include "srtm_taumol28.intfb.h"
193 #include "srtm_taumol29.intfb.h"
194 #include "srtm_reftra.intfb.h"
195 #include "srtm_vrtqdr.intfb.h"
196 ! ------------------------------------------------------------------
197 IF (lhook) CALL dr_hook('SRTM_SPCVRT',0,zhook_handle)
198 
199 !-- Two-stream model 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates
200 ! KMODTS is set in SWREFTRA
201 !NDBUG=4
202 
203 ib1=jpb1
204 ib2=jpb2
205 !print *,'IB1, IB2, KSW, KMOL, KLEV: ', IB1,IB2,KSW,KMOL,KLEV
206 
207 iw=0
208 zincflux=0.0_jprb
209 zinctot=0.0_jprb
210 
211 jb=ib1-1
212 DO jb = ib1, ib2
213  ibm = jb-15
214  igt = ngc(ibm)
215  zincf14(ibm)=0.0_jprb
216 
217 ! print *,'=== spectral band === JB= ',JB,' ====== i.e. IBM= ',IBM,' with IGT= ',IGT
218 
219 !-- for each band, computes the gaseous and Rayleigh optical thickness
220 ! for all g-points within the band
221 
222  IF (jb == 16) THEN
223  CALL srtm_taumol16 &
224  & ( klev ,&
225  & pfac00 , pfac01 , pfac10 , pfac11 ,&
226  & kjp , kjt , kjt1 , poneminus,&
227  & pcolh2o , pcolch4 , pcolmol ,&
228  & klaytrop, pselffac , pselffrac, kindself, pforfac , pforfrac, kindfor ,&
229  & zsflxzen, ztaug , ztaur &
230  & )
231 ! print *,'After SRTM_TAUMOL16'
232 
233  ELSEIF (jb == 17) THEN
234  CALL srtm_taumol17 &
235  & ( klev ,&
236  & pfac00 , pfac01 , pfac10 , pfac11 ,&
237  & kjp , kjt , kjt1 , poneminus ,&
238  & pcolh2o , pcolco2 , pcolmol ,&
239  & klaytrop, pselffac, pselffrac, kindself , pforfac, pforfrac, kindfor ,&
240  & zsflxzen, ztaug , ztaur &
241  & )
242 ! print *,'After SRTM_TAUMOL17'
243 
244  ELSEIF (jb == 18) THEN
245  CALL srtm_taumol18 &
246  & ( klev ,&
247  & pfac00 , pfac01 , pfac10 , pfac11 ,&
248  & kjp , kjt , kjt1 , poneminus ,&
249  & pcolh2o , pcolch4 , pcolmol ,&
250  & klaytrop, pselffac, pselffrac, kindself , pforfac, pforfrac, kindfor ,&
251  & zsflxzen, ztaug , ztaur &
252  & )
253 ! print *,'After SRTM_TAUMOL18'
254 
255  ELSEIF (jb == 19) THEN
256  CALL srtm_taumol19 &
257  & ( klev ,&
258  & pfac00 , pfac01 , pfac10 , pfac11 ,&
259  & kjp , kjt , kjt1 , poneminus ,&
260  & pcolh2o , pcolco2 , pcolmol ,&
261  & klaytrop, pselffac, pselffrac, kindself , pforfac, pforfrac, kindfor ,&
262  & zsflxzen, ztaug , ztaur &
263  & )
264 ! print *,'After SRTM_TAUMOL19'
265 
266  ELSEIF (jb == 20) THEN
267  CALL srtm_taumol20 &
268  & ( klev ,&
269  & pfac00 , pfac01 , pfac10 , pfac11 ,&
270  & kjp , kjt , kjt1 , poneminus ,&
271  & pcolh2o , pcolch4 , pcolmol ,&
272  & klaytrop, pselffac, pselffrac, kindself , pforfac, pforfrac, kindfor ,&
273  & zsflxzen, ztaug , ztaur &
274  & )
275 ! print *,'After SRTM_TAUMOL20'
276 
277  ELSEIF (jb == 21) THEN
278  CALL srtm_taumol21 &
279  & ( klev ,&
280  & pfac00 , pfac01 , pfac10 , pfac11 ,&
281  & kjp , kjt , kjt1 , poneminus ,&
282  & pcolh2o , pcolco2 , pcolmol ,&
283  & klaytrop, pselffac, pselffrac, kindself , pforfac, pforfrac, kindfor ,&
284  & zsflxzen, ztaug , ztaur &
285  & )
286 ! print *,'After SRTM_TAUMOL21'
287 
288  ELSEIF (jb == 22) THEN
289  CALL srtm_taumol22 &
290  & ( klev ,&
291  & pfac00 , pfac01 , pfac10 , pfac11 ,&
292  & kjp , kjt , kjt1 , poneminus ,&
293  & pcolh2o , pcolmol , pcolo2 ,&
294  & klaytrop, pselffac, pselffrac, kindself , pforfac, pforfrac, kindfor ,&
295  & zsflxzen, ztaug , ztaur &
296  & )
297 ! print *,'After SRTM_TAUMOL22'
298 
299  ELSEIF (jb == 23) THEN
300  CALL srtm_taumol23 &
301  & ( klev ,&
302  & pfac00 , pfac01 , pfac10 , pfac11 ,&
303  & kjp , kjt , kjt1 , poneminus ,&
304  & pcolh2o , pcolmol ,&
305  & klaytrop, pselffac, pselffrac, kindself , pforfac, pforfrac, kindfor ,&
306  & zsflxzen, ztaug , ztaur &
307  & )
308 ! print *,'After SRTM_TAUMOL23'
309 
310  ELSEIF (jb == 24) THEN
311  CALL srtm_taumol24 &
312  & ( klev ,&
313  & pfac00 , pfac01 , pfac10 , pfac11 ,&
314  & kjp , kjt , kjt1 , poneminus ,&
315  & pcolh2o , pcolmol , pcolo2 , pcolo3 ,&
316  & klaytrop, pselffac, pselffrac, kindself , pforfac, pforfrac, kindfor ,&
317  & zsflxzen, ztaug , ztaur &
318  & )
319 ! print *,'After SRTM_TAUMOL24'
320 
321  ELSEIF (jb == 25) THEN
322 !--- visible 16000-22650 cm-1 0.4415 - 0.6250 um
323  CALL srtm_taumol25 &
324  & ( klev ,&
325  & pfac00 , pfac01 , pfac10 , pfac11 ,&
326  & kjp , kjt , kjt1 , poneminus ,&
327  & pcolh2o , pcolmol , pcolo3 ,&
328  & klaytrop ,&
329  & zsflxzen, ztaug , ztaur &
330  & )
331 ! print *,'After SRTM_TAUMOL25'
332 
333  ELSEIF (jb == 26) THEN
334 !--- UV-A 22650-29000 cm-1 0.3448 - 0.4415 um
335  CALL srtm_taumol26 &
336  & ( klev ,&
337  & pfac00 , pfac01 , pfac10 , pfac11 ,&
338  & kjp , kjt , kjt1 , poneminus ,&
339  & pcolh2o , pcolco2 , pcolmol ,&
340  & klaytrop, pselffac, pselffrac, kindself , pforfac, pforfrac, kindfor ,&
341  & zsflxzen, ztaug , ztaur &
342  & )
343 ! print *,'After SRTM_TAUMOL26'
344 
345  ELSEIF (jb == 27) THEN
346 !--- UV-B 29000-38000 cm-1 0.2632 - 0.3448 um
347  CALL srtm_taumol27 &
348  & ( klev ,&
349  & pfac00 , pfac01 , pfac10 , pfac11 ,&
350  & kjp , kjt , kjt1 , poneminus ,&
351  & pcolmol , pcolo3 ,&
352  & klaytrop ,&
353  & zsflxzen, ztaug , ztaur &
354  & )
355 ! print *,'After SRTM_TAUMOL27'
356 
357  ELSEIF (jb == 28) THEN
358 !--- UV-C 38000-50000 cm-1 0.2000 - 0.2632 um
359  CALL srtm_taumol28 &
360  & ( klev ,&
361  & pfac00 , pfac01 , pfac10 , pfac11 ,&
362  & kjp , kjt , kjt1 , poneminus ,&
363  & pcolmol , pcolo2 , pcolo3 ,&
364  & klaytrop ,&
365  & zsflxzen, ztaug , ztaur &
366  & )
367 ! print *,'After SRTM_TAUMOL28'
368 
369  ELSEIF (jb == 29) THEN
370  CALL srtm_taumol29 &
371  & ( klev ,&
372  & pfac00 , pfac01 , pfac10 , pfac11 ,&
373  & kjp , kjt , kjt1 , poneminus ,&
374  & pcolh2o , pcolco2 , pcolmol ,&
375  & klaytrop , pselffac, pselffrac, kindself , pforfac, pforfrac, kindfor ,&
376  & zsflxzen , ztaug , ztaur &
377  & )
378 ! print *,'After SRTM_TAUMOL29'
379 
380  ENDIF
381 
382 ! IF (NDBUG.LE.3) THEN
383 ! print *,'Incident Solar Flux'
384 ! PRINT 9010,(ZSFLXZEN(JG),JG=1,16)
385  9010 format(1x,'SolFlx ',16f8.4)
386 ! print *,'Optical thickness for molecular absorption for JB= ',JB
387 ! DO JK=1,KLEV
388 ! PRINT 9011,JK,(ZTAUG(JK,JG),JG=1,16)
389  9011 format(1x,'TauGas ',i3,16e9.2)
390 ! ENDDO
391 ! print *,'Optical thickness for Rayleigh scattering for JB= ',JB
392 ! DO JK=1,KLEV
393 ! PRINT 9012,JK,(ZTAUR(JK,JG),JG=1,16)
394  9012 format(1x,'TauRay ',i3,16e9.2)
395 ! ENDDO
396 ! print *,'Cloud optical properties for JB= ',JB
397 ! DO JK=1,KLEV
398 ! PRINT 9013,JK,PFRCL(JK),PTAUC(JK,IBM),POMGC(JK,IBM),PASYC(JK,IBM)
399  9013 format(1x,'Cloud optprop ',i3,f8.4,f8.3,2f8.5)
400 ! ENDDO
401 ! ENDIF
402 
403  DO jg=1,igt
404  iw=iw+1
405 
406 ! IF (NDBUG.LE.1) THEN
407 ! print *,' === JG= ',JG,' === for JB= ',JB,' with IW, IBM, JPLAY, KLEV=',IW,IBM,JPLAY,KLEV
408 ! ENDIF
409 
410  zincflx(iw) =zsflxzen(jg)*prmu0
411  zincflux =zincflux+zsflxzen(jg)*prmu0
412  zinctot =zinctot+zsflxzen(jg)
413  zincf14(ibm)=zincf14(ibm)+zsflxzen(jg)
414 
415 !-- CALL to compute layer reflectances and transmittances for direct
416 ! and diffuse sources, first clear then cloudy.
417 ! Use direct/parallel albedo for direct radiation and diffuse albedo
418 ! otherwise.
419 
420 ! ZREFC(JK) direct albedo for clear
421 ! ZREFO(JK) direct albedo for cloud
422 ! ZREFDC(JK) diffuse albedo for clear
423 ! ZREFDO(JK) diffuse albedo for cloud
424 ! ZTRAC(JK) direct transmittance for clear
425 ! ZTRAO(JK) direct transmittance for cloudy
426 ! ZTRADC(JK) diffuse transmittance for clear
427 ! ZTRADO(JK) diffuse transmittance for cloudy
428 
429 ! ZREF(JK) direct reflectance
430 ! ZREFD(JK) diffuse reflectance
431 ! ZTRA(JK) direct transmittance
432 ! ZTRAD(JK) diffuse transmittance
433 
434 ! ZDBTC(JK) clear direct beam transmittance
435 ! ZDBTO(JK) cloudy direct beam transmittance
436 ! ZDBT(JK) layer mean direct beam transmittance
437 ! ZTDBT(JK) total direct beam transmittance at levels
438 
439 !-- clear-sky
440 !----- TOA direct beam
441  ztdbtc(1)=1._jprb
442 !----- surface values
443  zdbtc(klev+1) =0.0_jprb
444  ztrac(klev+1) =0.0_jprb
445  ztradc(klev+1)=0.0_jprb
446  zrefc(klev+1) =palbp(ibm)
447  zrefdc(klev+1)=palbd(ibm)
448  zrupc(klev+1) =palbp(ibm)
449  zrupdc(klev+1)=palbd(ibm)
450 
451 !-- total sky
452 !----- TOA direct beam
453  ztdbt(1)=1._jprb
454 !----- surface values
455  zdbt(klev+1) =0.0_jprb
456  ztra(klev+1) =0.0_jprb
457  ztrad(klev+1)=0.0_jprb
458  zref(klev+1) =palbp(ibm)
459  zrefd(klev+1)=palbd(ibm)
460  zrup(klev+1) =palbp(ibm)
461  zrupd(klev+1)=palbd(ibm)
462 ! if (NDBUG < 2) print *,'SWSPCTRL after 1 with JB,JG,IBM and IW= ',JB,JG,IBM,IW
463 
464  DO jk=1,klev
465 
466 !-- NB: a two-stream calculations from top to bottom, but RRTM_SW quantities
467 ! are given bottom to top (argh!)
468 ! Inputs for clouds and aerosols are bottom to top as inputs
469 
470  ikl=klev+1-jk
471 
472 !-- clear-sky optical parameters
473  llrtchk(jk)=.true.
474 
475 ! print 9000,JK,JG,IKL,ZTAUR(IKL,JG),ZTAUG(IKL,JG),PTAUC(IKL,IBM)
476  9000 format(1x,'Cloud quantities ',3i4,3e12.5)
477 
478 !-- original
479 ! ZTAUC(JK)=ZTAUR(IKL,JG)+ZTAUG(IKL,JG)
480 ! ZOMCC(JK)=ZTAUR(IKL,JG)/ZTAUC(JK)
481 ! ZGCC (JK)=0.0001_JPRB
482 
483 !-- total sky optical parameters
484 ! ZTAUO(JK)=ZTAUR(IKL,JG)+ZTAUG(IKL,JG)+PTAUC(IKL,IBM)
485 ! ZOMCO(JK)=PTAUC(IKL,IBM)*POMGC(IKL,IBM)+ZTAUR(IKL,JG)
486 ! ZGCO (JK)=(PTAUC(IKL,IBM)*POMGC(IKL,IBM)*PASYC(IKL,IBM) &
487 ! & +ZTAUR(IKL,JG)*0.0001_JPRB)/ZOMCO(JK)
488 ! ZOMCO(JK)=ZOMCO(JK)/ZTAUO(JK)
489 
490 !-- clear-sky optical parameters including aerosols
491  ztauc(jk) = ztaur(ikl,jg) + ztaug(ikl,jg) + ptaua(ikl,ibm)
492  zomcc(jk) = ztaur(ikl,jg)*1.0_jprb + ptaua(ikl,ibm)*pomga(ikl,ibm)
493  zgcc(jk) = pasya(ikl,ibm)*pomga(ikl,ibm)*ptaua(ikl,ibm) / zomcc(jk)
494  zomcc(jk) = zomcc(jk) / ztauc(jk)
495 
496 !-- total sky optical parameters
497  ztauo(jk) = ztaur(ikl,jg) + ztaug(ikl,jg) + ptaua(ikl,ibm) + ptauc(ikl,ibm)
498  zomco(jk) = ptaua(ikl,ibm)*pomga(ikl,ibm) + ptauc(ikl,ibm)*pomgc(ikl,ibm) &
499  & + ztaur(ikl,jg)*1.0_jprb
500  zgco(jk) = (ptauc(ikl,ibm)*pomgc(ikl,ibm)*pasyc(ikl,ibm) &
501  & + ptaua(ikl,ibm)*pomga(ikl,ibm)*pasya(ikl,ibm)) &
502  & / zomco(jk)
503  zomco(jk) = zomco(jk) / ztauo(jk)
504 
505 ! if (NDBUG <2) THEN
506 ! print 9001,JK,JG,LRTCHK(JK),0.00,ZTAUC(JK),ZOMCC(JK),ZGCC(JK),ZTAUR(IKL,JG),ZTAUG(IKL,JG)
507  9001 format(1x,'clear :',2i3,l4,7(1x,e13.6))
508 ! print 9002,JK,JG,LRTCHK(JK),PFRCL(IKL),ZTAUO(JK),ZOMCO(JK),ZGCO(JK) &
509 ! &,PTAUC(IKL,IBM),POMGC(IKL,IBM),PASYC(IKL,IBM)
510  9002 format(1x,'total0:',2i3,l4,7(1x,e13.6))
511 ! end if
512  ENDDO
513 ! if (NDBUG < 2) print *,'SWSPCTRL after 2'
514 
515 !-- Delta scaling for clear-sky / aerosol optical quantities
516  DO jk=1,klev
517  zf=zgcc(jk)*zgcc(jk)
518  zwf=zomcc(jk)*zf
519  ztauc(jk)=(1._jprb-zwf)*ztauc(jk)
520  zomcc(jk)=(zomcc(jk)-zwf)/(1.0_jprb-zwf)
521  zgcc(jk)=(zgcc(jk)-zf)/(1.0_jprb-zf)
522  ENDDO
523 
524  CALL srtm_reftra ( klev, i_kmodts ,&
525  & llrtchk, zgcc , prmu0, ztauc , zomcc ,&
526  & zrefc , zrefdc, ztrac, ztradc )
527 ! if (NDBUG < 2) print *,'SWSPCTR after SWREFTRA for clear-sky'
528 
529 !-- Delta scaling for cloudy quantities
530  DO jk=1,klev
531  ikl=klev+1-jk
532  llrtchk(jk)=.false.
533  zf=zgco(jk)*zgco(jk)
534  zwf=zomco(jk)*zf
535  ztauo(jk)=(1._jprb-zwf)*ztauo(jk)
536  zomco(jk)=(zomco(jk)-zwf)/(1._jprb-zwf)
537  zgco(jk)=(zgco(jk)-zf)/(1._jprb-zf)
538  llrtchk(jk)=(pfrcl(ikl) > repclc)
539 
540 ! if (NDBUG < 2) THEN
541 ! print 9003,JK,LRTCHK(JK),PFRCL(IKL),ZTAUO(JK),ZOMCO(JK),ZGCO(JK) &
542 ! &,PTAUC(IKL,IBM),POMGC(IKL,IBM),PASYC(IKL,IBM)
543  9003 format(1x,'totalD:',i3,l4,7(1x,e13.6))
544 ! end if
545 
546  ENDDO
547 ! if (NDBUG < 2) print *,'SWSPCTR after Delta scaling'
548 
549  CALL srtm_reftra ( klev, i_kmodts ,&
550  & llrtchk, zgco , prmu0, ztauo , zomco ,&
551  & zrefo , zrefdo, ztrao, ztrado )
552 ! if (NDBUG < 2) print *,'SWSPCTR after SWREFTRA for cloudy'
553 
554  DO jk=1,klev
555 
556 !-- combine clear and cloudy contributions for total sky
557 
558  ikl=klev+1-jk
559  zclear = 1.0_jprb - pfrcl(ikl)
560  zcloud = pfrcl(ikl)
561 
562  zref(jk) = zclear*zrefc(jk) + zcloud*zrefo(jk)
563  zrefd(jk)= zclear*zrefdc(jk)+ zcloud*zrefdo(jk)
564  ztra(jk) = zclear*ztrac(jk) + zcloud*ztrao(jk)
565  ztrad(jk)= zclear*ztradc(jk)+ zcloud*ztrado(jk)
566 
567 !-- direct beam transmittance
568 
569  zdbtmc = exp(-ztauc(jk)/prmu0)
570  zdbtmo = exp(-ztauo(jk)/prmu0)
571  zdbt(jk) = zclear*zdbtmc+zcloud*zdbtmo
572  ztdbt(jk+1)= zdbt(jk)*ztdbt(jk)
573 
574 !-- clear-sky
575  zdbtc(jk) =zdbtmc
576  ztdbtc(jk+1)=zdbtc(jk)*ztdbtc(jk)
577 
578 ! if (NDBUG < 2) print 9200,JK,ZREFC(JK),ZREFDC(JK),ZTRAC(JK),ZTRADC(JK),ZDBTC(JK),ZTDBTC(JK+1)
579 ! if (NDBUG < 2) print 9199,JK,ZREF(JK),ZREFD(JK),ZTRA(JK),ZTRAD(JK),ZDBT(JK),ZTDBT(JK+1)
580  9199 format(1x,'Comb total:',i3,6e13.6)
581  9200 format(1x,'Comb clear:',i3,6e13.6)
582 
583  ENDDO
584 ! if (NDBUG < 2) print *,'SRTM_SPCVRT after combining clear and cloudy'
585 
586 !-- vertical quadrature producing clear-sky fluxes
587 
588 ! print *,'SRTM_SPCVRT after 3 before SRTM_VRTQDR clear'
589 
590  CALL srtm_vrtqdr ( klev, iw ,&
591  & zrefc, zrefdc, ztrac , ztradc ,&
592  & zdbtc, zrdndc, zrupc , zrupdc, ztdbtc ,&
593  & zcd , zcu )
594 
595 ! IF (NDBUG < 2) THEN
596 ! print *,'SRTM_SPCVRT out of SRTM_VRTQDR for clear IW=',IW
597 ! DO JK=1,KLEV+1
598 ! print 9201,JK,ZCD(JK,IW),ZCU(JK,IW)
599  9201 format(1x,'clear-sky contrib to fluxes',i3,2f12.4)
600 ! ENDDO
601 ! ENDIF
602 
603 !-- vertical quadrature producing cloudy fluxes
604 
605 ! print *,'SRTM_SPCVRT after 4 before SRTM_VRTQDR cloudy'
606 
607  CALL srtm_vrtqdr ( klev, iw ,&
608  & zref , zrefd , ztra , ztrad ,&
609  & zdbt , zrdnd , zrup , zrupd , ztdbt ,&
610  & zfd , zfu )
611 
612 ! IF (NDBUG < 2) THEN
613 ! print *,'SRTM_SPCVRT out of SRTM_VRTQDR for cloudy IW=',IW
614 ! DO JK=1,KLEV+1
615 ! print 9202,JK,ZFD(JK,IW),ZFU(JK,IW)
616  9202 format(1x,'cloudy sky contrib to fluxes',i3,2f12.4)
617 ! ENDDO
618 ! ENDIF
619 
620 !-- up and down-welling fluxes at levels
621  DO jk=1,klev+1
622 !-- accumulation of spectral fluxes
623  pbbfu(jk) = pbbfu(jk) + zincflx(iw)*zfu(jk,iw)
624  pbbfd(jk) = pbbfd(jk) + zincflx(iw)*zfd(jk,iw)
625  pbbcu(jk) = pbbcu(jk) + zincflx(iw)*zcu(jk,iw)
626  pbbcd(jk) = pbbcd(jk) + zincflx(iw)*zcd(jk,iw)
627 
628 ! to get NIR, visible and UV quantities
629 
630 ! PBBFU(JK)=PBBFU(JK)+RWGT(IW)*ZFU(JK,IW)
631 ! PBBFD(JK)=PBBFD(JK)+RWGT(IW)*ZFD(JK,IW)
632 ! PBBCU(JK)=PBBCU(JK)+RWGT(IW)*ZCU(JK,IW)
633 ! PBBCD(JK)=PBBCD(JK)+RWGT(IW)*ZCD(JK,IW)
634 ! IF (IW <= NUV) THEN
635 ! PUVFD(JK)=PUVFD(JK)+RWGT(IW)*ZFD(JK,IW)
636 ! PUVFU(JK)=PUVFU(JK)+RWGT(IW)*ZFU(JK,IW)
637 ! PUVCD(JK)=PUVCD(JK)+RWGT(IW)*ZCD(JK,IW)
638 ! PUVCU(JK)=PUVCU(JK)+RWGT(IW)*ZCU(JK,IW)
639 ! ELSE IF (IW == NUV+1 .AND. IW <= NVS) THEN
640 ! PVSFD(JK)=PVSFD(JK)+RWGT(IW)*ZFD(JK,IW)
641 ! PVSFU(JK)=PVSFU(JK)+RWGT(IW)*ZFU(JK,IW)
642 ! PVSCD(JK)=PVSCD(JK)+RWGT(IW)*ZCD(JK,IW)
643 ! PVSCU(JK)=PVSCU(JK)+RWGT(IW)*ZCU(JK,IW)
644 ! ELSE IF (IW > NVS) THEN
645 ! PNIFD(JK)=PNIFD(JK)+RWGT(IW)*ZFD(JK,IW)
646 ! PNIFU(JK)=PNIFU(JK)+RWGT(IW)*ZFU(JK,IW)
647 ! PNICD(JK)=PNICD(JK)+RWGT(IW)*ZCD(JK,IW)
648 ! PNICU(JK)=PNICU(JK)+RWGT(IW)*ZCU(JK,IW)
649 ! ENDIF
650 ! if (NDBUG < 2) then
651 !! if (JG.EQ.IGT) THEN
652 ! print 9206,JB,JG,JK,IW,PBBCU(JK),PBBCD(JK),PBBFU(JK),PBBFD(JK)
653  9206 format(1x,'fluxes up to:',3i3,i4,6e13.6)
654 ! end if
655  ENDDO
656 
657 ! if (NDBUG < 2) print *,'SRTM_SPCVRT end of JG=',JG,' for JB=',JB,' i.e. IW=',IW
658  ENDDO
659 !-- end loop on JG
660 
661 ! print *,' --- JB= ',JB,' with IB1, IB2= ',IB1,IB2
662 ENDDO
663 !-- end loop on JB
664 !if (NDBUG < 2) print *,'SRTM_SPCVRT about to come out'
665 
666 !DO IBM=1,14
667 ! print 9301,IBM,ZINCF14(IBM), ZINCTOT, ZINCF14(IBM)/ZINCTOT
668 9301 format(1x,'Incident Spectral Flux: ',i3,2e15.8,f12.8)
669 !ENDDO
670 
671 ! ------------------------------------------------------------------
672 IF (lhook) CALL dr_hook('SRTM_SPCVRT',1,zhook_handle)
673 END SUBROUTINE srtm_spcvrt
srtm_taumol26
subroutine srtm_taumol26(KLEV, P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, P_ONEMINUS, P_COLH2O, P_COLCO2, P_COLMOL, K_LAYTROP, P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR)
Definition: srtm_taumol26.F90:9
parsrtm::jpb2
integer(kind=jpim), parameter jpb2
Definition: parsrtm.F90:25
srtm_reftra
subroutine srtm_reftra(KLEV, KMODTS, LDRTCHK, PGG, PRMUZ, PTAU, PW, PREF, PREFD, PTRA, PTRAD)
Definition: srtm_reftra.F90:10
srtm_taumol23
subroutine srtm_taumol23(KLEV, P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, P_ONEMINUS, P_COLH2O, P_COLMOL, K_LAYTROP, P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR)
Definition: srtm_taumol23.F90:9
srtm_taumol19
subroutine srtm_taumol19(KLEV, P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, P_ONEMINUS, P_COLH2O, P_COLCO2, P_COLMOL, K_LAYTROP, P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR)
Definition: srtm_taumol19.F90:9
parsrtm::jplay
integer(kind=jpim), parameter jplay
Definition: parsrtm.F90:19
srtm_taumol25
subroutine srtm_taumol25(KLEV, P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, P_ONEMINUS, P_COLH2O, P_COLMOL, P_COLO3, K_LAYTROP, P_SFLUXZEN, P_TAUG, P_TAUR)
Definition: srtm_taumol25.F90:9
srtm_taumol18
subroutine srtm_taumol18(KLEV, P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, P_ONEMINUS, P_COLH2O, P_COLCH4, P_COLMOL, K_LAYTROP, P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR)
Definition: srtm_taumol18.F90:9
srtm_taumol24
subroutine srtm_taumol24(KLEV, P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, P_ONEMINUS, P_COLH2O, P_COLMOL, P_COLO2, P_COLO3, K_LAYTROP, P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR)
Definition: srtm_taumol24.F90:9
dimphy::klev
integer, save klev
Definition: dimphy.F90:7
srtm_taumol17
subroutine srtm_taumol17(KLEV, P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, P_ONEMINUS, P_COLH2O, P_COLCO2, P_COLMOL, K_LAYTROP, P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR)
Definition: srtm_taumol17.F90:9
srtm_spcvrt
subroutine srtm_spcvrt(KLEV, KMOL, KSW, PONEMINUS,PAVEL, PTAVEL, PZ, PTZ, PTBOUND, PALBD, PALBP,PFRCL, PTAUC, PASYC, POMGC, PTAUA, PASYA, POMGA, PRMU0,PCOLDRY, PWKL,KLAYTROP, KLAYSWTCH, KLAYLOW,PCO2MULT, PCOLCH4, PCOLCO2, PCOLH2O, PCOLMOL, PCOLN2O, PCOLO2, PCOLO3,PFORFAC, PFORFRAC, KINDFOR, PSELFFAC, PSELFFRAC, KINDSELF,PFAC00, PFAC01, PFAC10, PFAC11,KJP, KJT, KJT1,
Definition: srtm_spcvrt.F90:15
yoerdi
Definition: yoerdi.F90:1
false
!$Id itapm1 ENDIF!IM on interpole les champs sur les niveaux STD de pression!IM a chaque pas de temps de la physique c!positionnement de l argument logique a false c!pour ne pas recalculer deux fois la meme chose!c!a cet effet un appel a plevel_new a ete deplace c!a la fin de la serie d appels c!la boucle DO nlevSTD a ete internalisee c!dans d ou la creation de cette routine c c!CALL false
Definition: calcul_STDlev.h:26
srtm_taumol22
subroutine srtm_taumol22(KLEV, P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, P_ONEMINUS, P_COLH2O, P_COLMOL, P_COLO2, K_LAYTROP, P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR)
Definition: srtm_taumol22.F90:9
srtm_taumol29
subroutine srtm_taumol29(KLEV, P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, P_ONEMINUS, P_COLH2O, P_COLCO2, P_COLMOL, K_LAYTROP, P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR)
Definition: srtm_taumol29.F90:9
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:31
parsrtm::jpgpt
integer(kind=jpim), parameter jpgpt
Definition: parsrtm.F90:27
srtm_taumol27
subroutine srtm_taumol27(KLEV, P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, P_ONEMINUS, P_COLMOL, P_COLO3, K_LAYTROP, P_SFLUXZEN, P_TAUG, P_TAUR)
Definition: srtm_taumol27.F90:9
x
!$Header!c c INCLUDE fxyprim h c c c Fonctions in line c c REAL fyprim REAL rj c c il faut la calculer avant d appeler ces fonctions c c c Fonctions a changer selon x(x) et y(y) choisis.c-----------------------------------------------------------------c c.....ici
true
!$Id itapm1 ENDIF!IM on interpole les champs sur les niveaux STD de pression!IM a chaque pas de temps de la physique c!positionnement de l argument logique a false c!pour ne pas recalculer deux fois la meme chose!c!a cet effet un appel a plevel_new a ete deplace c!a la fin de la serie d appels c!la boucle DO nlevSTD a ete internalisee c!dans d ou la creation de cette routine c c!CALL ulevSTD CALL &zphi philevSTD CALL &zx_rh rhlevSTD!DO klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon klev DO klon du jour ou toutes les read_climoz CALL true
Definition: calcul_STDlev.h:139
yomhook::lhook
logical lhook
Definition: yomhook.F90:12
srtm_taumol21
subroutine srtm_taumol21(KLEV, P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, P_ONEMINUS, P_COLH2O, P_COLCO2, P_COLMOL, K_LAYTROP, P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR)
Definition: srtm_taumol21.F90:9
srtm_taumol16
subroutine srtm_taumol16(KLEV, P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, P_ONEMINUS, P_COLH2O, P_COLCH4, P_COLMOL, K_LAYTROP, P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR)
Definition: srtm_taumol16.F90:9
yomhook::dr_hook
subroutine dr_hook(CDNAME, KSWITCH, PKEY)
Definition: yomhook.F90:17
parkind1::jpim
integer, parameter jpim
Definition: parkind1.F90:13
srtm_vrtqdr
subroutine srtm_vrtqdr(KLEV, KW, PREF, PREFD, PTRA, PTRAD, PDBT, PRDND, PRUP, PRUPD, PTDBT, PFD, PFU)
Definition: srtm_vrtqdr.F90:10
srtm_taumol28
subroutine srtm_taumol28(KLEV, P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, P_ONEMINUS, P_COLMOL, P_COLO2, P_COLO3, K_LAYTROP, P_SFLUXZEN, P_TAUG, P_TAUR)
Definition: srtm_taumol28.F90:9
yoerdi::repclc
real(kind=jprb) repclc
Definition: yoerdi.F90:21
srtm_taumol20
subroutine srtm_taumol20(KLEV, P_FAC00, P_FAC01, P_FAC10, P_FAC11, K_JP, K_JT, K_JT1, P_ONEMINUS, P_COLH2O, P_COLCH4, P_COLMOL, K_LAYTROP, P_SELFFAC, P_SELFFRAC, K_INDSELF, P_FORFAC, P_FORFRAC, K_INDFOR, P_SFLUXZEN, P_TAUG, P_TAUR)
Definition: srtm_taumol20.F90:9
yoesrtwn::ngc
integer(kind=jpim), dimension(14) ngc
Definition: yoesrtwn.F90:25
parsrtm::jpb1
integer(kind=jpim), parameter jpb1
Definition: parsrtm.F90:24