source: LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/ifsrrtm/srtm_gas_optical_depth.F90 @ 4999

Last change on this file since 4999 was 4728, checked in by idelkadi, 11 months ago

Update of ecrad in the LMDZ_ECRad branch of LMDZ:

  • version 1.6.1 of ecrad
  • files are no longer grouped in the same ecrad directory.
  • the structure of ecrad offline is preserved to facilitate updating in LMDZ
  • cfg.bld modified to take into account the new added subdirectories.
  • the interface routines and those added in ecrad are moved to the phylmd directory
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.