source: LMDZ6/trunk/libf/phylmd/rrtm/srtm_spcvrt_mcica.F90 @ 5018

Last change on this file since 5018 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: 24.6 KB
Line 
1#ifdef RS6K
2@PROCESS HOT NOSTRICT
3#endif
4SUBROUTINE SRTM_SPCVRT_MCICA &
5 & ( KLEV    , KMOL    , KSW    , KCOLS  , 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, PBBCD, PBBCU )
16
17! &   PBBFD, PBBFU, PUVFD, PUVFU, PVSFD, PVSFU , PNIFD , PNIFU ,&
18! &   PBBCD, PBBCU, PUVCD, PUVCU, PVSCD, PVSCU , PNICD , PNICU &
19! & ) 
20
21!**** *SRTM_SPCVRT* - SPECTRAL LOOP TO COMPUTE THE SHORTWAVE RADIATION FLUXES.
22
23!     PURPOSE.
24!     --------
25
26!          THIS ROUTINE COMPUTES THE TWO-STREAM METHOD OF BARKER
27
28!**   INTERFACE.
29!     ----------
30
31!          *SRTM_SPCVRT_MCICA* IS CALLED FROM *SRTM_SRTM_224GP*
32
33!        IMPLICIT ARGUMENTS :
34!        --------------------
35
36!     ==== INPUTS ===
37!     ==== OUTPUTS ===
38
39!     METHOD.
40!     -------
41
42!     EXTERNALS.
43!     ----------
44
45!          *SWVRTQDR*
46
47!     REFERENCE.
48!     ----------
49
50!        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
51!        DOCUMENTATION
52!     AUTHOR.
53!     -------
54!        from Howard Barker
55!        JEAN-JACQUES MORCRETTE  *ECMWF*
56
57!     MODIFICATIONS.
58!     --------------
59!        ORIGINAL : 03-02-27
60!        M.Hamrud      01-Oct-2003 CY28 Cleaning
61!        JJMorcrette   20050110 McICA version
62!     ------------------------------------------------------------------
63
64USE PARKIND1  ,ONLY : JPIM     ,JPRB
65USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
66
67USE PARSRTM  , ONLY : JPLAY, JPB1, JPB2, JPGPT
68
69USE YOESRTWN , ONLY : NGC
70USE YOERDI   , ONLY : REPCLC
71
72!USE YOERAD   , ONLY : NSW
73!USE YOERDU   , ONLY : RCDAY
74!USE YOESWN   , ONLY : NTBANDS, NBANDS, NGS, NUV, NVS, RWGT, NDBUG
75
76IMPLICIT NONE
77
78!     ------------------------------------------------------------------
79
80!*       0.1   ARGUMENTS
81!              ---------
82
83INTEGER(KIND=JPIM),INTENT(IN)    :: KSW
84INTEGER(KIND=JPIM),INTENT(IN)    :: KCOLS
85 
86INTEGER(KIND=JPIM)               :: KLEV ! UNDETERMINED INTENT
87INTEGER(KIND=JPIM)               :: KMOL ! Argument NOT used
88!INTEGER(KIND=JPIM)               :: KPT
89
90REAL(KIND=JPRB)                  :: PONEMINUS ! UNDETERMINED INTENT
91REAL(KIND=JPRB)                  :: PAVEL(JPLAY) ! Argument NOT used
92REAL(KIND=JPRB)                  :: PTAVEL(JPLAY) ! Argument NOT used
93REAL(KIND=JPRB)                  :: PZ(0:JPLAY) ! Argument NOT used
94REAL(KIND=JPRB)                  :: PTZ(0:JPLAY) ! Argument NOT used
95REAL(KIND=JPRB)                  :: PTBOUND ! Argument NOT used
96REAL(KIND=JPRB)   ,INTENT(IN)    :: PALBD(KSW)
97REAL(KIND=JPRB)   ,INTENT(IN)    :: PALBP(KSW)
98REAL(KIND=JPRB)   ,INTENT(IN)    :: PFRCL(KCOLS,JPLAY)  ! bottom to top
99REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUC(JPLAY,KCOLS)  ! bottom to top
100REAL(KIND=JPRB)   ,INTENT(IN)    :: PASYC(JPLAY,KCOLS)  ! bottom to top
101REAL(KIND=JPRB)   ,INTENT(IN)    :: POMGC(JPLAY,KCOLS)  ! bottom to top
102REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUA(JPLAY,KSW)    ! bottom to top
103REAL(KIND=JPRB)   ,INTENT(IN)    :: PASYA(JPLAY,KSW)    ! bottom to top
104REAL(KIND=JPRB)   ,INTENT(IN)    :: POMGA(JPLAY,KSW)    ! bottom to top
105REAL(KIND=JPRB)                  :: PRMU0 ! UNDETERMINED INTENT
106REAL(KIND=JPRB)                  :: PCOLDRY(JPLAY) ! Argument NOT used
107REAL(KIND=JPRB)                  :: PWKL(35,JPLAY) ! Argument NOT used
108INTEGER(KIND=JPIM)               :: KLAYTROP ! UNDETERMINED INTENT
109INTEGER(KIND=JPIM)               :: KLAYSWTCH ! Argument NOT used
110INTEGER(KIND=JPIM)               :: KLAYLOW ! Argument NOT used
111REAL(KIND=JPRB)                  :: PCO2MULT(JPLAY) ! Argument NOT used
112REAL(KIND=JPRB)                  :: PCOLCH4(JPLAY) ! UNDETERMINED INTENT
113REAL(KIND=JPRB)                  :: PCOLCO2(JPLAY) ! UNDETERMINED INTENT
114REAL(KIND=JPRB)                  :: PCOLH2O(JPLAY) ! UNDETERMINED INTENT
115REAL(KIND=JPRB)                  :: PCOLMOL(JPLAY) ! UNDETERMINED INTENT
116REAL(KIND=JPRB)                  :: PCOLN2O(JPLAY) ! Argument NOT used
117REAL(KIND=JPRB)                  :: PCOLO2(JPLAY) ! UNDETERMINED INTENT
118REAL(KIND=JPRB)                  :: PCOLO3(JPLAY) ! UNDETERMINED INTENT
119REAL(KIND=JPRB)                  :: PFORFAC(JPLAY) ! UNDETERMINED INTENT
120REAL(KIND=JPRB)                  :: PFORFRAC(JPLAY) ! UNDETERMINED INTENT
121INTEGER(KIND=JPIM)               :: KINDFOR(JPLAY) ! UNDETERMINED INTENT
122REAL(KIND=JPRB)                  :: PSELFFAC(JPLAY) ! UNDETERMINED INTENT
123REAL(KIND=JPRB)                  :: PSELFFRAC(JPLAY) ! UNDETERMINED INTENT
124INTEGER(KIND=JPIM)               :: KINDSELF(JPLAY) ! UNDETERMINED INTENT
125REAL(KIND=JPRB)                  :: PFAC00(JPLAY) ! UNDETERMINED INTENT
126REAL(KIND=JPRB)                  :: PFAC01(JPLAY) ! UNDETERMINED INTENT
127REAL(KIND=JPRB)                  :: PFAC10(JPLAY) ! UNDETERMINED INTENT
128REAL(KIND=JPRB)                  :: PFAC11(JPLAY) ! UNDETERMINED INTENT
129INTEGER(KIND=JPIM)               :: KJP(JPLAY) ! UNDETERMINED INTENT
130INTEGER(KIND=JPIM)               :: KJT(JPLAY) ! UNDETERMINED INTENT
131INTEGER(KIND=JPIM)               :: KJT1(JPLAY) ! UNDETERMINED INTENT
132REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBBFD(JPLAY+1)
133REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBBFU(JPLAY+1)
134!REAL(KIND=JPRB)                  :: PUVFD(JPLAY+1) ! Argument NOT used
135!REAL(KIND=JPRB)                  :: PUVFU(JPLAY+1) ! Argument NOT used
136!REAL(KIND=JPRB)                  :: PVSFD(JPLAY+1) ! Argument NOT used
137!REAL(KIND=JPRB)                  :: PVSFU(JPLAY+1) ! Argument NOT used
138!REAL(KIND=JPRB)                  :: PNIFD(JPLAY+1) ! Argument NOT used
139!REAL(KIND=JPRB)                  :: PNIFU(JPLAY+1) ! Argument NOT used
140REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBBCD(JPLAY+1)
141REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBBCU(JPLAY+1)
142!REAL(KIND=JPRB)                  :: PUVCD(JPLAY+1) ! Argument NOT used
143!REAL(KIND=JPRB)                  :: PUVCU(JPLAY+1) ! Argument NOT used
144!REAL(KIND=JPRB)                  :: PVSCD(JPLAY+1) ! Argument NOT used
145!REAL(KIND=JPRB)                  :: PVSCU(JPLAY+1) ! Argument NOT used
146!REAL(KIND=JPRB)                  :: PNICD(JPLAY+1) ! Argument NOT used
147!REAL(KIND=JPRB)                  :: PNICU(JPLAY+1) ! Argument NOT used
148!     ------------------------------------------------------------------
149
150!              ------------
151
152LOGICAL :: LLRTCHK(JPLAY)
153
154REAL(KIND=JPRB) :: &
155 & ZCLEAR      , ZCLOUD       &
156 & , ZDBT(JPLAY+1) &
157 & , ZGCC(JPLAY)   , ZGCO(JPLAY)     &
158 & , ZOMCC(JPLAY)  , ZOMCO(JPLAY)    &
159 & , ZRDND(JPLAY+1), ZRDNDC(JPLAY+1)&
160 & , ZREF(JPLAY+1) , ZREFC(JPLAY+1) , ZREFO(JPLAY+1)  &
161 & , ZREFD(JPLAY+1), ZREFDC(JPLAY+1), ZREFDO(JPLAY+1) &
162 & , ZRUP(JPLAY+1) , ZRUPD(JPLAY+1) &
163 & , ZRUPC(JPLAY+1), ZRUPDC(JPLAY+1)&
164 & , ZTAUC(JPLAY)  , ZTAUO(JPLAY)    &
165 & , ZTDBT(JPLAY+1) &
166 & , ZTRA(JPLAY+1) , ZTRAC(JPLAY+1) , ZTRAO(JPLAY+1)  &
167 & , ZTRAD(JPLAY+1), ZTRADC(JPLAY+1), ZTRADO(JPLAY+1)   
168REAL(KIND=JPRB) :: &
169 & ZDBTC(JPLAY+1), ZTDBTC(JPLAY+1), ZINCFLX(JPGPT)  &
170 & ,  ZINCF14(14)   , ZINCTOT   
171 
172INTEGER(KIND=JPIM) :: IB1, IB2, IBM, IGT, IKL, IW, JB, JG, JK, I_KMODTS
173
174REAL(KIND=JPRB) :: ZARG1, ZARG2, ZDBTMC, ZDBTMO, ZF, ZINCFLUX, ZWF
175
176!-- Output of SRTM_TAUMOLn routines
177
178REAL(KIND=JPRB) :: ZTAUG(JPLAY,16), ZTAUR(JPLAY,16), ZSFLXZEN(16)
179
180!-- Output of SRTM_VRTQDR routine
181REAL(KIND=JPRB) :: &
182 & ZCD(JPLAY+1,JPGPT), ZCU(JPLAY+1,JPGPT) &
183 & ,  ZFD(JPLAY+1,JPGPT), ZFU(JPLAY+1,JPGPT) 
184REAL(KIND=JPRB) :: ZHOOK_HANDLE
185
186
187#include "srtm_taumol16.intfb.h"
188#include "srtm_taumol17.intfb.h"
189#include "srtm_taumol18.intfb.h"
190#include "srtm_taumol19.intfb.h"
191#include "srtm_taumol20.intfb.h"
192#include "srtm_taumol21.intfb.h"
193#include "srtm_taumol22.intfb.h"
194#include "srtm_taumol23.intfb.h"
195#include "srtm_taumol24.intfb.h"
196#include "srtm_taumol25.intfb.h"
197#include "srtm_taumol26.intfb.h"
198#include "srtm_taumol27.intfb.h"
199#include "srtm_taumol28.intfb.h"
200#include "srtm_taumol29.intfb.h"
201#include "srtm_reftra.intfb.h"
202#include "srtm_vrtqdr.intfb.h"
203!     ------------------------------------------------------------------
204IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT_MCICA',0,ZHOOK_HANDLE)
205
206!-- Two-stream model 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates
207! KMODTS is set in SWREFTRA
208!NDBUG=4
209
210IB1=JPB1
211IB2=JPB2
212!print *,'IB1, IB2, KSW, KMOL, KLEV: ', IB1,IB2,KSW,KMOL,KLEV
213
214IW=0
215ZINCFLUX=0.0_JPRB
216ZINCTOT=0.0_JPRB
217
218JB=IB1-1
219DO JB = IB1, IB2
220  IBM = JB-15
221  IGT = NGC(IBM)
222  ZINCF14(IBM)=0.0_JPRB
223
224!  print *,'=== spectral band === JB= ',JB,' ====== i.e. IBM= ',IBM,' with IGT= ',IGT
225       
226!-- for each band, computes the gaseous and Rayleigh optical thickness
227!  for all g-points within the band
228
229  IF (JB == 16) THEN
230    CALL SRTM_TAUMOL16 &
231     & ( KLEV    ,&
232     &   PFAC00  , PFAC01   , PFAC10   , PFAC11   ,&
233     &   KJP     , KJT      , KJT1     , PONEMINUS,&
234     &   PCOLH2O , PCOLCH4  , PCOLMOL  ,&
235     &   KLAYTROP, PSELFFAC , PSELFFRAC, KINDSELF, PFORFAC  , PFORFRAC, KINDFOR ,&
236     &   ZSFLXZEN, ZTAUG    , ZTAUR    &
237     & ) 
238!    print *,'After  SRTM_TAUMOL16'
239
240  ELSEIF (JB == 17) THEN
241    CALL SRTM_TAUMOL17 &
242     & ( KLEV    ,&
243     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
244     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
245     &   PCOLH2O , PCOLCO2 , PCOLMOL  ,&
246     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
247     &   ZSFLXZEN, ZTAUG   , ZTAUR    &
248     & ) 
249!    print *,'After  SRTM_TAUMOL17'
250
251  ELSEIF (JB == 18) THEN
252    CALL SRTM_TAUMOL18 &
253     & ( KLEV    ,&
254     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
255     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
256     &   PCOLH2O , PCOLCH4 , PCOLMOL  ,&
257     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
258     &   ZSFLXZEN, ZTAUG   , ZTAUR    &
259     & ) 
260!    print *,'After  SRTM_TAUMOL18'
261
262  ELSEIF (JB == 19) THEN
263    CALL SRTM_TAUMOL19 &
264     & ( KLEV    ,&
265     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
266     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
267     &   PCOLH2O , PCOLCO2 , PCOLMOL  ,&
268     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
269     &   ZSFLXZEN, ZTAUG   , ZTAUR    &
270     & ) 
271!    print *,'After  SRTM_TAUMOL19'
272
273  ELSEIF (JB == 20) THEN
274    CALL SRTM_TAUMOL20 &
275     & ( KLEV    ,&
276     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
277     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
278     &   PCOLH2O , PCOLCH4 , PCOLMOL  ,&
279     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
280     &   ZSFLXZEN, ZTAUG   , ZTAUR    &
281     & ) 
282!    print *,'After  SRTM_TAUMOL20'
283
284  ELSEIF (JB == 21) THEN
285    CALL SRTM_TAUMOL21 &
286     & ( KLEV    ,&
287     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
288     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
289     &   PCOLH2O , PCOLCO2 , PCOLMOL  ,&
290     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
291     &   ZSFLXZEN, ZTAUG   , ZTAUR    &
292     & ) 
293!    print *,'After  SRTM_TAUMOL21'
294
295  ELSEIF (JB == 22) THEN
296    CALL SRTM_TAUMOL22 &
297     & ( KLEV    ,&
298     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
299     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
300     &   PCOLH2O , PCOLMOL , PCOLO2   ,&
301     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
302     &   ZSFLXZEN, ZTAUG   , ZTAUR    &
303     & ) 
304!    print *,'After  SRTM_TAUMOL22'
305
306  ELSEIF (JB == 23) THEN
307    CALL SRTM_TAUMOL23 &
308     & ( KLEV    ,&
309     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
310     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
311     &   PCOLH2O , PCOLMOL ,&
312     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
313     &   ZSFLXZEN, ZTAUG   , ZTAUR    &
314     & ) 
315!    print *,'After  SRTM_TAUMOL23'
316
317  ELSEIF (JB == 24) THEN
318    CALL SRTM_TAUMOL24 &
319     & ( KLEV    ,&
320     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
321     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
322     &   PCOLH2O , PCOLMOL , PCOLO2   , PCOLO3 ,&
323     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
324     &   ZSFLXZEN, ZTAUG   , ZTAUR    &
325     & ) 
326!    print *,'After  SRTM_TAUMOL24'
327
328  ELSEIF (JB == 25) THEN
329!--- visible 16000-22650 cm-1   0.4415 - 0.6250 um
330    CALL SRTM_TAUMOL25 &
331     & ( KLEV     ,&
332     &   PFAC00   , PFAC01  , PFAC10 , PFAC11 ,&
333     &   KJP      , KJT     , KJT1   , PONEMINUS ,&
334     &   PCOLH2O  , PCOLMOL , PCOLO3 ,&
335     &   KLAYTROP ,&
336     &   ZSFLXZEN, ZTAUG   , ZTAUR   &
337     & ) 
338!    print *,'After  SRTM_TAUMOL25'
339
340  ELSEIF (JB == 26) THEN
341!--- UV-A 22650-29000 cm-1   0.3448 - 0.4415 um
342    CALL SRTM_TAUMOL26 &
343     & ( KLEV    ,&
344     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
345     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
346     &   PCOLH2O , PCOLCO2 , PCOLMOL  ,&
347     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
348     &   ZSFLXZEN, ZTAUG   , ZTAUR    &
349     & ) 
350!    print *,'After  SRTM_TAUMOL26'
351
352  ELSEIF (JB == 27) THEN
353!--- UV-B 29000-38000 cm-1   0.2632 - 0.3448 um
354    CALL SRTM_TAUMOL27 &
355     & ( KLEV    ,&
356     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
357     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
358     &   PCOLMOL , PCOLO3 ,&
359     &   KLAYTROP ,&
360     &   ZSFLXZEN, ZTAUG   , ZTAUR    &
361     & ) 
362!    print *,'After  SRTM_TAUMOL27'
363
364  ELSEIF (JB == 28) THEN
365!--- UV-C 38000-50000 cm-1   0.2000 - 0.2632 um
366    CALL SRTM_TAUMOL28 &
367     & ( KLEV    ,&
368     &   PFAC00  , PFAC01  , PFAC10 , PFAC11 ,&
369     &   KJP     , KJT     , KJT1   , PONEMINUS ,&
370     &   PCOLMOL , PCOLO2  , PCOLO3 ,&
371     &   KLAYTROP ,&
372     &   ZSFLXZEN, ZTAUG   , ZTAUR  &
373     & ) 
374!    print *,'After  SRTM_TAUMOL28'
375
376  ELSEIF (JB == 29) THEN
377    CALL SRTM_TAUMOL29 &
378     & ( KLEV     ,&
379     &   PFAC00   , PFAC01  , PFAC10   , PFAC11 ,&
380     &   KJP      , KJT     , KJT1     , PONEMINUS ,&
381     &   PCOLH2O  , PCOLCO2 , PCOLMOL  ,&
382     &   KLAYTROP , PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
383     &   ZSFLXZEN , ZTAUG   , ZTAUR    &
384     & ) 
385!    print *,'After  SRTM_TAUMOL29'
386
387  ENDIF
388
389!  IF (NDBUG.LE.3) THEN
390!    print *,'Incident Solar Flux'
391!    PRINT 9010,(ZSFLXZEN(JG),JG=1,16)
392  9010 format(1x,'SolFlx ',16F8.4)
393!    print *,'Optical thickness for molecular absorption for JB= ',JB
394!    DO JK=1,KLEV
395!      PRINT 9011,JK,(ZTAUG(JK,JG),JG=1,16)
396  9011  format(1x,'TauGas ',I3,16E9.2)
397!    ENDDO
398!    print *,'Optical thickness for Rayleigh scattering for JB= ',JB
399!    DO JK=1,KLEV
400!      PRINT 9012,JK,(ZTAUR(JK,JG),JG=1,16)
401  9012  format(1x,'TauRay ',I3,16E9.2)
402!    ENDDO
403!  ENDIF
404
405  DO JG=1,IGT
406    IW=IW+1
407
408!    IF (NDBUG.LE.1) THEN
409!      print *,' === JG= ',JG,' === for JB= ',JB,' with IW, IBM, JPLAY, KLEV=',IW,IBM,JPLAY,KLEV
410!    ENDIF
411!    IF (NDBUG.LE.3) THEN
412!      print *,'Cloud optical properties for JB= ',JB
413!      DO JK=1,KLEV
414!        PRINT 9013,JK,PFRCL(IW,JK),PTAUC(JK,IW),POMGC(JK,IW),PASYC(JK,IW)
415  9013   format(1x,'Cloud optprop ',I3,f8.4,f8.3,2f8.5)
416!      ENDDO
417!    ENDIF
418
419    ZINCFLX(IW) =ZSFLXZEN(JG)*PRMU0
420    ZINCFLUX    =ZINCFLUX+ZSFLXZEN(JG)*PRMU0           
421    ZINCTOT     =ZINCTOT+ZSFLXZEN(JG)
422    ZINCF14(IBM)=ZINCF14(IBM)+ZSFLXZEN(JG)
423
424!-- CALL to compute layer reflectances and transmittances for direct
425!  and diffuse sources, first clear then cloudy.
426!   Use direct/parallel albedo for direct radiation and diffuse albedo
427!   otherwise.
428
429! ZREFC(JK)  direct albedo for clear
430! ZREFO(JK)  direct albedo for cloud
431! ZREFDC(JK) diffuse albedo for clear
432! ZREFDO(JK) diffuse albedo for cloud
433! ZTRAC(JK)  direct transmittance for clear
434! ZTRAO(JK)  direct transmittance for cloudy
435! ZTRADC(JK) diffuse transmittance for clear
436! ZTRADO(JK) diffuse transmittance for cloudy
437
438! ZREF(JK)   direct reflectance
439! ZREFD(JK)  diffuse reflectance
440! ZTRA(JK)   direct transmittance
441! ZTRAD(JK)  diffuse transmittance
442
443! ZDBTC(JK)  clear direct beam transmittance
444! ZDBTO(JK)  cloudy direct beam transmittance
445! ZDBT(JK)   layer mean direct beam transmittance
446! ZTDBT(JK)  total direct beam transmittance at levels
447
448!-- clear-sky   
449!----- TOA direct beam   
450    ZTDBTC(1)=1._JPRB
451!----- surface values
452    ZDBTC(KLEV+1) =0.0_JPRB
453    ZTRAC(KLEV+1) =0.0_JPRB
454    ZTRADC(KLEV+1)=0.0_JPRB
455    ZREFC(KLEV+1) =PALBP(IBM)
456    ZREFDC(KLEV+1)=PALBD(IBM)
457    ZRUPC(KLEV+1) =PALBP(IBM)
458    ZRUPDC(KLEV+1)=PALBD(IBM)
459           
460!-- total sky   
461!----- TOA direct beam   
462    ZTDBT(1)=1._JPRB
463!----- surface values
464    ZDBT(KLEV+1) =0.0_JPRB
465    ZTRA(KLEV+1) =0.0_JPRB
466    ZTRAD(KLEV+1)=0.0_JPRB
467    ZREF(KLEV+1) =PALBP(IBM)
468    ZREFD(KLEV+1)=PALBD(IBM)
469    ZRUP(KLEV+1) =PALBP(IBM)
470    ZRUPD(KLEV+1)=PALBD(IBM)
471!    if (NDBUG < 2) print *,'SWSPCTRL after 1 with JB,JG,IBM and IW= ',JB,JG,IBM,IW
472   
473
474!-- NB: a two-stream calculations from top to bottom, but RRTM_SW quantities
475!       are given bottom to top (argh!)
476!       Inputs for clouds and aerosols are bottom to top as inputs
477
478    DO JK=1,KLEV
479      IKL=KLEV+1-JK
480
481!-- clear-sky optical parameters     
482      LLRTCHK(JK)=.TRUE.
483
484!      print 9000,JK,JG,IKL,ZTAUR(IKL,JG),ZTAUG(IKL,JG),PTAUC(IKL,IW)
485      9000  format(1x,'Cloud quantities ',3I4,3E12.5)
486
487!-- original
488!      ZTAUC(JK)=ZTAUR(IKL,JG)+ZTAUG(IKL,JG)
489!      ZOMCC(JK)=ZTAUR(IKL,JG)/ZTAUC(JK)
490!      ZGCC (JK)=0.0001_JPRB
491
492!-- total sky optical parameters       
493!      ZTAUO(JK)=ZTAUR(IKL,JG)+ZTAUG(IKL,JG)+PTAUC(IKL,IW)
494!      ZOMCO(JK)=PTAUC(IKL,IW)*POMGC(IKL,IW)+ZTAUR(IKL,JG)
495!      ZGCO (JK)=(PTAUC(IKL,IW)*POMGC(IKL,IW)*PASYC(IKL,IW) &
496!        & +ZTAUR(IKL,JG)*0.0001_JPRB)/ZOMCO(JK)
497!      ZOMCO(JK)=ZOMCO(JK)/ZTAUO(JK)
498
499!-- clear-sky optical parameters including aerosols
500      ZTAUC(JK) = ZTAUR(IKL,JG) + ZTAUG(IKL,JG) + PTAUA(IKL,IBM)
501      ZOMCC(JK) = ZTAUR(IKL,JG)*1.0_JPRB + PTAUA(IKL,IBM)*POMGA(IKL,IBM)
502      ZGCC (JK) = PASYA(IKL,IBM)*POMGA(IKL,IBM)*PTAUA(IKL,IBM) / ZOMCC(JK)
503      ZOMCC(JK) = ZOMCC(JK) / ZTAUC(JK)
504
505    ENDDO
506    DO JK=1,KLEV
507      IKL=KLEV+1-JK
508!-- total sky optical parameters       
509      ZTAUO(JK) = ZTAUR(IKL,JG) + ZTAUG(IKL,JG) + PTAUA(IKL,IBM) + PTAUC(IKL,IW)
510      ZOMCO(JK) = PTAUA(IKL,IBM)*POMGA(IKL,IBM) + PTAUC(IKL,IW)*POMGC(IKL,IW) &
511       & + ZTAUR(IKL,JG)*1.0_JPRB 
512      ZGCO (JK) = (PTAUC(IKL,IW)*POMGC(IKL,IW)*PASYC(IKL,IW)  &
513       & +  PTAUA(IKL,IBM)*POMGA(IKL,IBM)*PASYA(IKL,IBM)) &
514       & /  ZOMCO(JK) 
515      ZOMCO(JK) = ZOMCO(JK) / ZTAUO(JK)
516
517!      if (NDBUG <2) THEN
518!        print 9001,JK,JG,LRTCHK(JK),0.00,ZTAUC(JK),ZOMCC(JK),ZGCC(JK),ZTAUR(IKL,JG),ZTAUG(IKL,JG)
519      9001    format(1x,'clear :',2I3,L4,7(1x,E13.6))
520!        print 9002,JK,JG,LRTCHK(JK),PFRCL(IW,IKL),ZTAUO(JK),ZOMCO(JK),ZGCO(JK) &
521!          &,PTAUC(IKL,IW),POMGC(IKL,IW),PASYC(IKL,IW)
522      9002    format(1x,'total0:',2I3,L4,7(1x,E13.6))
523!      end if
524    ENDDO   
525!    if (NDBUG < 2) print *,'SWSPCTRL after 2'
526
527!-- Delta scaling for clear-sky / aerosol optical quantities
528    DO  JK=1,KLEV
529      ZF=ZGCC(JK)*ZGCC(JK)
530      ZWF=ZOMCC(JK)*ZF
531      ZTAUC(JK)=(1._JPRB-ZWF)*ZTAUC(JK)
532      ZOMCC(JK)=(ZOMCC(JK)-ZWF)/(1.0_JPRB-ZWF)
533      ZGCC (JK)=(ZGCC(JK)-ZF)/(1.0_JPRB-ZF)
534    ENDDO
535   
536    CALL SRTM_REFTRA ( KLEV, I_KMODTS ,&
537     &   LLRTCHK, ZGCC  , PRMU0, ZTAUC , ZOMCC ,&
538     &   ZREFC  , ZREFDC, ZTRAC, ZTRADC ) 
539!    if (NDBUG < 2) print *,'SWSPCTR after SWREFTRA for clear-sky'
540   
541!-- Delta scaling for cloudy quantities
542    DO JK=1,KLEV
543      IKL=KLEV+1-JK
544      LLRTCHK(JK)=.FALSE.
545      ZF=ZGCO(JK)*ZGCO(JK)
546      ZWF=ZOMCO(JK)*ZF
547      ZTAUO(JK)=(1._JPRB-ZWF)*ZTAUO(JK)
548      ZOMCO(JK)=(ZOMCO(JK)-ZWF)/(1._JPRB-ZWF)
549      ZGCO (JK)=(ZGCO(JK)-ZF)/(1._JPRB-ZF)
550      LLRTCHK(JK)=(PFRCL(IW,IKL) > REPCLC)
551
552!      if (NDBUG < 2) THEN
553!        print 9003,JK,LRTCHK(JK),PFRCL(IW,IKL),ZTAUO(JK),ZOMCO(JK),ZGCO(JK) &
554!          &,PTAUC(IKL,IW),POMGC(IKL,IW),PASYC(IKL,IW)
555      9003    format(1x,'totalD:',I3,L4,7(1x,E13.6))
556!      end if
557
558    ENDDO
559!    if (NDBUG < 2) print *,'SWSPCTR after Delta scaling'
560   
561    CALL SRTM_REFTRA ( KLEV, I_KMODTS ,&
562     &   LLRTCHK, ZGCO  , PRMU0, ZTAUO , ZOMCO ,&
563     &   ZREFO , ZREFDO, ZTRAO, ZTRADO ) 
564!    if (NDBUG < 2) print *,'SWSPCTR after SWREFTRA for cloudy'
565
566    DO JK=1,KLEV
567
568!-- combine clear and cloudy contributions for total sky
569
570      IKL=KLEV+1-JK
571      ZCLEAR   = 1.0_JPRB - PFRCL(IW,IKL)
572      ZCLOUD   = PFRCL(IW,IKL)
573
574      ZREF(JK) = ZCLEAR*ZREFC(JK) + ZCLOUD*ZREFO(JK)
575      ZREFD(JK)= ZCLEAR*ZREFDC(JK)+ ZCLOUD*ZREFDO(JK)
576      ZTRA(JK) = ZCLEAR*ZTRAC(JK) + ZCLOUD*ZTRAO(JK)
577      ZTRAD(JK)= ZCLEAR*ZTRADC(JK)+ ZCLOUD*ZTRADO(JK)
578
579!-- direct beam transmittance       
580      ZARG1      = MIN( 200._JPRB, ZTAUC(JK)/PRMU0 )
581      ZARG2      = MIN( 200._JPRB, ZTAUO(JK)/PRMU0 )
582!      if (PRMU0 <= 0.05_JPRB ) THEN
583!        print 9198,JB,IW,JK,PRMU0,ZTAUC(JK),ZTAUO(JK),PTAUC(IKL,IW),ZARG1,ZARG2,ZCLEAR,ZCLOUD,ZTDBT(JK),PFRCL(IW,IKL)
5849198    format(1x,'Dbg:',3I4,10E13.6)
585!        print 9198,KPT,JB,IW,JK,ZTAUC(JK),ZTAUO(JK),ZARG1,ZARG2,ZCLEAR,ZCLOUD,ZTDBT(JK),PFRCL(IW,IKL)
586!9198    format(1x,'Dbg:',4I4,9E13.6)
587!      endif
588      ZDBTMC     = EXP(-ZARG1 )
589      ZDBTMO     = EXP(-ZARG2 )
590      ZDBT(JK)   = ZCLEAR*ZDBTMC+ZCLOUD*ZDBTMO
591      ZTDBT(JK+1)= ZDBT(JK)*ZTDBT(JK)
592       
593!-- clear-sky       
594      ZDBTC(JK)   =ZDBTMC
595      ZTDBTC(JK+1)=ZDBTC(JK)*ZTDBTC(JK)
596
597     
598      IF (PRMU0 <= 0.05_JPRB) THEN
599!      if (NDBUG < 2) print 9200,JK,ZREFC(JK),ZREFDC(JK),ZTRAC(JK),ZTRADC(JK),ZDBTC(JK),ZTDBTC(JK+1)
600!      if (NDBUG < 2) print 9199,JK,ZREF(JK),ZREFD(JK),ZTRA(JK),ZTRAD(JK),ZDBT(JK),ZTDBT(JK+1)
601!        print 9200,JK,ZREFC(JK),ZREFDC(JK),ZTRAC(JK),ZTRADC(JK),ZDBTC(JK),ZTDBTC(JK+1),ZCLEAR,ZCLOUD,PRMU0
602!        print 9199,JK,ZREF (JK),ZREFD (JK),ZTRA (JK),ZTRAD (JK),ZDBT (JK),ZTDBT (JK+1),ZTAUC(JK),ZTAUO(JK)
603      ENDIF
604      9199  format(1x,'Comb total:',I3,9E13.6)
605      9200  format(1x,'Comb clear:',I3,9E13.6)
606
607    ENDDO           
608!    if (NDBUG < 2) print *,'SRTM_SPCVRT after combining clear and cloudy'
609                 
610!-- vertical quadrature producing clear-sky fluxes
611
612!    print *,'SRTM_SPCVRT after 3 before SRTM_VRTQDR clear'
613   
614    CALL SRTM_VRTQDR ( KLEV, IW ,&
615     &   ZREFC, ZREFDC, ZTRAC , ZTRADC ,&
616     &   ZDBTC, ZRDNDC, ZRUPC , ZRUPDC, ZTDBTC ,&
617     &   ZCD  , ZCU   ) 
618     
619!    IF (NDBUG < 2) THEN
620!      print *,'SRTM_SPCVRT out of SRTM_VRTQDR for clear IW=',IW 
621!      DO JK=1,KLEV+1
622!        print 9201,JK,ZCD(JK,IW),ZCU(JK,IW)
623    9201    format(1x,'clear-sky contrib to fluxes',I3,2F12.4)
624!      ENDDO     
625!    ENDIF
626
627!-- vertical quadrature producing cloudy fluxes
628
629!    print *,'SRTM_SPCVRT after 4 before SRTM_VRTQDR cloudy'
630   
631    CALL SRTM_VRTQDR ( KLEV, IW ,&
632     &   ZREF , ZREFD , ZTRA , ZTRAD ,&
633     &   ZDBT , ZRDND , ZRUP , ZRUPD , ZTDBT ,&
634     &   ZFD  , ZFU   ) 
635 
636!    IF (NDBUG < 2) THEN     
637!      print *,'SRTM_SPCVRT out of SRTM_VRTQDR for cloudy IW=',IW
638!      DO JK=1,KLEV+1
639!        print 9202,JK,ZFD(JK,IW),ZFU(JK,IW)
640    9202    format(1x,'cloudy sky contrib to fluxes',I3,2F12.4)
641!      ENDDO     
642!    ENDIF
643
644!-- up and down-welling fluxes at levels
645    DO JK=1,KLEV+1
646!-- accumulation of spectral fluxes         
647      PBBFU(JK) = PBBFU(JK) + ZINCFLX(IW)*ZFU(JK,IW)
648      PBBFD(JK) = PBBFD(JK) + ZINCFLX(IW)*ZFD(JK,IW)
649      PBBCU(JK) = PBBCU(JK) + ZINCFLX(IW)*ZCU(JK,IW)
650      PBBCD(JK) = PBBCD(JK) + ZINCFLX(IW)*ZCD(JK,IW)
651
652! to get NIR, visible and UV quantities
653
654!      PBBFU(JK)=PBBFU(JK)+RWGT(IW)*ZFU(JK,IW)
655!      PBBFD(JK)=PBBFD(JK)+RWGT(IW)*ZFD(JK,IW)
656!      PBBCU(JK)=PBBCU(JK)+RWGT(IW)*ZCU(JK,IW)
657!      PBBCD(JK)=PBBCD(JK)+RWGT(IW)*ZCD(JK,IW)
658!      IF (IW <= NUV) THEN
659!        PUVFD(JK)=PUVFD(JK)+RWGT(IW)*ZFD(JK,IW)
660!        PUVFU(JK)=PUVFU(JK)+RWGT(IW)*ZFU(JK,IW)
661!        PUVCD(JK)=PUVCD(JK)+RWGT(IW)*ZCD(JK,IW)
662!        PUVCU(JK)=PUVCU(JK)+RWGT(IW)*ZCU(JK,IW)
663!      ELSE IF (IW == NUV+1 .AND. IW <= NVS) THEN 
664!        PVSFD(JK)=PVSFD(JK)+RWGT(IW)*ZFD(JK,IW)
665!        PVSFU(JK)=PVSFU(JK)+RWGT(IW)*ZFU(JK,IW)
666!        PVSCD(JK)=PVSCD(JK)+RWGT(IW)*ZCD(JK,IW)
667!        PVSCU(JK)=PVSCU(JK)+RWGT(IW)*ZCU(JK,IW)
668!      ELSE IF (IW > NVS) THEN 
669!        PNIFD(JK)=PNIFD(JK)+RWGT(IW)*ZFD(JK,IW)
670!        PNIFU(JK)=PNIFU(JK)+RWGT(IW)*ZFU(JK,IW)
671!        PNICD(JK)=PNICD(JK)+RWGT(IW)*ZCD(JK,IW)
672!        PNICU(JK)=PNICU(JK)+RWGT(IW)*ZCU(JK,IW)
673!      ENDIF 
674!      if (NDBUG < 2) then
675!!      if (JG.EQ.IGT) THEN
676!           print 9206,JB,JG,JK,IW,PBBCU(JK),PBBCD(JK),PBBFU(JK),PBBFD(JK)
677      9206      format(1x,'fluxes up to:',3I3,I4,6E13.6)       
678!      end if
679    ENDDO
680
681!    if (NDBUG < 2) print *,'SRTM_SPCVRT end of JG=',JG,' for JB=',JB,' i.e. IW=',IW
682  ENDDO             
683!-- end loop on JG
684
685!  print *,' --- JB= ',JB,' with IB1, IB2= ',IB1,IB2
686ENDDO                   
687!-- end loop on JB
688!if (NDBUG < 2) print *,'SRTM_SPCVRT about to come out'
689!print *,'SRTM_SPCVRT about to come out'
690
691!DO IBM=1,14
692!  print 9301,IBM,ZINCF14(IBM), ZINCTOT, ZINCF14(IBM)/ZINCTOT
6939301 format(1x,'Incident Spectral Flux: ',I3,2E15.8,F12.8)
694!ENDDO
695
696!     ------------------------------------------------------------------
697IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT_MCICA',1,ZHOOK_HANDLE)
698END SUBROUTINE SRTM_SPCVRT_MCICA
Note: See TracBrowser for help on using the repository browser.