source: LMDZ6/trunk/libf/phylmd/ecrad/ifsrrtm/srtm_taumol24.F90 @ 5440

Last change on this file since 5440 was 4773, checked in by idelkadi, 12 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: 7.5 KB
Line 
1SUBROUTINE SRTM_TAUMOL24 &
2 & ( KIDIA   , KFDIA    , KLEV,&
3 & P_FAC00   , P_FAC01  , P_FAC10   , P_FAC11,&
4 & K_JP      , K_JT     , K_JT1     , P_ONEMINUS,&
5 & P_COLH2O  , P_COLMOL , P_COLO2   , P_COLO3,&
6 & K_LAYTROP , P_SELFFAC, P_SELFFRAC, K_INDSELF  , P_FORFAC, P_FORFRAC, K_INDFOR,&
7 & P_SFLUXZEN, P_TAUG   , P_TAUR    , PRMU0   &
8 & ) 
9
10!     Written by Eli J. Mlawer, Atmospheric & Environmental Research.
11
12!     BAND 24:  12850-16000 cm-1 (low - H2O,O2; high - O2)
13
14! Modifications
15!        M.Hamrud      01-Oct-2003 CY28 Cleaning
16
17!     JJMorcrette 2003-02-24 adapted to ECMWF environment
18!        D.Salmond  31-Oct-2007 Vector version in the style of RRTM from Meteo France & NEC
19!     JJMorcrette 20110610 Flexible configuration for number of g-points
20
21USE PARKIND1 , ONLY : JPIM, JPRB
22USE YOMHOOK  , ONLY : LHOOK, DR_HOOK, JPHOOK
23USE PARSRTM  , ONLY : JPG
24USE YOESRTM  , ONLY : NG24
25USE YOESRTA24, ONLY : ABSA, ABSB, FORREFC, SELFREFC, SFLUXREFC, &
26 & ABSO3AC, ABSO3BC, RAYLAC, RAYLBC, LAYREFFR, STRRAT 
27USE YOESRTWN , ONLY : NSPA, NSPB
28
29IMPLICIT NONE
30
31!-- Output
32INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA, KFDIA
33INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
34REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC00(KIDIA:KFDIA,KLEV)
35REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC01(KIDIA:KFDIA,KLEV)
36REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC10(KIDIA:KFDIA,KLEV)
37REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC11(KIDIA:KFDIA,KLEV)
38INTEGER(KIND=JPIM),INTENT(IN)    :: K_JP(KIDIA:KFDIA,KLEV)
39INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT(KIDIA:KFDIA,KLEV)
40INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT1(KIDIA:KFDIA,KLEV)
41REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ONEMINUS(KIDIA:KFDIA)
42REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLH2O(KIDIA:KFDIA,KLEV)
43REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLMOL(KIDIA:KFDIA,KLEV)
44REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLO2(KIDIA:KFDIA,KLEV)
45REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLO3(KIDIA:KFDIA,KLEV)
46INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYTROP(KIDIA:KFDIA)
47REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFAC(KIDIA:KFDIA,KLEV)
48REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFRAC(KIDIA:KFDIA,KLEV)
49INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDSELF(KIDIA:KFDIA,KLEV)
50REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FORFAC(KIDIA:KFDIA,KLEV)
51REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FORFRAC(KIDIA:KFDIA,KLEV)
52INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDFOR(KIDIA:KFDIA,KLEV)
53
54REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_SFLUXZEN(KIDIA:KFDIA,JPG)
55REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAUG(KIDIA:KFDIA,KLEV,JPG)
56REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAUR(KIDIA:KFDIA,KLEV,JPG)
57REAL(KIND=JPRB)   ,INTENT(IN)    :: PRMU0(KIDIA:KFDIA)
58!- from INTFAC     
59!- from INTIND
60!- from PRECISE             
61!- from PROFDATA             
62!- from SELF             
63INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS, INDF, JS, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON
64
65INTEGER(KIND=JPIM) :: I_LAY_NEXT
66
67REAL(KIND=JPRB) :: Z_FAC000, Z_FAC001, Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101,&
68 & Z_FAC110, Z_FAC111, Z_FS, Z_SPECCOMB, Z_SPECMULT, Z_SPECPARM, &
69 & Z_TAURAY 
70REAL(KIND=JPHOOK) :: ZHOOK_HANDLE
71
72IF (LHOOK) CALL DR_HOOK('SRTM_TAUMOL24',0,ZHOOK_HANDLE)
73
74I_NLAYERS = KLEV
75
76!     Compute the optical depth by interpolating in ln(pressure),
77!     temperature, and appropriate species.  Below LAYTROP, the water
78!     vapor self-continuum is interpolated (in temperature) separately. 
79
80I_LAYSOLFR(KIDIA:KFDIA) = K_LAYTROP(KIDIA:KFDIA)
81
82DO I_LAY = 1, I_NLAYERS
83  I_LAY_NEXT = MIN(I_NLAYERS, I_LAY+1)
84  DO IPLON = KIDIA, KFDIA
85    IF (PRMU0(IPLON) > 0.0_JPRB) THEN
86      IF (I_LAY <= K_LAYTROP(IPLON)) THEN
87        IF (K_JP(IPLON,I_LAY) < LAYREFFR .AND. K_JP(IPLON,I_LAY_NEXT) >= LAYREFFR) &
88         & I_LAYSOLFR(IPLON) = MIN(I_LAY+1,K_LAYTROP(IPLON)) 
89        Z_SPECCOMB = P_COLH2O(IPLON,I_LAY) + STRRAT*P_COLO2(IPLON,I_LAY)
90        Z_SPECPARM = P_COLH2O(IPLON,I_LAY)/Z_SPECCOMB
91        IF (Z_SPECPARM >= P_ONEMINUS(IPLON)) Z_SPECPARM = P_ONEMINUS(IPLON)
92        Z_SPECMULT = 8.*(Z_SPECPARM)
93        JS = 1 + INT(Z_SPECMULT)
94        Z_FS = MOD(Z_SPECMULT, 1.0_JPRB )
95        ! Z_FAC000 = (1. - Z_FS) * P_FAC00(I_LAY)
96        ! Z_FAC010 = (1. - Z_FS) * P_FAC10(I_LAY)
97        ! Z_FAC100 = Z_FS * P_FAC00(I_LAY)
98        ! Z_FAC110 = Z_FS * P_FAC10(I_LAY)
99        ! Z_FAC001 = (1. - Z_FS) * P_FAC01(I_LAY)
100        ! Z_FAC011 = (1. - Z_FS) * P_FAC11(I_LAY)
101        ! Z_FAC101 = Z_FS * P_FAC01(I_LAY)
102        ! Z_FAC111 = Z_FS * P_FAC11(I_LAY)
103        IND0 = ((K_JP(IPLON,I_LAY)-1)*5+(K_JT(IPLON,I_LAY)-1))*NSPA(24) + JS
104        IND1 = (K_JP(IPLON,I_LAY)*5+(K_JT1(IPLON,I_LAY)-1))*NSPA(24) + JS
105        INDS = K_INDSELF(IPLON,I_LAY)
106        INDF = K_INDFOR(IPLON,I_LAY)
107
108        !  DO IG = 1, NG(24)
109!CDIR UNROLL=NG24
110        DO IG = 1 , NG24
111          Z_TAURAY = P_COLMOL(IPLON,I_LAY) * (RAYLAC(IG,JS) + &
112           & Z_FS * (RAYLAC(IG,JS+1) - RAYLAC(IG,JS))) 
113          P_TAUG(IPLON,I_LAY,IG) = Z_SPECCOMB * &
114           !    & (Z_FAC000 * ABSA(IND0,IG) + &
115           !    & Z_FAC100 * ABSA(IND0+1,IG) + &
116           !    & Z_FAC010 * ABSA(IND0+9,IG) + &
117           !    & Z_FAC110 * ABSA(IND0+10,IG) + &
118           !    & Z_FAC001 * ABSA(IND1,IG) + &
119           !    & Z_FAC101 * ABSA(IND1+1,IG) + &
120           !    & Z_FAC011 * ABSA(IND1+9,IG) + &
121           !    & Z_FAC111 * ABSA(IND1+10,IG)) + &
122           & (&
123           & (1. - Z_FS) * ( ABSA(IND0,IG) * P_FAC00(IPLON,I_LAY) + &
124           &                 ABSA(IND0+9,IG) * P_FAC10(IPLON,I_LAY) + &
125           &                 ABSA(IND1,IG) * P_FAC01(IPLON,I_LAY) + &
126           &                 ABSA(IND1+9,IG) * P_FAC11(IPLON,I_LAY) ) + &
127           & Z_FS        * ( ABSA(IND0+1,IG) * P_FAC00(IPLON,I_LAY) + &
128           &                 ABSA(IND0+10,IG) * P_FAC10(IPLON,I_LAY) + &
129           &                 ABSA(IND1+1,IG) * P_FAC01(IPLON,I_LAY) + &
130           &                 ABSA(IND1+10,IG) * P_FAC11(IPLON,I_LAY) ) &
131           & ) + &
132           & P_COLO3(IPLON,I_LAY) * ABSO3AC(IG) + &
133           & P_COLH2O(IPLON,I_LAY) *  &
134           & (P_SELFFAC(IPLON,I_LAY) * (SELFREFC(INDS,IG) + &
135           & P_SELFFRAC(IPLON,I_LAY) * &
136           & (SELFREFC(INDS+1,IG) - SELFREFC(INDS,IG))) + &
137           & P_FORFAC(IPLON,I_LAY) * (FORREFC(INDF,IG) +  &
138           & P_FORFRAC(IPLON,I_LAY) * &
139           & (FORREFC(INDF+1,IG) - FORREFC(INDF,IG)))) 
140          !     &           + TAURAY
141          !    SSA(LAY,IG) = TAURAY/TAUG(LAY,IG)
142          IF (I_LAY == I_LAYSOLFR(IPLON)) P_SFLUXZEN(IPLON,IG) = SFLUXREFC(IG,JS) &
143           & + Z_FS * (SFLUXREFC(IG,JS+1) - SFLUXREFC(IG,JS)) 
144          P_TAUR(IPLON,I_LAY,IG) =  Z_TAURAY
145        ENDDO
146      ENDIF
147    ENDIF
148  ENDDO
149ENDDO
150
151DO I_LAY = 1, I_NLAYERS
152  DO IPLON = KIDIA, KFDIA
153    IF (PRMU0(IPLON) > 0.0_JPRB) THEN
154      IF (I_LAY >= K_LAYTROP(IPLON)+1) THEN
155        IND0 = ((K_JP(IPLON,I_LAY)-13)*5+(K_JT(IPLON,I_LAY)-1))*NSPB(24) + 1
156        IND1 = ((K_JP(IPLON,I_LAY)-12)*5+(K_JT1(IPLON,I_LAY)-1))*NSPB(24) + 1
157
158        !  DO IG = 1, NG(24)
159!CDIR UNROLL=NG24
160        DO IG = 1 , NG24
161          Z_TAURAY = P_COLMOL(IPLON,I_LAY) * RAYLBC(IG)
162          P_TAUG(IPLON,I_LAY,IG) = P_COLO2(IPLON,I_LAY) * &
163           & (P_FAC00(IPLON,I_LAY) * ABSB(IND0,IG) + &
164           & P_FAC10(IPLON,I_LAY) * ABSB(IND0+1,IG) + &
165           & P_FAC01(IPLON,I_LAY) * ABSB(IND1,IG) + &
166           & P_FAC11(IPLON,I_LAY) * ABSB(IND1+1,IG)) + &
167           & P_COLO3(IPLON,I_LAY) * ABSO3BC(IG) 
168          !     &          + TAURAY
169          !    SSA(LAY,IG) = TAURAY/TAUG(LAY,IG)
170          P_TAUR(IPLON,I_LAY,IG) = Z_TAURAY
171        ENDDO
172      ENDIF
173    ENDIF
174  ENDDO
175ENDDO
176
177!-----------------------------------------------------------------------
178IF (LHOOK) CALL DR_HOOK('SRTM_TAUMOL24',1,ZHOOK_HANDLE)
179
180END SUBROUTINE SRTM_TAUMOL24
Note: See TracBrowser for help on using the repository browser.