source: LMDZ6/trunk/libf/phylmd/ecrad.v1.5.1/srtm_gas_optical_depth.F90 @ 5407

Last change on this file since 5407 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: 10.5 KB
Line 
1#ifdef RS6K
2@PROCESS HOT(NOVECTOR) NOSTRICT
3#endif
4SUBROUTINE SRTM_GAS_OPTICAL_DEPTH &
5 & ( KIDIA   , KFDIA   , KLEV    , PONEMINUS, &
6 &   PRMU0, &
7 &   KLAYTROP,&
8 &   PCOLCH4  , PCOLCO2 , PCOLH2O , PCOLMOL  , PCOLO2 , PCOLO3 ,&
9 &   PFORFAC , PFORFRAC , KINDFOR , PSELFFAC, PSELFFRAC, KINDSELF ,&
10 &   PFAC00  , PFAC01   , PFAC10  , PFAC11 ,&
11 &   KJP     , KJT      , KJT1 ,&
12 !-- output arrays
13 &   POD, PSSA, PINCSOL)
14
15
16!**** *SRTM_GAS_OPTICAL_DEPTH* - SPECTRAL LOOP TO COMPUTE THE SHORTWAVE RADIATION FLUXES.
17
18!     PURPOSE.
19!     --------
20
21!          COMPUTE THE GAS OPTICAL DEPTH AT EACH SHORTWAVE G POINT
22
23!**   INTERFACE.
24!     ----------
25
26!          *SRTM_GAS_OPTICAL_DEPTH* IS CALLED FROM THE NEW RADIATION SCHEME
27
28!        IMPLICIT ARGUMENTS :
29!        --------------------
30
31!     ==== INPUTS ===
32!     ==== OUTPUTS ===
33
34!     METHOD.
35!     -------
36
37!     EXTERNALS.
38!     ----------
39
40!     REFERENCE.
41!     ----------
42
43!        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
44!        DOCUMENTATION
45!     AUTHOR.
46!     -------
47!        ADAPTED FROM SRTM_SPCVRT_MCICA (BY JEAN-JACQUES MORCRETTE) BY
48!        ROBIN HOGAN
49!
50!     MODIFICATIONS.
51!     --------------
52!        ORIGINAL : 2015-07-16
53
54!     ------------------------------------------------------------------
55
56USE PARKIND1 , ONLY : JPIM, JPRB
57USE YOMHOOK  , ONLY : LHOOK, DR_HOOK
58USE PARSRTM  , ONLY : JPB1, JPB2
59USE YOESRTM  , ONLY : JPGPT
60USE YOESRTWN , ONLY : NGC
61
62IMPLICIT NONE
63
64!     ------------------------------------------------------------------
65
66!*       0.1   ARGUMENTS
67!              ---------
68
69INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA, KFDIA
70INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
71REAL(KIND=JPRB)   ,INTENT(IN)    :: PONEMINUS(KIDIA:KFDIA)
72REAL(KIND=JPRB)   ,INTENT(IN)    :: PRMU0(KIDIA:KFDIA)
73INTEGER(KIND=JPIM),INTENT(IN)    :: KLAYTROP(KIDIA:KFDIA)
74REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOLCH4(KIDIA:KFDIA,KLEV)
75REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOLCO2(KIDIA:KFDIA,KLEV)
76REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOLH2O(KIDIA:KFDIA,KLEV)
77REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOLMOL(KIDIA:KFDIA,KLEV)
78REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOLO2(KIDIA:KFDIA,KLEV)
79REAL(KIND=JPRB)   ,INTENT(IN)    :: PCOLO3(KIDIA:KFDIA,KLEV)
80REAL(KIND=JPRB)   ,INTENT(IN)    :: PFORFAC(KIDIA:KFDIA,KLEV)
81REAL(KIND=JPRB)   ,INTENT(IN)    :: PFORFRAC(KIDIA:KFDIA,KLEV)
82INTEGER(KIND=JPIM),INTENT(IN)    :: KINDFOR(KIDIA:KFDIA,KLEV)
83REAL(KIND=JPRB)   ,INTENT(IN)    :: PSELFFAC(KIDIA:KFDIA,KLEV)
84REAL(KIND=JPRB)   ,INTENT(IN)    :: PSELFFRAC(KIDIA:KFDIA,KLEV)
85INTEGER(KIND=JPIM),INTENT(IN)    :: KINDSELF(KIDIA:KFDIA,KLEV)
86REAL(KIND=JPRB)   ,INTENT(IN)    :: PFAC00(KIDIA:KFDIA,KLEV)
87REAL(KIND=JPRB)   ,INTENT(IN)    :: PFAC01(KIDIA:KFDIA,KLEV)
88REAL(KIND=JPRB)   ,INTENT(IN)    :: PFAC10(KIDIA:KFDIA,KLEV)
89REAL(KIND=JPRB)   ,INTENT(IN)    :: PFAC11(KIDIA:KFDIA,KLEV)
90INTEGER(KIND=JPIM),INTENT(IN)    :: KJP(KIDIA:KFDIA,KLEV)
91INTEGER(KIND=JPIM),INTENT(IN)    :: KJT(KIDIA:KFDIA,KLEV)
92INTEGER(KIND=JPIM),INTENT(IN)    :: KJT1(KIDIA:KFDIA,KLEV)
93
94REAL(KIND=JPRB)   ,INTENT(OUT)   :: POD(KIDIA:KFDIA,KLEV,JPGPT) ! Optical depth
95REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSSA(KIDIA:KFDIA,KLEV,JPGPT) ! Single scattering albedo
96REAL(KIND=JPRB)   ,INTENT(OUT)   :: PINCSOL(KIDIA:KFDIA,JPGPT) ! Incoming solar flux
97
98
99!     ------------------------------------------------------------------
100
101INTEGER(KIND=JPIM) :: IB1, IB2, IBM, IGT, IW(KIDIA:KFDIA), JB, JG, JK, JL, IC, ICOUNT
102
103INTEGER(KIND=JPIM) :: IND(KFDIA-KIDIA+1)
104
105
106!-- Output of SRTM_TAUMOLn routines
107REAL(KIND=JPRB) :: ZTAUG(KIDIA:KFDIA,KLEV,16) ! Absorption optical depth
108REAL(KIND=JPRB) :: ZTAUR(KIDIA:KFDIA,KLEV,16) ! Rayleigh optical depth
109REAL(KIND=JPRB) :: ZSFLXZEN(KIDIA:KFDIA,16) ! Incoming solar flux
110
111
112REAL(KIND=JPRB) :: ZTAU, ZPAO, ZPTO
113REAL(KIND=JPRB) :: ZPAOJ(KIDIA:KFDIA,KLEV)
114REAL(KIND=JPRB) :: ZPTOJ(KIDIA:KFDIA,KLEV)
115REAL(KIND=JPRB) :: ZRMU0D(KIDIA:KFDIA)
116 
117REAL(KIND=JPRB) :: ZHOOK_HANDLE
118
119
120#include "srtm_taumol16.intfb.h"
121#include "srtm_taumol17.intfb.h"
122#include "srtm_taumol18.intfb.h"
123#include "srtm_taumol19.intfb.h"
124#include "srtm_taumol20.intfb.h"
125#include "srtm_taumol21.intfb.h"
126#include "srtm_taumol22.intfb.h"
127#include "srtm_taumol23.intfb.h"
128#include "srtm_taumol24.intfb.h"
129#include "srtm_taumol25.intfb.h"
130#include "srtm_taumol26.intfb.h"
131#include "srtm_taumol27.intfb.h"
132#include "srtm_taumol28.intfb.h"
133#include "srtm_taumol29.intfb.h"
134
135!     ------------------------------------------------------------------
136ASSOCIATE(NFLEVG=>KLEV)
137IF (LHOOK) CALL DR_HOOK('SRTM_GAS_OPTICAL_DEPTH',0,ZHOOK_HANDLE)
138
139IB1=JPB1
140IB2=JPB2
141
142IC=0
143DO JL = KIDIA, KFDIA
144  IF (PRMU0(JL) > 0.0_JPRB) THEN
145    IC=IC+1
146    IND(IC)=JL
147    IW(JL)=0
148  ENDIF
149ENDDO
150ICOUNT=IC
151IF(ICOUNT==0)THEN
152  IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT_MCICA',1,ZHOOK_HANDLE)
153  RETURN
154ENDIF
155
156JB=IB1-1
157DO JB = IB1, IB2
158  DO IC=1,ICOUNT
159    JL=IND(IC)
160    IBM = JB-15
161    IGT = NGC(IBM)
162  ENDDO
163
164  !-- for each band, computes the gaseous and Rayleigh optical thickness
165  !  for all g-points within the band
166
167  IF (JB == 16) THEN
168    CALL SRTM_TAUMOL16 &
169     & ( KIDIA   , KFDIA    , KLEV    ,&
170     &   PFAC00  , PFAC01   , PFAC10   , PFAC11   ,&
171     &   KJP     , KJT      , KJT1     , PONEMINUS,&
172     &   PCOLH2O , PCOLCH4  , PCOLMOL  ,&
173     &   KLAYTROP, PSELFFAC , PSELFFRAC, KINDSELF, PFORFAC  , PFORFRAC, KINDFOR ,&
174     &   ZSFLXZEN, ZTAUG    , ZTAUR    , PRMU0     &
175     & ) 
176
177  ELSEIF (JB == 17) THEN
178    CALL SRTM_TAUMOL17 &
179     & ( KIDIA   , KFDIA   , KLEV    ,&
180     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
181     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
182     &   PCOLH2O , PCOLCO2 , PCOLMOL  ,&
183     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
184     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
185     & ) 
186
187  ELSEIF (JB == 18) THEN
188    CALL SRTM_TAUMOL18 &
189     & ( KIDIA   , KFDIA   , KLEV    ,&
190     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
191     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
192     &   PCOLH2O , PCOLCH4 , PCOLMOL  ,&
193     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
194     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
195     & ) 
196
197  ELSEIF (JB == 19) THEN
198    CALL SRTM_TAUMOL19 &
199     & ( KIDIA   , KFDIA   , KLEV    ,&
200     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
201     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
202     &   PCOLH2O , PCOLCO2 , PCOLMOL  ,&
203     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
204     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
205     & ) 
206
207  ELSEIF (JB == 20) THEN
208    CALL SRTM_TAUMOL20 &
209     & ( KIDIA   , KFDIA   , KLEV    ,&
210     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
211     &   KJP     , KJT     , KJT1     ,&
212     &   PCOLH2O , PCOLCH4 , PCOLMOL  ,&
213     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
214     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
215     & ) 
216
217  ELSEIF (JB == 21) THEN
218    CALL SRTM_TAUMOL21 &
219     & ( KIDIA   , KFDIA   , KLEV    ,&
220     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
221     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
222     &   PCOLH2O , PCOLCO2 , PCOLMOL  ,&
223     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
224     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
225     & ) 
226
227  ELSEIF (JB == 22) THEN
228    CALL SRTM_TAUMOL22 &
229     & ( KIDIA   , KFDIA   , KLEV    ,&
230     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
231     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
232     &   PCOLH2O , PCOLMOL , PCOLO2   ,&
233     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
234     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
235     & ) 
236
237  ELSEIF (JB == 23) THEN
238    CALL SRTM_TAUMOL23 &
239     & ( KIDIA   , KFDIA   , KLEV    ,&
240     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
241     &   KJP     , KJT     , KJT1     ,&
242     &   PCOLH2O , PCOLMOL ,&
243     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
244     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
245     & ) 
246
247  ELSEIF (JB == 24) THEN
248    CALL SRTM_TAUMOL24 &
249     & ( KIDIA   , KFDIA   , KLEV    ,&
250     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
251     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
252     &   PCOLH2O , PCOLMOL , PCOLO2   , PCOLO3 ,&
253     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
254     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
255     & ) 
256
257  ELSEIF (JB == 25) THEN
258    !--- visible 16000-22650 cm-1   0.4415 - 0.6250 um
259    CALL SRTM_TAUMOL25 &
260     & ( KIDIA    , KFDIA   , KLEV     ,&
261     &   PFAC00   , PFAC01  , PFAC10 , PFAC11 ,&
262     &   KJP      , KJT     , KJT1   ,&
263     &   PCOLH2O  , PCOLMOL , PCOLO3 ,&
264     &   KLAYTROP ,&
265     &   ZSFLXZEN, ZTAUG   , ZTAUR   , PRMU0     &
266     & ) 
267
268  ELSEIF (JB == 26) THEN
269    !--- UV-A 22650-29000 cm-1   0.3448 - 0.4415 um
270    CALL SRTM_TAUMOL26 &
271     & ( KIDIA   , KFDIA   , KLEV    ,&
272     &   PCOLMOL ,KLAYTROP,&
273     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
274     & ) 
275
276  ELSEIF (JB == 27) THEN
277    !--- UV-B 29000-38000 cm-1   0.2632 - 0.3448 um
278    CALL SRTM_TAUMOL27 &
279     & ( KIDIA   , KFDIA   , KLEV    ,&
280     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
281     &   KJP     , KJT     , KJT1     ,&
282     &   PCOLMOL , PCOLO3 ,&
283     &   KLAYTROP ,&
284     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
285     & ) 
286
287  ELSEIF (JB == 28) THEN
288    !--- UV-C 38000-50000 cm-1   0.2000 - 0.2632 um
289    CALL SRTM_TAUMOL28 &
290     & ( KIDIA   , KFDIA   , KLEV    ,&
291     &   PFAC00  , PFAC01  , PFAC10 , PFAC11 ,&
292     &   KJP     , KJT     , KJT1   , PONEMINUS ,&
293     &   PCOLMOL , PCOLO2  , PCOLO3 ,&
294     &   KLAYTROP ,&
295     &   ZSFLXZEN, ZTAUG   , ZTAUR  , PRMU0     &
296     & ) 
297
298  ELSEIF (JB == 29) THEN
299    CALL SRTM_TAUMOL29 &
300     & ( KIDIA    , KFDIA   , KLEV     ,&
301     &   PFAC00   , PFAC01  , PFAC10   , PFAC11 ,&
302     &   KJP      , KJT     , KJT1     ,&
303     &   PCOLH2O  , PCOLCO2 , PCOLMOL  ,&
304     &   KLAYTROP , PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
305     &   ZSFLXZEN , ZTAUG   , ZTAUR    , PRMU0     &
306     & ) 
307
308  ENDIF
309   
310  DO JG=1,IGT
311    DO IC=1,ICOUNT
312      JL=IND(IC)
313      IW(JL)=IW(JL)+1
314
315      ! Incoming solar flux into plane perp to incoming radiation
316      PINCSOL(JL,IW(JL)) = ZSFLXZEN(JL,JG)
317    ENDDO
318
319    DO JK=1,KLEV
320      DO IC=1,ICOUNT
321        JL=IND(IC)
322        POD (JL,JK,IW(JL)) = ZTAUR(JL,JK,JG) + ZTAUG(JL,JK,JG)
323        PSSA(JL,JK,IW(JL)) = ZTAUR(JL,JK,JG) / POD(JL,JK,IW(JL))
324      ENDDO
325    ENDDO
326
327  ENDDO   !-- end loop on JG (g point)
328
329ENDDO     !-- end loop on JB (band)
330
331!     ------------------------------------------------------------------
332IF (LHOOK) CALL DR_HOOK('SRTM_GAS_OPTICAL_DEPTH',1,ZHOOK_HANDLE)
333END ASSOCIATE
334END SUBROUTINE SRTM_GAS_OPTICAL_DEPTH
Note: See TracBrowser for help on using the repository browser.