source: LMDZ6/trunk/libf/phylmd/ecrad/ifsrrtm/srtm_gas_optical_depth.F90 @ 5450

Last change on this file since 5450 was 4773, checked in by idelkadi, 13 months ago
  • Update of Ecrad in LMDZ The same organization of the Ecrad offline version is retained in order to facilitate the updating of Ecrad in LMDZ and the comparison between online and offline results. version 1.6.1 of Ecrad (​https://github.com/lguez/ecrad.git)
  • Implementation of the double call of Ecrad in LMDZ


File size: 10.4 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, JPHOOK
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
111REAL(KIND=JPHOOK) :: ZHOOK_HANDLE
112
113
114#include "srtm_taumol16.intfb.h"
115#include "srtm_taumol17.intfb.h"
116#include "srtm_taumol18.intfb.h"
117#include "srtm_taumol19.intfb.h"
118#include "srtm_taumol20.intfb.h"
119#include "srtm_taumol21.intfb.h"
120#include "srtm_taumol22.intfb.h"
121#include "srtm_taumol23.intfb.h"
122#include "srtm_taumol24.intfb.h"
123#include "srtm_taumol25.intfb.h"
124#include "srtm_taumol26.intfb.h"
125#include "srtm_taumol27.intfb.h"
126#include "srtm_taumol28.intfb.h"
127#include "srtm_taumol29.intfb.h"
128
129!     ------------------------------------------------------------------
130
131IF (LHOOK) CALL DR_HOOK('SRTM_GAS_OPTICAL_DEPTH',0,ZHOOK_HANDLE)
132
133IB1=JPB1
134IB2=JPB2
135
136IC=0
137DO JL = KIDIA, KFDIA
138  IF (PRMU0(JL) > 0.0_JPRB) THEN
139    IC=IC+1
140    IND(IC)=JL
141    IW(JL)=0
142  ENDIF
143ENDDO
144ICOUNT=IC
145IF(ICOUNT==0)THEN
146  IF (LHOOK) CALL DR_HOOK('SRTM_SPCVRT_MCICA',1,ZHOOK_HANDLE)
147  RETURN
148ENDIF
149
150JB=IB1-1
151DO JB = IB1, IB2
152  DO IC=1,ICOUNT
153    JL=IND(IC)
154    IBM = JB-15
155    IGT = NGC(IBM)
156  ENDDO
157
158  !-- for each band, computes the gaseous and Rayleigh optical thickness
159  !  for all g-points within the band
160
161  IF (JB == 16) THEN
162    CALL SRTM_TAUMOL16 &
163     & ( KIDIA   , KFDIA    , KLEV    ,&
164     &   PFAC00  , PFAC01   , PFAC10   , PFAC11   ,&
165     &   KJP     , KJT      , KJT1     , PONEMINUS,&
166     &   PCOLH2O , PCOLCH4  , PCOLMOL  ,&
167     &   KLAYTROP, PSELFFAC , PSELFFRAC, KINDSELF, PFORFAC  , PFORFRAC, KINDFOR ,&
168     &   ZSFLXZEN, ZTAUG    , ZTAUR    , PRMU0     &
169     & ) 
170
171  ELSEIF (JB == 17) THEN
172    CALL SRTM_TAUMOL17 &
173     & ( KIDIA   , KFDIA   , KLEV    ,&
174     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
175     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
176     &   PCOLH2O , PCOLCO2 , PCOLMOL  ,&
177     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
178     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
179     & ) 
180
181  ELSEIF (JB == 18) THEN
182    CALL SRTM_TAUMOL18 &
183     & ( KIDIA   , KFDIA   , KLEV    ,&
184     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
185     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
186     &   PCOLH2O , PCOLCH4 , PCOLMOL  ,&
187     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
188     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
189     & ) 
190
191  ELSEIF (JB == 19) THEN
192    CALL SRTM_TAUMOL19 &
193     & ( KIDIA   , KFDIA   , KLEV    ,&
194     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
195     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
196     &   PCOLH2O , PCOLCO2 , PCOLMOL  ,&
197     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
198     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
199     & ) 
200
201  ELSEIF (JB == 20) THEN
202    CALL SRTM_TAUMOL20 &
203     & ( KIDIA   , KFDIA   , KLEV    ,&
204     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
205     &   KJP     , KJT     , KJT1     ,&
206     &   PCOLH2O , PCOLCH4 , PCOLMOL  ,&
207     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
208     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
209     & ) 
210
211  ELSEIF (JB == 21) THEN
212    CALL SRTM_TAUMOL21 &
213     & ( KIDIA   , KFDIA   , KLEV    ,&
214     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
215     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
216     &   PCOLH2O , PCOLCO2 , PCOLMOL  ,&
217     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
218     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
219     & ) 
220
221  ELSEIF (JB == 22) THEN
222    CALL SRTM_TAUMOL22 &
223     & ( KIDIA   , KFDIA   , KLEV    ,&
224     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
225     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
226     &   PCOLH2O , PCOLMOL , PCOLO2   ,&
227     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
228     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
229     & ) 
230
231  ELSEIF (JB == 23) THEN
232    CALL SRTM_TAUMOL23 &
233     & ( KIDIA   , KFDIA   , KLEV    ,&
234     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
235     &   KJP     , KJT     , KJT1     ,&
236     &   PCOLH2O , PCOLMOL ,&
237     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
238     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
239     & ) 
240
241  ELSEIF (JB == 24) THEN
242    CALL SRTM_TAUMOL24 &
243     & ( KIDIA   , KFDIA   , KLEV    ,&
244     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
245     &   KJP     , KJT     , KJT1     , PONEMINUS ,&
246     &   PCOLH2O , PCOLMOL , PCOLO2   , PCOLO3 ,&
247     &   KLAYTROP, PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
248     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
249     & ) 
250
251  ELSEIF (JB == 25) THEN
252    !--- visible 16000-22650 cm-1   0.4415 - 0.6250 um
253    CALL SRTM_TAUMOL25 &
254     & ( KIDIA    , KFDIA   , KLEV     ,&
255     &   PFAC00   , PFAC01  , PFAC10 , PFAC11 ,&
256     &   KJP      , KJT     , KJT1   ,&
257     &   PCOLH2O  , PCOLMOL , PCOLO3 ,&
258     &   KLAYTROP ,&
259     &   ZSFLXZEN, ZTAUG   , ZTAUR   , PRMU0     &
260     & ) 
261
262  ELSEIF (JB == 26) THEN
263    !--- UV-A 22650-29000 cm-1   0.3448 - 0.4415 um
264    CALL SRTM_TAUMOL26 &
265     & ( KIDIA   , KFDIA   , KLEV    ,&
266     &   PCOLMOL ,KLAYTROP,&
267     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
268     & ) 
269
270  ELSEIF (JB == 27) THEN
271    !--- UV-B 29000-38000 cm-1   0.2632 - 0.3448 um
272    CALL SRTM_TAUMOL27 &
273     & ( KIDIA   , KFDIA   , KLEV    ,&
274     &   PFAC00  , PFAC01  , PFAC10   , PFAC11 ,&
275     &   KJP     , KJT     , KJT1     ,&
276     &   PCOLMOL , PCOLO3 ,&
277     &   KLAYTROP ,&
278     &   ZSFLXZEN, ZTAUG   , ZTAUR    , PRMU0     &
279     & ) 
280
281  ELSEIF (JB == 28) THEN
282    !--- UV-C 38000-50000 cm-1   0.2000 - 0.2632 um
283    CALL SRTM_TAUMOL28 &
284     & ( KIDIA   , KFDIA   , KLEV    ,&
285     &   PFAC00  , PFAC01  , PFAC10 , PFAC11 ,&
286     &   KJP     , KJT     , KJT1   , PONEMINUS ,&
287     &   PCOLMOL , PCOLO2  , PCOLO3 ,&
288     &   KLAYTROP ,&
289     &   ZSFLXZEN, ZTAUG   , ZTAUR  , PRMU0     &
290     & ) 
291
292  ELSEIF (JB == 29) THEN
293    CALL SRTM_TAUMOL29 &
294     & ( KIDIA    , KFDIA   , KLEV     ,&
295     &   PFAC00   , PFAC01  , PFAC10   , PFAC11 ,&
296     &   KJP      , KJT     , KJT1     ,&
297     &   PCOLH2O  , PCOLCO2 , PCOLMOL  ,&
298     &   KLAYTROP , PSELFFAC, PSELFFRAC, KINDSELF  , PFORFAC, PFORFRAC, KINDFOR ,&
299     &   ZSFLXZEN , ZTAUG   , ZTAUR    , PRMU0     &
300     & ) 
301
302  ENDIF
303   
304  DO JG=1,IGT
305! Added for DWD (2020)
306!NEC$ ivdep
307    DO IC=1,ICOUNT
308      JL=IND(IC)
309      IW(JL)=IW(JL)+1
310
311      ! Incoming solar flux into plane perp to incoming radiation
312      PINCSOL(JL,IW(JL)) = ZSFLXZEN(JL,JG)
313    ENDDO
314
315    DO JK=1,KLEV
316      DO IC=1,ICOUNT
317        JL=IND(IC)
318        POD (JL,JK,IW(JL)) = ZTAUR(JL,JK,JG) + ZTAUG(JL,JK,JG)
319        PSSA(JL,JK,IW(JL)) = ZTAUR(JL,JK,JG) / POD(JL,JK,IW(JL))
320      ENDDO
321    ENDDO
322
323  ENDDO   !-- end loop on JG (g point)
324
325ENDDO     !-- end loop on JB (band)
326
327!     ------------------------------------------------------------------
328
329IF (LHOOK) CALL DR_HOOK('SRTM_GAS_OPTICAL_DEPTH',1,ZHOOK_HANDLE)
330
331END SUBROUTINE SRTM_GAS_OPTICAL_DEPTH
Note: See TracBrowser for help on using the repository browser.