source: LMDZ6/trunk/libf/phylmd/ecrad/srtm_spcvrt_mcica.F90.or @ 4013

Last change on this file since 4013 was 3908, checked in by idelkadi, 4 years ago

Online implementation of the radiative transfer code ECRAD in the LMDZ model.

  • Inclusion of the ecrad directory containing the sources of the ECRAD code
    • interface routine : radiation_scheme.F90
  • Adaptation of compilation scripts :
    • compilation under CPP key CPP_ECRAD
    • compilation with option "-rad ecard" or "-ecard true"
    • The "-rad old/rtm/ecran" build option will need to replace the "-rrtm true" and "-ecrad true" options in the future.
  • Runing LMDZ simulations with ecrad, you need :
    • logical key iflag_rrtm = 2 in physiq.def
    • namelist_ecrad (DefLists?)
    • the directory "data" containing the configuration files is temporarily placed in ../libfphylmd/ecrad/
  • Compilation and execution are tested in the 1D case. The repository under svn would allow to continue the implementation work: tests, verification of the results, ...
File size: 24.5 KB
Line 
1#ifdef RS6K
2@PROCESS HOT(NOVECTOR) NOSTRICT
3#endif
4SUBROUTINE SRTM_SPCVRT_MCICA &
5 & ( KIDIA   , KFDIA   , KLEV    , KSW    , KCOLS  , PONEMINUS, &
6 &   PALBD   , PALBP, &
7 &   PFRCL   , PTAUC   , PASYC  , POMGC  , PTAUA    , PASYA   , POMGA , PRMU0, &
8 &   KLAYTROP,&
9 &   PCOLCH4  , PCOLCO2 , PCOLH2O , PCOLMOL  , PCOLO2 , PCOLO3 ,&
10 &   PFORFAC , PFORFRAC , KINDFOR , PSELFFAC, PSELFFRAC, KINDSELF ,&
11 &   PFAC00  , PFAC01   , PFAC10  , PFAC11 ,&
12 &   KJP     , KJT      , KJT1 ,&
13 !-- output arrays
14 &   PBBFD   , PBBFU    , PBBCD, PBBCU, PFUVF, PFUVC, PPARF, PPARCF, PSUDU, &
15 &   PBBFDIR , PBBCDIR  , PSwDiffuseBand     , PSwDirectBand )
16
17
18!**** *SRTM_SPCVRT* - SPECTRAL LOOP TO COMPUTE THE SHORTWAVE RADIATION FLUXES.
19
20!     PURPOSE.
21!     --------
22
23!          THIS ROUTINE COMPUTES THE TWO-STREAM METHOD OF BARKER
24
25!**   INTERFACE.
26!     ----------
27
28!          *SRTM_SPCVRT_MCICA* IS CALLED FROM *SRTM_SRTM_224GP*
29
30!        IMPLICIT ARGUMENTS :
31!        --------------------
32
33!     ==== INPUTS ===
34!     ==== OUTPUTS ===
35
36!     METHOD.
37!     -------
38
39!     EXTERNALS.
40!     ----------
41
42!          *SWVRTQDR*
43
44!     REFERENCE.
45!     ----------
46
47!        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
48!        DOCUMENTATION
49!     AUTHOR.
50!     -------
51!        from Howard Barker
52!        JEAN-JACQUES MORCRETTE  *ECMWF*
53
54!     MODIFICATIONS.
55!     --------------
56!        ORIGINAL : 03-02-27
57!        M.Hamrud      01-Oct-2003 CY28 Cleaning
58!        JJMorcrette   20050110 McICA version
59!        JJMorcrette   20070614 bug-fix for solar duration
60!        JJMorcrette   20070831 UV-B surface flux
61!        D.Salmond  31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC
62!        JJMorcrette/MJIacono 20080724 Look-up table replacing exponential
63!        JJMorcrette   20091201 Total and clear-sky downward direct flux
64!        RJHogan       20140627 Store downwelling surface fluxes in each band
65!     ------------------------------------------------------------------
66
67USE PARKIND1 , ONLY : JPIM, JPRB
68USE YOMHOOK  , ONLY : LHOOK, DR_HOOK
69USE PARSRTM  , ONLY : JPB1, JPB2
70USE YOESRTM  , ONLY : JPGPT
71USE YOESRTWN , ONLY : NGC, NMPSRTM
72USE YOERDI   , ONLY : REPCLC
73USE YOESRTAB , ONLY : BPADE, TRANS, RODLOW, RTBLINT
74USE YOERAD   , ONLY : NSW, LApproxSwUpdate
75
76IMPLICIT NONE
77
78!     ------------------------------------------------------------------
79
80!*       0.1   ARGUMENTS
81!              ---------
82
83INTEGER(KIND=JPIM),INTENT(IN)    :: KSW
84INTEGER(KIND=JPIM),INTENT(IN)    :: KCOLS
85INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA, KFDIA
86INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
87REAL(KIND=JPRB)   ,INTENT(IN)    :: PONEMINUS(KIDIA:KFDIA)
88REAL(KIND=JPRB)   ,INTENT(IN)    :: PALBD(KIDIA:KFDIA,KSW)
89REAL(KIND=JPRB)   ,INTENT(IN)    :: PALBP(KIDIA:KFDIA,KSW)
90REAL(KIND=JPRB)   ,INTENT(IN)    :: PFRCL(KIDIA:KFDIA,KCOLS,KLEV)  ! bottom to top
91REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUC(KIDIA:KFDIA,KLEV,KCOLS)  ! bottom to top
92REAL(KIND=JPRB)   ,INTENT(IN)    :: PASYC(KIDIA:KFDIA,KLEV,KCOLS)  ! bottom to top
93REAL(KIND=JPRB)   ,INTENT(IN)    :: POMGC(KIDIA:KFDIA,KLEV,KCOLS)  ! bottom to top
94REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUA(KIDIA:KFDIA,KLEV,KSW)    ! bottom to top
95REAL(KIND=JPRB)   ,INTENT(IN)    :: PASYA(KIDIA:KFDIA,KLEV,KSW)    ! bottom to top
96REAL(KIND=JPRB)   ,INTENT(IN)    :: POMGA(KIDIA:KFDIA,KLEV,KSW)    ! bottom to top
97REAL(KIND=JPRB)   ,INTENT(IN)    :: PRMU0(KIDIA:KFDIA)
98INTEGER(KIND=JPIM),INTENT(IN)    :: KLAYTROP(KIDIA:KFDIA)
99REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOLCH4(KIDIA:KFDIA,KLEV)
100REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOLCO2(KIDIA:KFDIA,KLEV)
101REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOLH2O(KIDIA:KFDIA,KLEV)
102REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOLMOL(KIDIA:KFDIA,KLEV)
103REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOLO2(KIDIA:KFDIA,KLEV)
104REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOLO3(KIDIA:KFDIA,KLEV)
105REAL(KIND=JPRB)   ,INTENT(IN)    :: PFORFAC(KIDIA:KFDIA,KLEV)
106REAL(KIND=JPRB)   ,INTENT(IN)    :: PFORFRAC(KIDIA:KFDIA,KLEV)
107INTEGER(KIND=JPIM),INTENT(IN)    :: KINDFOR(KIDIA:KFDIA,KLEV)
108REAL(KIND=JPRB)   ,INTENT(IN)    :: PSELFFAC(KIDIA:KFDIA,KLEV)
109REAL(KIND=JPRB)   ,INTENT(IN)    :: PSELFFRAC(KIDIA:KFDIA,KLEV)
110INTEGER(KIND=JPIM),INTENT(IN)    :: KINDSELF(KIDIA:KFDIA,KLEV)
111REAL(KIND=JPRB)   ,INTENT(IN)    :: PFAC00(KIDIA:KFDIA,KLEV)
112REAL(KIND=JPRB)   ,INTENT(IN)    :: PFAC01(KIDIA:KFDIA,KLEV)
113REAL(KIND=JPRB)   ,INTENT(IN)    :: PFAC10(KIDIA:KFDIA,KLEV)
114REAL(KIND=JPRB)   ,INTENT(IN)    :: PFAC11(KIDIA:KFDIA,KLEV)
115INTEGER(KIND=JPIM),INTENT(IN)    :: KJP(KIDIA:KFDIA,KLEV)
116INTEGER(KIND=JPIM),INTENT(IN)    :: KJT(KIDIA:KFDIA,KLEV)
117INTEGER(KIND=JPIM),INTENT(IN)    :: KJT1(KIDIA:KFDIA,KLEV)
118REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBBFD(KIDIA:KFDIA,KLEV+1)
119REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBBFU(KIDIA:KFDIA,KLEV+1)
120REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBBCD(KIDIA:KFDIA,KLEV+1)
121REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBBCU(KIDIA:KFDIA,KLEV+1)
122REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFUVF(KIDIA:KFDIA), PFUVC(KIDIA:KFDIA)
123REAL(KIND=JPRB)   ,INTENT(OUT)   :: PPARF(KIDIA:KFDIA), PPARCF(KIDIA:KFDIA)
124REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSUDU(KIDIA:KFDIA)
125REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBBFDIR(KIDIA:KFDIA,KLEV+1)
126REAL(KIND=JPRB)   ,INTENT(INOUT) :: PBBCDIR(KIDIA:KFDIA,KLEV+1)
127
128! Surface diffuse and direct downwelling shortwave flux in each
129! shortwave albedo band, used in RADINTG to update the surface fluxes
130! accounting for high-resolution albedo information
131REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSwDiffuseBand(KIDIA:KFDIA,NSW)
132REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSwDirectBand(KIDIA:KFDIA,NSW)
133
134!     ------------------------------------------------------------------
135
136!              ------------
137
138LOGICAL :: LLRTCHK(KIDIA:KFDIA,KLEV)
139
140REAL(KIND=JPRB) :: &
141 & ZCLEAR(KIDIA:KFDIA)      , ZCLOUD(KIDIA:KFDIA)       &
142 & , ZDBT(KIDIA:KFDIA,KLEV+1) &
143 & , ZGCC(KIDIA:KFDIA,KLEV)   , ZGCO(KIDIA:KFDIA,KLEV)     &
144 & , ZOMCC(KIDIA:KFDIA,KLEV)  , ZOMCO(KIDIA:KFDIA,KLEV)    &
145 & , ZRDND(KIDIA:KFDIA,KLEV+1), ZRDNDC(KIDIA:KFDIA,KLEV+1)&
146 & , ZREF(KIDIA:KFDIA,KLEV+1) , ZREFC(KIDIA:KFDIA,KLEV+1) , ZREFO(KIDIA:KFDIA,KLEV+1)  &
147 & , ZREFD(KIDIA:KFDIA,KLEV+1), ZREFDC(KIDIA:KFDIA,KLEV+1), ZREFDO(KIDIA:KFDIA,KLEV+1) &
148 & , ZRUP(KIDIA:KFDIA,KLEV+1) , ZRUPD(KIDIA:KFDIA,KLEV+1) &
149 & , ZRUPC(KIDIA:KFDIA,KLEV+1), ZRUPDC(KIDIA:KFDIA,KLEV+1)&
150 & , ZTAUC(KIDIA:KFDIA,KLEV)  , ZTAUO(KIDIA:KFDIA,KLEV)    &
151 & , ZTDBT(KIDIA:KFDIA,KLEV+1) &
152 & , ZTRA(KIDIA:KFDIA,KLEV+1) , ZTRAC(KIDIA:KFDIA,KLEV+1) , ZTRAO(KIDIA:KFDIA,KLEV+1)  &
153 & , ZTRAD(KIDIA:KFDIA,KLEV+1), ZTRADC(KIDIA:KFDIA,KLEV+1), ZTRADO(KIDIA:KFDIA,KLEV+1)   
154REAL(KIND=JPRB) :: &
155 & ZDBTC(KIDIA:KFDIA,KLEV+1), ZTDBTC(KIDIA:KFDIA,KLEV+1), ZINCFLX(KIDIA:KFDIA,JPGPT)  &
156 & ,  ZINCF14(KIDIA:KFDIA,14)   , ZINCTOT(KIDIA:KFDIA)   
157
158INTEGER(KIND=JPIM) :: IB1, IB2, IBM, IGT, IKL, IW(KIDIA:KFDIA), JB, JG, JK, I_KMODTS, JL, IC, ICOUNT
159
160! An index for the 6 bands used in the original albedo data rather
161! than the 14 RRTM bands
162INTEGER(KIND=JPIM) :: JB_ALBEDO
163
164INTEGER(KIND=JPIM) :: INDEX(KIDIA:KFDIA)
165
166REAL(KIND=JPRB) :: ZDBTMC(KIDIA:KFDIA), ZDBTMO(KIDIA:KFDIA), ZF(KIDIA:KFDIA)
167! REAL(KIND=JPRB) :: ZARG1(KIDIA:KFDIA), ZARG2(KIDIA:KFDIA)
168REAL(KIND=JPRB) :: ZINCFLUX(KIDIA:KFDIA), ZWF(KIDIA:KFDIA)
169REAL(KIND=JPRB) :: ZCOEFVS
170
171!-- Output of SRTM_TAUMOLn routines
172
173REAL(KIND=JPRB) :: ZTAUG(KIDIA:KFDIA,KLEV,16), ZTAUR(KIDIA:KFDIA,KLEV,16), ZSFLXZEN(KIDIA:KFDIA,16)
174
175!-- Output of SRTM_VRTQDR routine
176REAL(KIND=JPRB) :: &
177 & ZCD(KIDIA:KFDIA,KLEV+1,JPGPT), ZCU(KIDIA:KFDIA,KLEV+1,JPGPT) &
178 & ,  ZFD(KIDIA:KFDIA,KLEV+1,JPGPT), ZFU(KIDIA:KFDIA,KLEV+1,JPGPT) 
179
180REAL(KIND=JPRB) :: ZTAU, ZPAO, ZPTO
181REAL(KIND=JPRB) :: ZPAOJ(KIDIA:KFDIA,KLEV)
182REAL(KIND=JPRB) :: ZPTOJ(KIDIA:KFDIA,KLEV)
183REAL(KIND=JPRB) :: ZRMU0D(KIDIA:KFDIA)
184 
185!--  Use of exponential look-up table
186REAL(KIND=JPRB) :: ZE1, ZE2, ZTBLIND
187INTEGER(KIND=JPIM) :: ITIND
188
189REAL(KIND=JPRB) :: ZHOOK_HANDLE
190
191
192#include "srtm_taumol16.intfb.h"
193#include "srtm_taumol17.intfb.h"
194#include "srtm_taumol18.intfb.h"
195#include "srtm_taumol19.intfb.h"
196#include "srtm_taumol20.intfb.h"
197#include "srtm_taumol21.intfb.h"
198#include "srtm_taumol22.intfb.h"
199#include "srtm_taumol23.intfb.h"
200#include "srtm_taumol24.intfb.h"
201#include "srtm_taumol25.intfb.h"
202#include "srtm_taumol26.intfb.h"
203#include "srtm_taumol27.intfb.h"
204#include "srtm_taumol28.intfb.h"
205#include "srtm_taumol29.intfb.h"
206#include "srtm_reftra.intfb.h"
207#include "srtm_vrtqdr.intfb.h"
208!     ------------------------------------------------------------------
209ASSOCIATE(NFLEVG=>KLEV)
210IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT_MCICA',0,ZHOOK_HANDLE)
211
212!-- Two-stream model 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discrete ordinates
213
214IB1=JPB1
215IB2=JPB2
216
217IC=0
218DO JL = KIDIA, KFDIA
219  IF (PRMU0(JL) > 0.0_JPRB) THEN
220    IC=IC+1
221    INDEX(IC)=JL
222    IW(JL)=0
223    ZINCFLUX(JL)=0.0_JPRB
224    ZINCTOT(JL)=0.0_JPRB
225    PFUVF(JL) = 0.0_JPRB
226    PFUVC(JL) = 0.0_JPRB
227    PPARF(JL) = 0.0_JPRB
228    PPARCF(JL)= 0.0_JPRB
229  ENDIF
230ENDDO
231ICOUNT=IC
232IF(ICOUNT==0)THEN
233  IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT_MCICA',1,ZHOOK_HANDLE)
234  RETURN
235ENDIF
236
237! Since the stored shortwave downwelling fluxes in bands are
238! accumulated over the g-points within that band, they need to be
239! initialized here
240IF (LApproxSwUpdate) THEN
241  DO JB_ALBEDO = 1,NSW
242    DO JL = KIDIA, KFDIA
243      PSwDiffuseBand(JL,JB_ALBEDO) = 0.0_JPRB
244      PSwDirectBand (JL,JB_ALBEDO) = 0.0_JPRB
245    ENDDO
246  ENDDO
247ENDIF
248
249
250!-- fraction of visible (to 0.69 um) in interval 0.6250-0.7782 um
251ZCOEFVS = 0.42425_JPRB
252
253JB=IB1-1
254DO JB = IB1, IB2
255  DO IC=1,ICOUNT
256    JL=INDEX(IC)
257    IBM = JB-15
258    IGT = NGC(IBM)
259    ZINCF14(JL,IBM)=0.0_JPRB
260  ENDDO
261
262  !-- for each band, computes the gaseous and Rayleigh optical thickness
263  !  for all g-points within the band
264
265  IF (JB == 16) THEN
266    CALL SRTM_TAUMOL16 &
267     & ( KIDIA   , KFDIA    , KLEV    ,&
268     &   PFAC00  , PFAC01   , PFAC10   , PFAC11   ,&
269     &   KJP     , KJT      , KJT1     , PONEMINUS,&
270     &   PCOLH2O , PCOLCH4  , PCOLMOL  ,&
271     &   KLAYTROP, PSELFFAC , PSELFFRAC, KINDSELF, PFORFAC  , PFORFRAC, KINDFOR ,&
272     &   ZSFLXZEN, ZTAUG    , ZTAUR    , PRMU0     &
273     & ) 
274
275  ELSEIF (JB == 17) THEN
276    CALL SRTM_TAUMOL17 &
277     & ( KIDIA   , KFDIA   , KLEV    ,&
278     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
279     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
280     &   PCOLH2O , PCOLCO2 , PCOLMOL  ,&
281     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
282     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
283     & ) 
284
285  ELSEIF (JB == 18) THEN
286    CALL SRTM_TAUMOL18 &
287     & ( KIDIA   , KFDIA   , KLEV    ,&
288     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
289     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
290     &   PCOLH2O , PCOLCH4 , PCOLMOL  ,&
291     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
292     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
293     & ) 
294
295  ELSEIF (JB == 19) THEN
296    CALL SRTM_TAUMOL19 &
297     & ( KIDIA   , KFDIA   , KLEV    ,&
298     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
299     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
300     &   PCOLH2O , PCOLCO2 , PCOLMOL  ,&
301     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
302     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
303     & ) 
304
305  ELSEIF (JB == 20) THEN
306    CALL SRTM_TAUMOL20 &
307     & ( KIDIA   , KFDIA   , KLEV    ,&
308     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
309     &   KJP     , KJT     , KJT1     ,&
310     &   PCOLH2O , PCOLCH4 , PCOLMOL  ,&
311     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
312     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
313     & ) 
314
315  ELSEIF (JB == 21) THEN
316    CALL SRTM_TAUMOL21 &
317     & ( KIDIA   , KFDIA   , KLEV    ,&
318     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
319     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
320     &   PCOLH2O , PCOLCO2 , PCOLMOL  ,&
321     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
322     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
323     & ) 
324
325  ELSEIF (JB == 22) THEN
326    CALL SRTM_TAUMOL22 &
327     & ( KIDIA   , KFDIA   , KLEV    ,&
328     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
329     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
330     &   PCOLH2O , PCOLMOL , PCOLO2   ,&
331     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
332     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
333     & ) 
334
335  ELSEIF (JB == 23) THEN
336    CALL SRTM_TAUMOL23 &
337     & ( KIDIA   , KFDIA   , KLEV    ,&
338     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
339     &   KJP     , KJT     , KJT1     ,&
340     &   PCOLH2O , PCOLMOL ,&
341     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
342     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
343     & ) 
344
345  ELSEIF (JB == 24) THEN
346    CALL SRTM_TAUMOL24 &
347     & ( KIDIA   , KFDIA   , KLEV    ,&
348     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
349     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
350     &   PCOLH2O , PCOLMOL , PCOLO2   , PCOLO3 ,&
351     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
352     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
353     & ) 
354
355  ELSEIF (JB == 25) THEN
356    !--- visible 16000-22650 cm-1   0.4415 - 0.6250 um
357    CALL SRTM_TAUMOL25 &
358     & ( KIDIA    , KFDIA   , KLEV     ,&
359     &   PFAC00   , PFAC01  , PFAC10 , PFAC11 ,&
360     &   KJP      , KJT     , KJT1   ,&
361     &   PCOLH2O  , PCOLMOL , PCOLO3 ,&
362     &   KLAYTROP ,&
363     &   ZSFLXZEN, ZTAUG   , ZTAUR   , PRMU0     &
364     & ) 
365
366  ELSEIF (JB == 26) THEN
367    !--- UV-A 22650-29000 cm-1   0.3448 - 0.4415 um
368    CALL SRTM_TAUMOL26 &
369     & ( KIDIA   , KFDIA   , KLEV    ,&
370     &   PCOLMOL ,KLAYTROP,&
371     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
372     & ) 
373
374  ELSEIF (JB == 27) THEN
375    !--- UV-B 29000-38000 cm-1   0.2632 - 0.3448 um
376    CALL SRTM_TAUMOL27 &
377     & ( KIDIA   , KFDIA   , KLEV    ,&
378     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
379     &   KJP     , KJT     , KJT1     ,&
380     &   PCOLMOL , PCOLO3 ,&
381     &   KLAYTROP ,&
382     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
383     & ) 
384
385  ELSEIF (JB == 28) THEN
386    !--- UV-C 38000-50000 cm-1   0.2000 - 0.2632 um
387    CALL SRTM_TAUMOL28 &
388     & ( KIDIA   , KFDIA   , KLEV    ,&
389     &   PFAC00  , PFAC01  , PFAC10 , PFAC11 ,&
390     &   KJP     , KJT     , KJT1   , PONEMINUS ,&
391     &   PCOLMOL , PCOLO2  , PCOLO3 ,&
392     &   KLAYTROP ,&
393     &   ZSFLXZEN, ZTAUG   , ZTAUR  , PRMU0     &
394     & ) 
395
396  ELSEIF (JB == 29) THEN
397    CALL SRTM_TAUMOL29 &
398     & ( KIDIA    , KFDIA   , KLEV     ,&
399     &   PFAC00   , PFAC01  , PFAC10   , PFAC11 ,&
400     &   KJP      , KJT     , KJT1     ,&
401     &   PCOLH2O  , PCOLCO2 , PCOLMOL  ,&
402     &   KLAYTROP , PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
403     &   ZSFLXZEN , ZTAUG   , ZTAUR    , PRMU0     &
404     & ) 
405
406  ENDIF
407   
408!J---Start---
409  DO JK=1,KLEV
410    IKL=KLEV+1-JK
411    DO IC=1,ICOUNT
412      JL=INDEX(IC)
413      ZPAOJ(JL,JK) = PASYA(JL,IKL,IBM)*POMGA(JL,IKL,IBM)
414      ZPTOJ(JL,JK) = PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM)
415    ENDDO
416  ENDDO
417!J---End---
418
419  DO JG=1,IGT
420    DO IC=1,ICOUNT
421      JL=INDEX(IC)
422      IW(JL)=IW(JL)+1
423
424      ZINCFLX(JL,IW(JL)) =ZSFLXZEN(JL,JG)*PRMU0(JL)
425      ZINCFLUX(JL)    =ZINCFLUX(JL)+ZSFLXZEN(JL,JG)*PRMU0(JL)           
426      ZINCTOT(JL)     =ZINCTOT(JL)+ZSFLXZEN(JL,JG)
427      ZINCF14(JL,IBM)=ZINCF14(JL,IBM)+ZSFLXZEN(JL,JG)
428
429      !-- CALL to compute layer reflectances and transmittances for direct
430      !  and diffuse sources, first clear then cloudy.
431      !   Use direct/parallel albedo for direct radiation and diffuse albedo
432      !   otherwise.
433
434      ! ZREFC(JK)  direct albedo for clear
435      ! ZREFO(JK)  direct albedo for cloud
436      ! ZREFDC(JK) diffuse albedo for clear
437      ! ZREFDO(JK) diffuse albedo for cloud
438      ! ZTRAC(JK)  direct transmittance for clear
439      ! ZTRAO(JK)  direct transmittance for cloudy
440      ! ZTRADC(JK) diffuse transmittance for clear
441      ! ZTRADO(JK) diffuse transmittance for cloudy
442
443      ! ZREF(JK)   direct reflectance
444      ! ZREFD(JK)  diffuse reflectance
445      ! ZTRA(JK)   direct transmittance
446      ! ZTRAD(JK)  diffuse transmittance
447
448      ! ZDBTC(JK)  clear direct beam transmittance
449      ! ZDBTO(JK)  cloudy direct beam transmittance
450      ! ZDBT(JK)   layer mean direct beam transmittance
451      ! ZTDBT(JK)  total direct beam transmittance at levels
452
453      !-- clear-sky   
454      !----- TOA direct beam   
455      ZTDBTC(JL,1)=1._JPRB
456      !----- surface values
457      ZDBTC(JL,KLEV+1) =0.0_JPRB
458      ZTRAC(JL,KLEV+1) =0.0_JPRB
459      ZTRADC(JL,KLEV+1)=0.0_JPRB
460      ZREFC(JL,KLEV+1) =PALBP(JL,IBM)
461      ZREFDC(JL,KLEV+1)=PALBD(JL,IBM)
462      ZRUPC(JL,KLEV+1) =PALBP(JL,IBM)
463      ZRUPDC(JL,KLEV+1)=PALBD(JL,IBM)
464
465      !-- total sky   
466      !----- TOA direct beam   
467      ZTDBT(JL,1)=1._JPRB
468      !----- surface values
469      ZDBT(JL,KLEV+1) =0.0_JPRB
470      ZTRA(JL,KLEV+1) =0.0_JPRB
471      ZTRAD(JL,KLEV+1)=0.0_JPRB
472      ZREF(JL,KLEV+1) =PALBP(JL,IBM)
473      ZREFD(JL,KLEV+1)=PALBD(JL,IBM)
474      ZRUP(JL,KLEV+1) =PALBP(JL,IBM)
475      ZRUPD(JL,KLEV+1)=PALBD(JL,IBM)
476    ENDDO
477
478
479    !-- NB: a two-stream calculations from top to bottom, but RRTM_SW quantities
480    !       are given bottom to top (argh!)
481    !       Inputs for clouds and aerosols are bottom to top as inputs
482
483!    DO JK=1,KLEV
484!      IKL=KLEV+1-JK
485!      WRITE(NULOUT,8001) IBM,JG,IKL,(PTAUA(INDEX(IC),IKL,IBM),IC=1,ICOUNT)
4868001  format(1X,'McICA_SW',3I5,30E12.5)
487!    ENDDO
488
489
490
491    DO JK=1,KLEV
492      IKL=KLEV+1-JK
493      DO IC=1,ICOUNT
494        JL=INDEX(IC)
495        !-- clear-sky optical parameters     
496        LLRTCHK(JL,JK)=.TRUE.
497        !-- clear-sky optical parameters including aerosols
498!J      ZTAUC(JL,JK) = ZTAUR(JL,IKL,JG) + ZTAUG(JL,IKL,JG) + PTAUA(JL,IKL,IBM)
499!J      ZOMCC(JL,JK) = ZTAUR(JL,IKL,JG)*1.0_JPRB + PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM)
500!J      ZGCC(JL,JK) = PASYA(JL,IKL,IBM)*POMGA(JL,IKL,IBM)*PTAUA(JL,IKL,IBM) / ZOMCC(JL,JK)
501!J      ZOMCC(JL,JK) = ZOMCC(JL,JK) / ZTAUC(JL,JK)
502!J    ENDDO
503!J  ENDDO
504!J  DO JK=1,KLEV
505!J    IKL=KLEV+1-JK
506!J    DO IC=1,ICOUNT
507!J      JL=INDEX(IC)
508!J      !-- total sky optical parameters       
509!J      ZTAUO(JL,JK) = ZTAUR(JL,IKL,JG) + ZTAUG(JL,IKL,JG) + PTAUA(JL,IKL,IBM) + PTAUC(JL,IKL,IW(JL))
510!J      ZOMCO(JL,JK) = PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM) + PTAUC(JL,IKL,IW(JL))*POMGC(JL,IKL,IW(JL)) &
511!J       & + ZTAUR(JL,IKL,JG)*1.0_JPRB 
512!J      ZGCO(JL,JK) = (PTAUC(JL,IKL,IW(JL))*POMGC(JL,IKL,IW(JL))*PASYC(JL,IKL,IW(JL))  &
513!J       & +  PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM)*PASYA(JL,IKL,IBM)) &
514!J       & /  ZOMCO(JL,JK) 
515!J      ZOMCO(JL,JK) = ZOMCO(JL,JK) / ZTAUO(JL,JK)
516
517        ZTAU = ZTAUR(JL,IKL,JG) + ZTAUG(JL,IKL,JG)
518!       ZPAO = PASYA(JL,IKL,IBM)*POMGA(JL,IKL,IBM)
519!       ZPTO = PTAUA(JL,IKL,IBM)*POMGA(JL,IKL,IBM)
520        ZPAO = ZPAOJ(JL,JK)
521        ZPTO = ZPTOJ(JL,JK)
522        ZTAUC(JL,JK) = ZTAU + PTAUA(JL,IKL,IBM)
523        ZOMCC(JL,JK) = ZTAUR(JL,IKL,JG) + ZPTO
524        ZGCC(JL,JK) = ZPAO*PTAUA(JL,IKL,IBM) / ZOMCC(JL,JK)
525        ZOMCC(JL,JK) = ZOMCC(JL,JK) / ZTAUC(JL,JK)
526        !-- total sky optical parameters       
527        ZTAUO(JL,JK) = ZTAU + PTAUA(JL,IKL,IBM) + PTAUC(JL,IKL,IW(JL))
528        ZOMCO(JL,JK) = ZPTO + PTAUC(JL,IKL,IW(JL))*POMGC(JL,IKL,IW(JL)) + ZTAUR(JL,IKL,JG) 
529        ZGCO(JL,JK) = (PTAUC(JL,IKL,IW(JL))*POMGC(JL,IKL,IW(JL))*PASYC(JL,IKL,IW(JL))  &
530         & +  PTAUA(JL,IKL,IBM)*ZPAO) /  ZOMCO(JL,JK) 
531        ZOMCO(JL,JK) = ZOMCO(JL,JK) / ZTAUO(JL,JK)
532      ENDDO
533    ENDDO
534
535    !-- Delta scaling for clear-sky / aerosol optical quantities
536    DO  JK=1,KLEV
537      DO IC=1,ICOUNT
538        JL=INDEX(IC)
539        ZF(JL)=ZGCC(JL,JK)*ZGCC(JL,JK)
540        ZWF(JL)=ZOMCC(JL,JK)*ZF(JL)
541        ZTAUC(JL,JK)=(1._JPRB-ZWF(JL))*ZTAUC(JL,JK)
542        ZOMCC(JL,JK)=(ZOMCC(JL,JK)-ZWF(JL))/(1.0_JPRB-ZWF(JL))
543        ZGCC(JL,JK)=(ZGCC(JL,JK)-ZF(JL))/(1.0_JPRB-ZF(JL))
544      ENDDO
545    ENDDO
546
547    CALL SRTM_REFTRA ( KIDIA, KFDIA, KLEV, I_KMODTS ,&
548     &   LLRTCHK, ZGCC  , PRMU0, ZTAUC , ZOMCC ,&
549     &   ZREFC  , ZREFDC, ZTRAC, ZTRADC ) 
550
551    !-- Delta scaling for cloudy quantities
552    DO JK=1,KLEV
553      IKL=KLEV+1-JK
554      DO IC=1,ICOUNT
555        JL=INDEX(IC)
556        LLRTCHK(JL,JK)=.FALSE.
557        ZF(JL)=ZGCO(JL,JK)*ZGCO(JL,JK)
558        ZWF(JL)=ZOMCO(JL,JK)*ZF(JL)
559        ZTAUO(JL,JK)=(1._JPRB-ZWF(JL))*ZTAUO(JL,JK)
560        ZOMCO(JL,JK)=(ZOMCO(JL,JK)-ZWF(JL))/(1._JPRB-ZWF(JL))
561        ZGCO(JL,JK)=(ZGCO(JL,JK)-ZF(JL))/(1._JPRB-ZF(JL))
562        LLRTCHK(JL,JK)=(PFRCL(JL,IW(JL),IKL) > REPCLC)
563      ENDDO
564    ENDDO
565
566    CALL SRTM_REFTRA ( KIDIA, KFDIA, KLEV, I_KMODTS ,&
567     &   LLRTCHK, ZGCO  , PRMU0, ZTAUO , ZOMCO ,&
568     &   ZREFO , ZREFDO, ZTRAO, ZTRADO ) 
569
570!J---Start---
571    DO IC=1,ICOUNT
572      JL=INDEX(IC)
573      ZRMU0D(JL)=1.0_JPRB/PRMU0(JL)
574    ENDDO
575!J---End---
576
577    DO JK=1,KLEV
578      IKL=KLEV+1-JK
579      DO IC=1,ICOUNT
580        JL=INDEX(IC)
581        !-- combine clear and cloudy contributions for total sky
582
583        ZCLEAR(JL)   = 1.0_JPRB - PFRCL(JL,IW(JL),IKL)
584        ZCLOUD(JL)   = PFRCL(JL,IW(JL),IKL)
585
586        ZREF(JL,JK) = ZCLEAR(JL)*ZREFC(JL,JK) + ZCLOUD(JL)*ZREFO(JL,JK)
587        ZREFD(JL,JK)= ZCLEAR(JL)*ZREFDC(JL,JK)+ ZCLOUD(JL)*ZREFDO(JL,JK)
588        ZTRA(JL,JK) = ZCLEAR(JL)*ZTRAC(JL,JK) + ZCLOUD(JL)*ZTRAO(JL,JK)
589        ZTRAD(JL,JK)= ZCLEAR(JL)*ZTRADC(JL,JK)+ ZCLOUD(JL)*ZTRADO(JL,JK)
590
591        !-- direct beam transmittance       
592!        ZARG1(JL)      = MIN( 200._JPRB, ZTAUC(JL,JK)/PRMU0(JL) )
593!        ZARG2(JL)      = MIN( 200._JPRB, ZTAUO(JL,JK)/PRMU0(JL) )
594!        ZDBTMC(JL)     = EXP(-ZARG1(JL) )
595!        ZDBTMO(JL)     = EXP(-ZARG2(JL) )
596
597!-- Use exponential look-up table for transmittance, or expansion of exponential for
598!   low optical thickness
599!J      ZE1 = ZTAUC(JL,JK)/PRMU0(JL)
600        ZE1 = ZTAUC(JL,JK)*ZRMU0D(JL)
601        IF (ZE1 <= RODLOW) THEN
602          ZDBTMC(JL) = 1._JPRB - ZE1 + 0.5_JPRB*ZE1*ZE1
603        ELSE
604          ZTBLIND = ZE1 / (BPADE+ZE1)
605          ITIND = RTBLINT * ZTBLIND + 0.5_JPRB
606          ZDBTMC(JL) = TRANS(ITIND)
607        ENDIF
608
609!J      ZE2 = ZTAUO(JL,JK)/PRMU0(JL)
610        ZE2 = ZTAUO(JL,JK)*ZRMU0D(JL)
611        IF (ZE2 <= RODLOW) THEN
612          ZDBTMO(JL) = 1._JPRB - ZE2 + 0.5_JPRB*ZE2*ZE2
613        ELSE
614          ZTBLIND = ZE2 / (BPADE+ZE2)
615          ITIND = RTBLINT * ZTBLIND + 0.5_JPRB
616          ZDBTMO(JL) = TRANS(ITIND)
617        ENDIF
618!---
619
620        ZDBT(JL,JK)   = ZCLEAR(JL)*ZDBTMC(JL)+ZCLOUD(JL)*ZDBTMO(JL)
621        ZTDBT(JL,JK+1)= ZDBT(JL,JK)*ZTDBT(JL,JK)
622
623        !-- clear-sky       
624        ZDBTC(JL,JK)   =ZDBTMC(JL)
625        ZTDBTC(JL,JK+1)=ZDBTC(JL,JK)*ZTDBTC(JL,JK)
626
627      ENDDO
628    ENDDO
629
630    !-- vertical quadrature producing clear-sky fluxes
631
632    !    print *,'SRTM_SPCVRT after 3 before SRTM_VRTQDR clear'
633
634    CALL SRTM_VRTQDR ( KIDIA, KFDIA, KLEV, IW ,&
635     &   ZREFC, ZREFDC, ZTRAC , ZTRADC ,&
636     &   ZDBTC, ZRDNDC, ZRUPC , ZRUPDC, ZTDBTC ,&
637     &   ZCD  , ZCU   , PRMU0 ) 
638
639    !-- vertical quadrature producing cloudy fluxes
640
641    CALL SRTM_VRTQDR ( KIDIA, KFDIA, KLEV, IW ,&
642     &   ZREF , ZREFD , ZTRA , ZTRAD ,&
643     &   ZDBT , ZRDND , ZRUP , ZRUPD , ZTDBT ,&
644     &   ZFD  , ZFU   , PRMU0) 
645
646    !-- up and down-welling fluxes at levels
647    DO JK=1,KLEV+1
648      DO IC=1,ICOUNT
649        JL=INDEX(IC)
650        !-- accumulation of spectral fluxes         
651        PBBFU(JL,JK) = PBBFU(JL,JK) + ZINCFLX(JL,IW(JL))*ZFU(JL,JK,IW(JL))
652        PBBFD(JL,JK) = PBBFD(JL,JK) + ZINCFLX(JL,IW(JL))*ZFD(JL,JK,IW(JL))
653        PBBCU(JL,JK) = PBBCU(JL,JK) + ZINCFLX(JL,IW(JL))*ZCU(JL,JK,IW(JL))
654        PBBCD(JL,JK) = PBBCD(JL,JK) + ZINCFLX(JL,IW(JL))*ZCD(JL,JK,IW(JL))
655
656        PBBFDIR(JL,JK)=PBBFDIR(JL,JK)+ZINCFLX(JL,IW(JL))*ZTDBT (JL,JK)
657        PBBCDIR(JL,JK)=PBBCDIR(JL,JK)+ZINCFLX(JL,IW(JL))*ZTDBTC(JL,JK)
658
659      ENDDO
660    ENDDO
661    DO IC=1,ICOUNT
662      JL=INDEX(IC)
663      IF ( JB >= 26 .AND. JB <= 28 ) THEN
664        PFUVF(JL) = PFUVF(JL) + ZINCFLX(JL,IW(JL))*ZFD(JL,KLEV+1,IW(JL))
665        PFUVC(JL) = PFUVC(JL) + ZINCFLX(JL,IW(JL))*ZCD(JL,KLEV+1,IW(JL))
666      ENDIF
667      IF ( JB == 23) THEN
668        PPARF(JL) = PPARF(JL)+ ZINCFLX(JL,IW(JL))*ZFD(JL,KLEV+1,IW(JL))*ZCOEFVS
669        PPARCF(JL)=PPARCF(JL)+ ZINCFLX(JL,IW(JL))*ZCD(JL,KLEV+1,IW(JL))*ZCOEFVS
670      ENDIF
671      IF ( JB == 24) THEN
672        PPARF(JL) = PPARF(JL)+ ZINCFLX(JL,IW(JL))*ZFD(JL,KLEV+1,IW(JL))
673        PPARCF(JL)=PPARCF(JL)+ ZINCFLX(JL,IW(JL))*ZCD(JL,KLEV+1,IW(JL))
674      ENDIF
675      PSUDU(JL) = PSUDU(JL)  + ZINCFLX(JL,IW(JL))*ZTDBT(JL,KLEV+1)
676    ENDDO
677
678    ! Store the shortwave downwelling fluxes in each band
679    IF (LApproxSwUpdate) THEN
680      JB_ALBEDO = NMPSRTM(JB-IB1+1)
681      DO IC = 1,ICOUNT
682        JL = INDEX(IC)
683        PSwDiffuseBand(JL,JB_ALBEDO)= PSwDiffuseBand(JL,JB_ALBEDO) &
684             & + ZINCFLX(JL,IW(JL)) * (ZFD(JL, KLEV+1, IW(JL))-ZTDBT(JL,KLEV+1))
685        PSwDirectBand(JL,JB_ALBEDO) = PSwDirectBand(JL,JB_ALBEDO) &
686             & + ZINCFLX(JL,IW(JL)) * ZTDBT(JL,KLEV+1)
687      ENDDO
688    ENDIF
689
690  ENDDO
691  !-- end loop on JG
692
693ENDDO
694!-- end loop on JB
695
696!     ------------------------------------------------------------------
697IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT_MCICA',1,ZHOOK_HANDLE)
698END ASSOCIATE
699END SUBROUTINE SRTM_SPCVRT_MCICA
Note: See TracBrowser for help on using the repository browser.