source: LMDZ6/trunk/libf/phylmd/ecrad/ifsrrtm/srtm_taumol17.F90 @ 4791

Last change on this file since 4791 was 4773, checked in by idelkadi, 9 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: 8.4 KB
Line 
1SUBROUTINE SRTM_TAUMOL17 &
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_COLCO2 , P_COLMOL,&
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 17:  3250-4000 cm-1 (low - H2O,CO2; high - H2O,CO2)
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 20010610 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 : NG17
25USE YOESRTA17, ONLY : ABSA, ABSB, FORREFC, SELFREFC, SFLUXREFC, RAYL, LAYREFFR, STRRAT 
26USE YOESRTWN , ONLY : NSPA, NSPB
27
28IMPLICIT NONE
29
30!-- Output
31INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA, KFDIA
32INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
33REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC00(KIDIA:KFDIA,KLEV)
34REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC01(KIDIA:KFDIA,KLEV)
35REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC10(KIDIA:KFDIA,KLEV)
36REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC11(KIDIA:KFDIA,KLEV)
37INTEGER(KIND=JPIM),INTENT(IN)    :: K_JP(KIDIA:KFDIA,KLEV)
38INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT(KIDIA:KFDIA,KLEV)
39INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT1(KIDIA:KFDIA,KLEV)
40REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ONEMINUS(KIDIA:KFDIA)
41REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLH2O(KIDIA:KFDIA,KLEV)
42REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLCO2(KIDIA:KFDIA,KLEV)
43REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLMOL(KIDIA:KFDIA,KLEV)
44INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYTROP(KIDIA:KFDIA)
45REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFAC(KIDIA:KFDIA,KLEV)
46REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFRAC(KIDIA:KFDIA,KLEV)
47INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDSELF(KIDIA:KFDIA,KLEV)
48REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FORFAC(KIDIA:KFDIA,KLEV)
49REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FORFRAC(KIDIA:KFDIA,KLEV)
50INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDFOR(KIDIA:KFDIA,KLEV)
51
52REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_SFLUXZEN(KIDIA:KFDIA,JPG)
53REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAUG(KIDIA:KFDIA,KLEV,JPG)
54REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAUR(KIDIA:KFDIA,KLEV,JPG)
55REAL(KIND=JPRB)   ,INTENT(IN)    :: PRMU0(KIDIA:KFDIA)
56!- from INTFAC     
57!- from INTIND
58!- from PRECISE             
59!- from PROFDATA             
60!- from SELF             
61INTEGER(KIND=JPIM) :: IG, IND0, IND1, INDS, INDF, JS, I_LAY, I_LAYSOLFR(KIDIA:KFDIA), I_NLAYERS, IPLON
62
63! REAL(KIND=JPRB) :: Z_FAC000, Z_FAC001, Z_FAC010, Z_FAC011, Z_FAC100, Z_FAC101,&
64!  & Z_FAC110, Z_FAC111
65REAL(KIND=JPRB) :: Z_FS, Z_SPECCOMB, Z_SPECMULT, Z_SPECPARM, Z_TAURAY 
66REAL(KIND=JPHOOK) :: ZHOOK_HANDLE
67
68IF (LHOOK) CALL DR_HOOK('SRTM_TAUMOL17',0,ZHOOK_HANDLE)
69
70I_NLAYERS = KLEV
71
72!     Compute the optical depth by interpolating in ln(pressure),
73!     temperature, and appropriate species.  Below LAYTROP, the water
74!     vapor self-continuum is interpolated (in temperature) separately. 
75
76DO I_LAY = 1, I_NLAYERS
77  DO IPLON = KIDIA, KFDIA
78    IF (PRMU0(IPLON) > 0.0_JPRB) THEN
79      IF (I_LAY <= K_LAYTROP(IPLON)) THEN
80        Z_SPECCOMB = P_COLH2O(IPLON,I_LAY) + STRRAT*P_COLCO2(IPLON,I_LAY)
81        Z_SPECPARM = P_COLH2O(IPLON,I_LAY)/Z_SPECCOMB
82        IF (Z_SPECPARM >= P_ONEMINUS(IPLON)) Z_SPECPARM = P_ONEMINUS(IPLON)
83        Z_SPECMULT = 8.*(Z_SPECPARM)
84        JS = 1 + INT(Z_SPECMULT)
85        Z_FS = MOD(Z_SPECMULT, 1.0_JPRB )
86        ! Z_FAC000 = (1. - Z_FS) * P_FAC00(I_LAY)
87        ! Z_FAC010 = (1. - Z_FS) * P_FAC10(I_LAY)
88        ! Z_FAC100 = Z_FS * P_FAC00(I_LAY)
89        ! Z_FAC110 = Z_FS * P_FAC10(I_LAY)
90        ! Z_FAC001 = (1. - Z_FS) * P_FAC01(I_LAY)
91        ! Z_FAC011 = (1. - Z_FS) * P_FAC11(I_LAY)
92        ! Z_FAC101 = Z_FS * P_FAC01(I_LAY)
93        ! Z_FAC111 = Z_FS * P_FAC11(I_LAY)
94        IND0 = ((K_JP(IPLON,I_LAY)-1)*5+(K_JT(IPLON,I_LAY)-1))*NSPA(17) + JS
95        IND1 = (K_JP(IPLON,I_LAY)*5+(K_JT1(IPLON,I_LAY)-1))*NSPA(17) + JS
96        INDS = K_INDSELF(IPLON,I_LAY)
97        INDF = K_INDFOR(IPLON,I_LAY)
98        Z_TAURAY = P_COLMOL(IPLON,I_LAY) * RAYL
99
100        !  DO IG = 1, NG(17)
101!CDIR UNROLL=NG17
102        DO IG = 1, NG17
103          P_TAUG(IPLON,I_LAY,IG) = Z_SPECCOMB * &
104           & (&
105           & (1. - Z_FS) * ( ABSA(IND0,IG) * P_FAC00(IPLON,I_LAY) + &
106           &                 ABSA(IND0+9,IG) * P_FAC10(IPLON,I_LAY) + &
107           &                 ABSA(IND1,IG) * P_FAC01(IPLON,I_LAY) + &
108           &                 ABSA(IND1+9,IG) * P_FAC11(IPLON,I_LAY) ) + &
109           & Z_FS        * ( ABSA(IND0+1,IG) * P_FAC00(IPLON,I_LAY) + &
110           &                 ABSA(IND0+10,IG) * P_FAC10(IPLON,I_LAY) + &
111           &                 ABSA(IND1+1,IG) * P_FAC01(IPLON,I_LAY) + &
112           &                 ABSA(IND1+10,IG) * P_FAC11(IPLON,I_LAY) ) &
113           & )  + &
114           & P_COLH2O(IPLON,I_LAY) * &
115           & (P_SELFFAC(IPLON,I_LAY) * (SELFREFC(INDS,IG) + &
116           & P_SELFFRAC(IPLON,I_LAY) * &
117           & (SELFREFC(INDS+1,IG) - SELFREFC(INDS,IG))) + &
118           & P_FORFAC(IPLON,I_LAY) * (FORREFC(INDF,IG) + &
119           & P_FORFRAC(IPLON,I_LAY) * &
120           & (FORREFC(INDF+1,IG) - FORREFC(INDF,IG))))   
121
122          !     &           + TAURAY
123          !    SSA(LAY,IG) = TAURAY/TAUG(LAY,IG)
124          P_TAUR(IPLON,I_LAY,IG) = Z_TAURAY
125        ENDDO
126      ENDIF
127    ENDIF
128  ENDDO
129ENDDO
130
131I_LAYSOLFR(:) = I_NLAYERS
132
133DO I_LAY = 1, I_NLAYERS
134  DO IPLON = KIDIA, KFDIA
135    IF (PRMU0(IPLON) > 0.0_JPRB) THEN
136      IF (I_LAY >= K_LAYTROP(IPLON)+1) THEN
137        IF (K_JP(IPLON,I_LAY-1) < LAYREFFR .AND. K_JP(IPLON,I_LAY) >= LAYREFFR) &
138         & I_LAYSOLFR(IPLON) = I_LAY 
139        Z_SPECCOMB = P_COLH2O(IPLON,I_LAY) + STRRAT*P_COLCO2(IPLON,I_LAY)
140        Z_SPECPARM = P_COLH2O(IPLON,I_LAY)/Z_SPECCOMB
141        IF (Z_SPECPARM >= P_ONEMINUS(IPLON)) Z_SPECPARM = P_ONEMINUS(IPLON)
142        Z_SPECMULT = 4.*(Z_SPECPARM)
143        JS = 1 + INT(Z_SPECMULT)
144        Z_FS = MOD(Z_SPECMULT, 1.0_JPRB )
145        ! Z_FAC000 = (1. - Z_FS) * P_FAC00(I_LAY)
146        ! Z_FAC010 = (1. - Z_FS) * P_FAC10(I_LAY)
147        ! Z_FAC100 = Z_FS * P_FAC00(I_LAY)
148        ! Z_FAC110 = Z_FS * P_FAC10(I_LAY)
149        ! Z_FAC001 = (1. - Z_FS) * P_FAC01(I_LAY)
150        ! Z_FAC011 = (1. - Z_FS) * P_FAC11(I_LAY)
151        ! Z_FAC101 = Z_FS * P_FAC01(I_LAY)
152        ! Z_FAC111 = Z_FS * P_FAC11(I_LAY)
153        IND0 = ((K_JP(IPLON,I_LAY)-13)*5+(K_JT(IPLON,I_LAY)-1))*NSPB(17) + JS
154        IND1 = ((K_JP(IPLON,I_LAY)-12)*5+(K_JT1(IPLON,I_LAY)-1))*NSPB(17) + JS
155        INDF = K_INDFOR(IPLON,I_LAY)
156        Z_TAURAY = P_COLMOL(IPLON,I_LAY) * RAYL
157
158        !  DO IG = 1, NG(17)
159!CDIR UNROLL=NG17
160        DO IG = 1, NG17
161          P_TAUG(IPLON,I_LAY,IG) = Z_SPECCOMB * &
162           !    & (Z_FAC000 * ABSB(IND0,IG) + &
163           !    & Z_FAC100 * ABSB(IND0+1,IG) + &
164           !    & Z_FAC010 * ABSB(IND0+5,IG) + &
165           !    & Z_FAC110 * ABSB(IND0+6,IG) + &
166           !    & Z_FAC001 * ABSB(IND1,IG) + &
167           !    & Z_FAC101 * ABSB(IND1+1,IG) + &
168           !    & Z_FAC011 * ABSB(IND1+5,IG) + &
169           !    & Z_FAC111 * ABSB(IND1+6,IG)) + &
170           & (&
171           & (1. - Z_FS) * ( ABSB(IND0,IG) * P_FAC00(IPLON,I_LAY) + &
172           &                 ABSB(IND0+5,IG) * P_FAC10(IPLON,I_LAY) + &
173           &                 ABSB(IND1,IG) * P_FAC01(IPLON,I_LAY) + &
174           &                 ABSB(IND1+5,IG) * P_FAC11(IPLON,I_LAY) ) + &
175           & Z_FS        * ( ABSB(IND0+1,IG) * P_FAC00(IPLON,I_LAY) + &
176           &                 ABSB(IND0+6,IG) * P_FAC10(IPLON,I_LAY) + &
177           &                 ABSB(IND1+1,IG) * P_FAC01(IPLON,I_LAY) + &
178           &                 ABSB(IND1+6,IG) * P_FAC11(IPLON,I_LAY) ) &
179           & ) + &
180           & P_COLH2O(IPLON,I_LAY) * &
181           & P_FORFAC(IPLON,I_LAY) * (FORREFC(INDF,IG) + &
182           & P_FORFRAC(IPLON,I_LAY) * &
183           & (FORREFC(INDF+1,IG) - FORREFC(INDF,IG)))   
184          !     &           + TAURAY
185          !    SSA(LAY,IG) = TAURAY/TAUG(LAY,IG)
186          IF (I_LAY == I_LAYSOLFR(IPLON)) P_SFLUXZEN(IPLON,IG) = SFLUXREFC(IG,JS) &
187           & + Z_FS * (SFLUXREFC(IG,JS+1) - SFLUXREFC(IG,JS)) 
188          P_TAUR(IPLON,I_LAY,IG) = Z_TAURAY
189        ENDDO
190      ENDIF
191    ENDIF
192  ENDDO
193ENDDO
194
195!-----------------------------------------------------------------------
196IF (LHOOK) CALL DR_HOOK('SRTM_TAUMOL17',1,ZHOOK_HANDLE)
197
198END SUBROUTINE SRTM_TAUMOL17
Note: See TracBrowser for help on using the repository browser.