source: LMDZ6/branches/SETHET_DECOUPLE/libf/phylmd/rrtm/srtm_spcvrt.F90 @ 4799

Last change on this file since 4799 was 1990, checked in by Laurent Fairhead, 11 years ago

Corrections à la version r1989 pour permettre la compilation avec RRTM
Inclusion de la licence CeCILL_V2 pour RRTM

Changes to revision r1989 to enable RRTM code compilation
RRTM part put under CeCILL_V2 licence
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 23.5 KB
Line 
1#ifdef RS6K
2@PROCESS HOT NOSTRICT
3#endif
4SUBROUTINE 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
61USE PARKIND1  ,ONLY : JPIM     ,JPRB
62USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
63
64USE PARSRTM  , ONLY : JPLAY, JPB1, JPB2, JPGPT
65
66USE YOESRTWN , ONLY : NGC
67USE 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
73IMPLICIT NONE
74
75!     ------------------------------------------------------------------
76
77!*       0.1   ARGUMENTS
78!              ---------
79
80INTEGER(KIND=JPIM),INTENT(IN)    :: KSW
81INTEGER(KIND=JPIM)               :: KLEV ! UNDETERMINED INTENT
82INTEGER(KIND=JPIM)               :: KMOL ! Argument NOT used
83REAL(KIND=JPRB)                  :: PONEMINUS ! UNDETERMINED INTENT
84REAL(KIND=JPRB)                  :: PAVEL(JPLAY) ! Argument NOT used
85REAL(KIND=JPRB)                  :: PTAVEL(JPLAY) ! Argument NOT used
86REAL(KIND=JPRB)                  :: PZ(0:JPLAY) ! Argument NOT used
87REAL(KIND=JPRB)                  :: PTZ(0:JPLAY) ! Argument NOT used
88REAL(KIND=JPRB)                  :: PTBOUND ! Argument NOT used
89REAL(KIND=JPRB)   ,INTENT(IN)    :: PALBD(KSW)
90REAL(KIND=JPRB)   ,INTENT(IN)    :: PALBP(KSW)
91REAL(KIND=JPRB)   ,INTENT(IN)    :: PFRCL(JPLAY)     ! bottom to top
92REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUC(JPLAY,KSW) ! bottom to top
93REAL(KIND=JPRB)   ,INTENT(IN)    :: PASYC(JPLAY,KSW) ! bottom to top
94REAL(KIND=JPRB)   ,INTENT(IN)    :: POMGC(JPLAY,KSW) ! bottom to top
95REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUA(JPLAY,KSW) ! bottom to top
96REAL(KIND=JPRB)   ,INTENT(IN)    :: PASYA(JPLAY,KSW) ! bottom to top
97REAL(KIND=JPRB)   ,INTENT(IN)    :: POMGA(JPLAY,KSW) ! bottom to top
98REAL(KIND=JPRB)                  :: PRMU0 ! UNDETERMINED INTENT
99REAL(KIND=JPRB)                  :: PCOLDRY(JPLAY) ! Argument NOT used
100REAL(KIND=JPRB)                  :: PWKL(35,JPLAY) ! Argument NOT used
101INTEGER(KIND=JPIM)               :: KLAYTROP ! UNDETERMINED INTENT
102INTEGER(KIND=JPIM)               :: KLAYSWTCH ! Argument NOT used
103INTEGER(KIND=JPIM)               :: KLAYLOW ! Argument NOT used
104REAL(KIND=JPRB)                  :: PCO2MULT(JPLAY) ! Argument NOT used
105REAL(KIND=JPRB)                  :: PCOLCH4(JPLAY) ! UNDETERMINED INTENT
106REAL(KIND=JPRB)                  :: PCOLCO2(JPLAY) ! UNDETERMINED INTENT
107REAL(KIND=JPRB)                  :: PCOLH2O(JPLAY) ! UNDETERMINED INTENT
108REAL(KIND=JPRB)                  :: PCOLMOL(JPLAY) ! UNDETERMINED INTENT
109REAL(KIND=JPRB)                  :: PCOLN2O(JPLAY) ! Argument NOT used
110REAL(KIND=JPRB)                  :: PCOLO2(JPLAY) ! UNDETERMINED INTENT
111REAL(KIND=JPRB)                  :: PCOLO3(JPLAY) ! UNDETERMINED INTENT
112REAL(KIND=JPRB)                  :: PFORFAC(JPLAY) ! UNDETERMINED INTENT
113REAL(KIND=JPRB)                  :: PFORFRAC(JPLAY) ! UNDETERMINED INTENT
114INTEGER(KIND=JPIM)               :: KINDFOR(JPLAY) ! UNDETERMINED INTENT
115REAL(KIND=JPRB)                  :: PSELFFAC(JPLAY) ! UNDETERMINED INTENT
116REAL(KIND=JPRB)                  :: PSELFFRAC(JPLAY) ! UNDETERMINED INTENT
117INTEGER(KIND=JPIM)               :: KINDSELF(JPLAY) ! UNDETERMINED INTENT
118REAL(KIND=JPRB)                  :: PFAC00(JPLAY) ! UNDETERMINED INTENT
119REAL(KIND=JPRB)                  :: PFAC01(JPLAY) ! UNDETERMINED INTENT
120REAL(KIND=JPRB)                  :: PFAC10(JPLAY) ! UNDETERMINED INTENT
121REAL(KIND=JPRB)                  :: PFAC11(JPLAY) ! UNDETERMINED INTENT
122INTEGER(KIND=JPIM)               :: KJP(JPLAY) ! UNDETERMINED INTENT
123INTEGER(KIND=JPIM)               :: KJT(JPLAY) ! UNDETERMINED INTENT
124INTEGER(KIND=JPIM)               :: KJT1(JPLAY) ! UNDETERMINED INTENT
125REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBBFD(JPLAY+1)
126REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBBFU(JPLAY+1)
127REAL(KIND=JPRB)                  :: PUVFD(JPLAY+1) ! Argument NOT used
128REAL(KIND=JPRB)                  :: PUVFU(JPLAY+1) ! Argument NOT used
129REAL(KIND=JPRB)                  :: PVSFD(JPLAY+1) ! Argument NOT used
130REAL(KIND=JPRB)                  :: PVSFU(JPLAY+1) ! Argument NOT used
131REAL(KIND=JPRB)                  :: PNIFD(JPLAY+1) ! Argument NOT used
132REAL(KIND=JPRB)                  :: PNIFU(JPLAY+1) ! Argument NOT used
133REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBBCD(JPLAY+1)
134REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBBCU(JPLAY+1)
135REAL(KIND=JPRB)                  :: PUVCD(JPLAY+1) ! Argument NOT used
136REAL(KIND=JPRB)                  :: PUVCU(JPLAY+1) ! Argument NOT used
137REAL(KIND=JPRB)                  :: PVSCD(JPLAY+1) ! Argument NOT used
138REAL(KIND=JPRB)                  :: PVSCU(JPLAY+1) ! Argument NOT used
139REAL(KIND=JPRB)                  :: PNICD(JPLAY+1) ! Argument NOT used
140REAL(KIND=JPRB)                  :: PNICU(JPLAY+1) ! Argument NOT used
141!     ------------------------------------------------------------------
142
143!              ------------
144
145LOGICAL :: LLRTCHK(JPLAY)
146
147REAL(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)   
161REAL(KIND=JPRB) :: &
162 & ZDBTC(JPLAY+1), ZTDBTC(JPLAY+1), ZINCFLX(JPGPT)  &
163 & ,  ZINCF14(14)   , ZINCTOT   
164 
165INTEGER(KIND=JPIM) :: IB1, IB2, IBM, IGT, IKL, IW, JB, JG, JK, I_KMODTS
166
167REAL(KIND=JPRB) :: ZDBTMC, ZDBTMO, ZF, ZINCFLUX, ZWF
168
169!-- Output of SRTM_TAUMOLn routines
170
171REAL(KIND=JPRB) :: ZTAUG(JPLAY,16), ZTAUR(JPLAY,16), ZSFLXZEN(16)
172
173!-- Output of SRTM_VRTQDR routine
174REAL(KIND=JPRB) :: &
175 & ZCD(JPLAY+1,JPGPT), ZCU(JPLAY+1,JPGPT) &
176 & ,  ZFD(JPLAY+1,JPGPT), ZFU(JPLAY+1,JPGPT) 
177REAL(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!     ------------------------------------------------------------------
197IF (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
203IB1=JPB1
204IB2=JPB2
205!print *,'IB1, IB2, KSW, KMOL, KLEV: ', IB1,IB2,KSW,KMOL,KLEV
206
207IW=0
208ZINCFLUX=0.0_JPRB
209ZINCTOT=0.0_JPRB
210
211JB=IB1-1
212DO 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
662ENDDO                   
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
6689301 format(1x,'Incident Spectral Flux: ',I3,2E15.8,F12.8)
669!ENDDO
670
671!     ------------------------------------------------------------------
672IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT',1,ZHOOK_HANDLE)
673END SUBROUTINE SRTM_SPCVRT
Note: See TracBrowser for help on using the repository browser.