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

Last change on this file since 4791 was 4773, checked in by idelkadi, 11 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: 16.7 KB
RevLine 
[4773]1!----------------------------------------------------------------------------
2SUBROUTINE RRTM_TAUMOL3 (KIDIA,KFDIA,KLEV,P_TAU,&
3 & P_TAUAERL,P_FAC00,P_FAC01,P_FAC10,P_FAC11,P_FORFAC,P_FORFRAC,K_INDFOR,K_JP,K_JT,K_JT1,P_ONEMINUS,&
4 & P_COLH2O,P_COLCO2,P_COLN2O,P_COLDRY,K_LAYTROP,P_SELFFAC,P_SELFFRAC,K_INDSELF,PFRAC, &
5 & PRAT_H2OCO2, PRAT_H2OCO2_1,PMINORFRAC,KINDMINOR) 
6
7!     BAND 3:  500-630 cm-1 (low - H2O,CO2; high - H2O,CO2)
8
9!     AUTHOR.
10!     -------
11!      JJMorcrette, ECMWF
12
13!     MODIFICATIONS.
14!     --------------
15!      M.Hamrud      01-Oct-2003 CY28 Cleaning
16!      NEC           25-Oct-2007 Optimisations
17!      JJMorcrette 20110613 flexible number of g-points
18!      ABozzo 20130517 updated to rrtmg_lw_v4.85:
19!     band 3:  500-630 cm-1 (low key - h2o,co2; low minor - n2o)
20!                           (high key - h2o,co2; high minor - n2o)
21! ---------------------------------------------------------------------------
22
23USE PARKIND1  ,ONLY : JPIM     ,JPRB
24USE YOMHOOK   ,ONLY : LHOOK, DR_HOOK, JPHOOK
25
26USE PARRRTM  , ONLY : JPBAND
27USE YOERRTM  , ONLY : JPGPT  ,NG3   ,NGS2
28USE YOERRTWN , ONLY : NSPA   ,NSPB
29USE YOERRTA3 , ONLY : ABSA   ,ABSB   ,FRACREFA, FRACREFB,&
30 & FORREF   ,SELFREF , KA_MN2O ,  KB_MN2O
31USE YOERRTRF, ONLY : CHI_MLS
32
33IMPLICIT NONE
34
35INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA
36INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA
37INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
38REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_TAU(KIDIA:KFDIA,JPGPT,KLEV)
39REAL(KIND=JPRB)   ,INTENT(IN)    :: P_TAUAERL(KIDIA:KFDIA,KLEV,JPBAND)
40REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC00(KIDIA:KFDIA,KLEV)
41REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC01(KIDIA:KFDIA,KLEV)
42REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC10(KIDIA:KFDIA,KLEV)
43REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FAC11(KIDIA:KFDIA,KLEV)
44REAL(KIND=JPRB)   ,INTENT(IN)    :: P_FORFAC(KIDIA:KFDIA,KLEV)
45INTEGER(KIND=JPIM),INTENT(IN)    :: K_JP(KIDIA:KFDIA,KLEV)
46INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT(KIDIA:KFDIA,KLEV)
47INTEGER(KIND=JPIM),INTENT(IN)    :: K_JT1(KIDIA:KFDIA,KLEV)
48REAL(KIND=JPRB)   ,INTENT(IN)    :: P_ONEMINUS
49REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLH2O(KIDIA:KFDIA,KLEV)
50REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLCO2(KIDIA:KFDIA,KLEV)
51REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLN2O(KIDIA:KFDIA,KLEV)
52REAL(KIND=JPRB)   ,INTENT(IN)    :: P_COLDRY(KIDIA:KFDIA,KLEV)
53INTEGER(KIND=JPIM),INTENT(IN)    :: K_LAYTROP(KIDIA:KFDIA)
54REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFAC(KIDIA:KFDIA,KLEV)
55REAL(KIND=JPRB)   ,INTENT(IN)    :: P_SELFFRAC(KIDIA:KFDIA,KLEV)
56INTEGER(KIND=JPIM),INTENT(IN)    :: K_INDSELF(KIDIA:KFDIA,KLEV)
57REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFRAC(KIDIA:KFDIA,JPGPT,KLEV)
58
59REAL(KIND=JPRB)   ,INTENT(IN)   :: PRAT_H2OCO2(KIDIA:KFDIA,KLEV)
60REAL(KIND=JPRB)   ,INTENT(IN)   :: PRAT_H2OCO2_1(KIDIA:KFDIA,KLEV)
61INTEGER(KIND=JPIM),INTENT(IN)   :: K_INDFOR(KIDIA:KFDIA,KLEV)
62REAL(KIND=JPRB)   ,INTENT(IN)   :: P_FORFRAC(KIDIA:KFDIA,KLEV)
63REAL(KIND=JPRB)   ,INTENT(IN)   :: PMINORFRAC(KIDIA:KFDIA,KLEV)
64INTEGER(KIND=JPIM),INTENT(IN)   :: KINDMINOR(KIDIA:KFDIA,KLEV)
65! ---------------------------------------------------------------------------
66
67REAL(KIND=JPRB) :: Z_SPECCOMB(KLEV),Z_SPECCOMB1(KLEV),Z_SPECCOMB_MN2O(KLEV), &
68& Z_SPECCOMB_PLANCK(KLEV)
69REAL(KIND=JPRB) :: ZREFRAT_PLANCK_A, ZREFRAT_PLANCK_B, ZREFRAT_M_A, ZREFRAT_M_B
70
71INTEGER(KIND=JPIM) :: IND0(KLEV),IND1(KLEV),INDS(KLEV),INDF(KLEV),INDM(KLEV)
72INTEGER(KIND=JPIM) :: IG, JS, JLAY, JS1,JMN2O,JPL
73INTEGER(KIND=JPIM) :: JLON
74
75REAL(KIND=JPRB) :: Z_FS, Z_SPECMULT, Z_SPECPARM,  &
76 & Z_FS1, Z_SPECMULT1, Z_SPECPARM1,   &
77 & Z_FMN2O, Z_FMN2OMF, Z_SPECMULT_MN2O, Z_SPECPARM_MN2O,   &
78 & Z_FPL, Z_SPECMULT_PLANCK, Z_SPECPARM_PLANCK
79
80REAL(KIND=JPRB) :: ZADJFAC,ZADJCOLN2O(KIDIA:KFDIA,KLEV),ZRATN2O,Z_CHI_N2O
81
82 REAL(KIND=JPRB) ::  Z_FAC000, Z_FAC100, Z_FAC200,&
83 & Z_FAC010, Z_FAC110, Z_FAC210, &
84 & Z_FAC001, Z_FAC101, Z_FAC201, &
85 & Z_FAC011, Z_FAC111, Z_FAC211
86REAL(KIND=JPRB) :: ZP, ZP4, ZFK0, ZFK1, ZFK2
87REAL(KIND=JPRB) :: ZTAUFOR,ZTAUSELF,ZN2OM1,ZN2OM2,ZABSN2O,ZTAU_MAJOR,ZTAU_MAJOR1
88
89REAL(KIND=JPHOOK) :: ZHOOK_HANDLE
90
91IF (LHOOK) CALL DR_HOOK('RRTM_TAUMOL3',0,ZHOOK_HANDLE)
92
93!     Compute the optical depth by interpolating in ln(pressure),
94!     temperature, and appropriate species.  Below LAYTROP, the water
95!     vapor self-continuum is interpolated (in temperature) separately. 
96
97
98! Minor gas mapping levels:
99!     lower - n2o, p = 706.272 mbar, t = 278.94 k
100!     upper - n2o, p = 95.58 mbar, t = 215.7 k
101
102!  P = 212.725 mb
103      ZREFRAT_PLANCK_A = CHI_MLS(1,9)/CHI_MLS(2,9)
104
105!  P = 95.58 mb
106      ZREFRAT_PLANCK_B = CHI_MLS(1,13)/CHI_MLS(2,13)
107
108!  P = 706.270mb
109      ZREFRAT_M_A = CHI_MLS(1,3)/CHI_MLS(2,3)
110
111!  P = 95.58 mb
112      ZREFRAT_M_B = CHI_MLS(1,13)/CHI_MLS(2,13)
113ASSOCIATE(NFLEVG=>KLEV)
114
115
116DO JLAY = 1, KLEV
117  DO JLON = KIDIA, KFDIA
118    IF (JLAY <= K_LAYTROP(JLON)) THEN
119      Z_SPECCOMB(JLAY) = P_COLH2O(JLON,JLAY) + PRAT_H2OCO2(JLON,JLAY)*P_COLCO2(JLON,JLAY)
120      Z_SPECPARM = P_COLH2O(JLON,JLAY)/Z_SPECCOMB(JLAY)
121      Z_SPECPARM=MIN(P_ONEMINUS,Z_SPECPARM)
122      Z_SPECMULT = 8._JPRB*(Z_SPECPARM)
123      JS = 1 + INT(Z_SPECMULT)
124      Z_FS = MOD(Z_SPECMULT,1.0_JPRB)
125
126
127        Z_SPECCOMB1(JLAY) = P_COLH2O(JLON,JLAY) + PRAT_H2OCO2_1(JLON,JLAY)*P_COLCO2(JLON,JLAY)
128        Z_SPECPARM1 = P_COLH2O(JLON,JLAY)/Z_SPECCOMB1(JLAY)
129        IF (Z_SPECPARM1 >= P_ONEMINUS) Z_SPECPARM1 = P_ONEMINUS
130        Z_SPECMULT1 = 8._JPRB*(Z_SPECPARM1)
131        JS1 = 1 + INT(Z_SPECMULT1)
132        Z_FS1 = MOD(Z_SPECMULT1,1.0_JPRB)
133
134        Z_SPECCOMB_MN2O(JLAY) = P_COLH2O(JLON,JLAY) + ZREFRAT_M_A*P_COLCO2(JLON,JLAY)
135        Z_SPECPARM_MN2O = P_COLH2O(JLON,JLAY)/Z_SPECCOMB_MN2O(JLAY)
136        IF (Z_SPECPARM_MN2O >= P_ONEMINUS) Z_SPECPARM_MN2O = P_ONEMINUS
137        Z_SPECMULT_MN2O = 8._JPRB*Z_SPECPARM_MN2O
138        JMN2O = 1 + INT(Z_SPECMULT_MN2O)
139        Z_FMN2O = MOD(Z_SPECMULT_MN2O,1.0_JPRB)
140        Z_FMN2OMF = PMINORFRAC(JLON,JLAY)*Z_FMN2O
141!  In atmospheres where the amount of N2O is too great to be considered
142!  a minor species, adjust the column amount of N2O by an empirical factor
143!  to obtain the proper contribution.
144        Z_CHI_N2O = P_COLN2O(JLON,JLAY)/P_COLDRY(JLON,JLAY)
145        ZRATN2O = 1.E20_JPRB*Z_CHI_N2O/CHI_MLS(4,K_JP(JLON,JLAY)+1)
146        IF (ZRATN2O > 1.5_JPRB) THEN
147           ZADJFAC = 0.5_JPRB+(ZRATN2O-0.5_JPRB)**0.65_JPRB
148           ZADJCOLN2O(JLON,JLAY) = ZADJFAC*CHI_MLS(4,K_JP(JLON,JLAY)+1)*P_COLDRY(JLON,JLAY)*1.E-20_JPRB
149        ELSE
150           ZADJCOLN2O(JLON,JLAY) = P_COLN2O(JLON,JLAY)
151        ENDIF
152       
153        Z_SPECCOMB_PLANCK(JLAY) = P_COLH2O(JLON,JLAY)+ZREFRAT_PLANCK_A*P_COLCO2(JLON,JLAY)
154        Z_SPECPARM_PLANCK = P_COLH2O(JLON,JLAY)/Z_SPECCOMB_PLANCK(JLAY)
155        IF (Z_SPECPARM_PLANCK >= P_ONEMINUS) Z_SPECPARM_PLANCK=P_ONEMINUS
156        Z_SPECMULT_PLANCK = 8._JPRB*Z_SPECPARM_PLANCK
157        JPL= 1 + INT(Z_SPECMULT_PLANCK)
158        Z_FPL = MOD(Z_SPECMULT_PLANCK,1.0_JPRB)
159
160
161
162      IND0(JLAY) = ((K_JP(JLON,JLAY)-1)*5+(K_JT(JLON,JLAY)-1))*NSPA(3) + JS
163      IND1(JLAY) = (K_JP(JLON,JLAY)*5+(K_JT1(JLON,JLAY)-1))*NSPA(3) + JS1
164      INDS(JLAY) = K_INDSELF(JLON,JLAY)
165      INDF(JLAY) = K_INDFOR(JLON,JLAY)
166      INDM(JLAY) = KINDMINOR(JLON,JLAY)
167
168
169
170         IF (Z_SPECPARM < 0.125_JPRB) THEN
171            ZP = Z_FS - 1
172            ZP4 = ZP**4
173            ZFK0 = ZP4
174            ZFK1 = 1 - ZP - 2.0_JPRB*ZP4
175            ZFK2 = ZP + ZP4
176            Z_FAC000 = ZFK0*P_FAC00(JLON,JLAY)
177            Z_FAC100 = ZFK1*P_FAC00(JLON,JLAY)
178            Z_FAC200 = ZFK2*P_FAC00(JLON,JLAY)
179            Z_FAC010 = ZFK0*P_FAC10(JLON,JLAY)
180            Z_FAC110 = ZFK1*P_FAC10(JLON,JLAY)
181            Z_FAC210 = ZFK2*P_FAC10(JLON,JLAY)
182         ELSEIF (Z_SPECPARM > 0.875_JPRB) THEN
183            ZP = -Z_FS
184            ZP4 = ZP**4
185            ZFK0 = ZP4
186            ZFK1 = 1 - ZP - 2.0_JPRB*ZP4
187            ZFK2 = ZP + ZP4
188            Z_FAC000 = ZFK0*P_FAC00(JLON,JLAY)
189            Z_FAC100 = ZFK1*P_FAC00(JLON,JLAY)
190            Z_FAC200 = ZFK2*P_FAC00(JLON,JLAY)
191            Z_FAC010 = ZFK0*P_FAC10(JLON,JLAY)
192            Z_FAC110 = ZFK1*P_FAC10(JLON,JLAY)
193            Z_FAC210 = ZFK2*P_FAC10(JLON,JLAY)
194         ELSE
195            Z_FAC000 = (1._JPRB - Z_FS) * P_FAC00(JLON,JLAY)
196            Z_FAC010 = (1._JPRB - Z_FS) * P_FAC10(JLON,JLAY)
197            Z_FAC100 = Z_FS * P_FAC00(JLON,JLAY)
198            Z_FAC110 = Z_FS * P_FAC10(JLON,JLAY)
199         ENDIF
200         IF (Z_SPECPARM1 < 0.125_JPRB) THEN
201            ZP = Z_FS1 - 1
202            ZP4 = ZP**4
203            ZFK0 = ZP4
204            ZFK1 = 1 - ZP - 2.0_JPRB*ZP4
205            ZFK2 = ZP + ZP4
206            Z_FAC001 = ZFK0*P_FAC01(JLON,JLAY)
207            Z_FAC101 = ZFK1*P_FAC01(JLON,JLAY)
208            Z_FAC201 = ZFK2*P_FAC01(JLON,JLAY)
209            Z_FAC011 = ZFK0*P_FAC11(JLON,JLAY)
210            Z_FAC111 = ZFK1*P_FAC11(JLON,JLAY)
211            Z_FAC211 = ZFK2*P_FAC11(JLON,JLAY)
212         ELSEIF (Z_SPECPARM1 > 0.875_JPRB) THEN
213            ZP = -Z_FS1
214            ZP4 = ZP**4
215            ZFK0 = ZP4
216            ZFK1 = 1 - ZP - 2.0_JPRB*ZP4
217            ZFK2 = ZP + ZP4
218            Z_FAC001 = ZFK0*P_FAC01(JLON,JLAY)
219            Z_FAC101 = ZFK1*P_FAC01(JLON,JLAY)
220            Z_FAC201 = ZFK2*P_FAC01(JLON,JLAY)
221            Z_FAC011 = ZFK0*P_FAC11(JLON,JLAY)
222            Z_FAC111 = ZFK1*P_FAC11(JLON,JLAY)
223            Z_FAC211 = ZFK2*P_FAC11(JLON,JLAY)
224         ELSE
225            Z_FAC001 = (1._JPRB - Z_FS1) * P_FAC01(JLON,JLAY)
226            Z_FAC011 = (1._JPRB - Z_FS1) * P_FAC11(JLON,JLAY)
227            Z_FAC101 = Z_FS1 * P_FAC01(JLON,JLAY)
228            Z_FAC111 = Z_FS1 * P_FAC11(JLON,JLAY)
229         ENDIF
230
231
232
233
234
235!-- DS_000515
236!CDIR UNROLL=NG3
237      DO IG = 1, NG3
238!-- DS_000515
239         ZTAUSELF = P_SELFFAC(JLON,JLAY)* (SELFREF(INDS(JLAY),IG) + P_SELFFRAC(JLON,JLAY) * &
240            &    (SELFREF(INDS(JLAY)+1,IG) - SELFREF(INDS(JLAY),IG)))
241         ZTAUFOR = P_FORFAC(JLON,JLAY) * (FORREF(INDF(JLAY),IG) + P_FORFRAC(JLON,JLAY) * &
242            &    (FORREF(INDF(JLAY)+1,IG) - FORREF(INDF(JLAY),IG)))
243         ZN2OM1 = KA_MN2O(JMN2O,INDM(JLAY),IG) + Z_FMN2O * &
244            &    (KA_MN2O(JMN2O+1,INDM(JLAY),IG) - KA_MN2O(JMN2O,INDM(JLAY),IG))
245         ZN2OM2 = KA_MN2O(JMN2O,INDM(JLAY)+1,IG) + Z_FMN2O * &
246            &    (KA_MN2O(JMN2O+1,INDM(JLAY)+1,IG) - KA_MN2O(JMN2O,INDM(JLAY)+1,IG))
247         ZABSN2O = ZN2OM1 + PMINORFRAC(JLON,JLAY) * (ZN2OM2 - ZN2OM1)
248
249            IF (Z_SPECPARM < 0.125_JPRB) THEN
250               ZTAU_MAJOR = Z_SPECCOMB(JLAY) * &
251                 &  (Z_FAC000 * ABSA(IND0(JLAY),IG) + &
252                 &  Z_FAC100 * ABSA(IND0(JLAY)+1,IG) + &
253                 &  Z_FAC200 * ABSA(IND0(JLAY)+2,IG) + &
254                 &  Z_FAC010 * ABSA(IND0(JLAY)+9,IG) + &
255                 &  Z_FAC110 * ABSA(IND0(JLAY)+10,IG) + &
256                 &  Z_FAC210 * ABSA(IND0(JLAY)+11,IG))
257            ELSEIF (Z_SPECPARM > 0.875_JPRB) THEN
258               ZTAU_MAJOR = Z_SPECCOMB(JLAY) * &
259                 &  (Z_FAC200 * ABSA(IND0(JLAY)-1,IG) + &
260                 &  Z_FAC100 * ABSA(IND0(JLAY),IG) + &
261                 &  Z_FAC000 * ABSA(IND0(JLAY)+1,IG) + &
262                 &  Z_FAC210 * ABSA(IND0(JLAY)+8,IG) + &
263                 &  Z_FAC110 * ABSA(IND0(JLAY)+9,IG) + &
264                 &  Z_FAC010 * ABSA(IND0(JLAY)+10,IG))
265            ELSE
266               ZTAU_MAJOR = Z_SPECCOMB(JLAY) * &
267                 &  (Z_FAC000 * ABSA(IND0(JLAY),IG) + &
268                 &  Z_FAC100 * ABSA(IND0(JLAY)+1,IG) + &
269                 &  Z_FAC010 * ABSA(IND0(JLAY)+9,IG) + &
270                 &  Z_FAC110 * ABSA(IND0(JLAY)+10,IG))
271            ENDIF
272
273            IF (Z_SPECPARM1 < 0.125_JPRB) THEN
274               ZTAU_MAJOR1 = Z_SPECCOMB1(JLAY) * &
275                 &  (Z_FAC001 * ABSA(IND1(JLAY),IG) + &
276                 &  Z_FAC101 * ABSA(IND1(JLAY)+1,IG) + &
277                 &  Z_FAC201 * ABSA(IND1(JLAY)+2,IG) + &
278                 &  Z_FAC011 * ABSA(IND1(JLAY)+9,IG) + &
279                 &  Z_FAC111 * ABSA(IND1(JLAY)+10,IG) + &
280                 &  Z_FAC211 * ABSA(IND1(JLAY)+11,IG))
281            ELSEIF (Z_SPECPARM1 > 0.875_JPRB) THEN
282               ZTAU_MAJOR1 = Z_SPECCOMB1(JLAY) * &
283                 &  (Z_FAC201 * ABSA(IND1(JLAY)-1,IG) + &
284                 &  Z_FAC101 * ABSA(IND1(JLAY),IG) + &
285                 &  Z_FAC001 * ABSA(IND1(JLAY)+1,IG) + &
286                 &  Z_FAC211 * ABSA(IND1(JLAY)+8,IG) + &
287                 &  Z_FAC111 * ABSA(IND1(JLAY)+9,IG) + &
288                 &  Z_FAC011 * ABSA(IND1(JLAY)+10,IG))
289            ELSE
290               ZTAU_MAJOR1 = Z_SPECCOMB1(JLAY) * &
291                 &  (Z_FAC001 * ABSA(IND1(JLAY),IG) +  &
292                 &  Z_FAC101 * ABSA(IND1(JLAY)+1,IG) + &
293                 &  Z_FAC011 * ABSA(IND1(JLAY)+9,IG) + &
294                 &  Z_FAC111 * ABSA(IND1(JLAY)+10,IG))
295            ENDIF
296 
297
298        P_TAU(JLON,NGS2+IG,JLAY) = ZTAU_MAJOR + ZTAU_MAJOR1 &
299               & + ZTAUSELF + ZTAUFOR &
300               & + ZADJCOLN2O(JLON,JLAY)*ZABSN2O &
301               & + P_TAUAERL(JLON,JLAY,3) 
302
303        !if (JPL < 1) call abort
304
305        PFRAC(JLON,NGS2+IG,JLAY) = FRACREFA(IG,JPL) + Z_FPL *&
306         & (FRACREFA(IG,JPL+1) - FRACREFA(IG,JPL)) 
307      ENDDO
308    ENDIF
309
310    IF (JLAY > K_LAYTROP(JLON)) THEN
311      Z_SPECCOMB(JLAY) = P_COLH2O(JLON,JLAY) + PRAT_H2OCO2(JLON,JLAY)*P_COLCO2(JLON,JLAY)
312      Z_SPECPARM = P_COLH2O(JLON,JLAY)/Z_SPECCOMB(JLAY)
313      Z_SPECPARM=MIN(P_ONEMINUS,Z_SPECPARM)
314      Z_SPECMULT = 4._JPRB*(Z_SPECPARM)
315      JS = 1 + INT(Z_SPECMULT)
316      Z_FS = MOD(Z_SPECMULT,1.0_JPRB)
317
318      Z_SPECCOMB1(JLAY) = P_COLH2O(JLON,JLAY) + PRAT_H2OCO2_1(JLON,JLAY)*P_COLCO2(JLON,JLAY)
319      Z_SPECPARM1 = P_COLH2O(JLON,JLAY)/Z_SPECCOMB1(JLAY)
320      IF (Z_SPECPARM1 >= P_ONEMINUS) Z_SPECPARM1 = P_ONEMINUS
321      Z_SPECMULT1 = 4._JPRB*(Z_SPECPARM1)
322      JS1 = 1 + INT(Z_SPECMULT1)
323      Z_FS1 = MOD(Z_SPECMULT1,1.0_JPRB)
324
325      Z_FAC000 = (1._JPRB - Z_FS) * P_FAC00(JLON,JLAY)
326      Z_FAC010 = (1._JPRB - Z_FS) * P_FAC10(JLON,JLAY)
327      Z_FAC100 = Z_FS * P_FAC00(JLON,JLAY)
328      Z_FAC110 = Z_FS * P_FAC10(JLON,JLAY)
329      Z_FAC001 = (1._JPRB - Z_FS1) * P_FAC01(JLON,JLAY)
330      Z_FAC011 = (1._JPRB - Z_FS1) * P_FAC11(JLON,JLAY)
331      Z_FAC101 = Z_FS1 * P_FAC01(JLON,JLAY)
332      Z_FAC111 = Z_FS1 * P_FAC11(JLON,JLAY)
333
334
335        Z_SPECCOMB_MN2O(JLAY) = P_COLH2O(JLON,JLAY) + ZREFRAT_M_B*P_COLCO2(JLON,JLAY)
336        Z_SPECPARM_MN2O = P_COLH2O(JLON,JLAY)/Z_SPECCOMB_MN2O(JLAY)
337        IF (Z_SPECPARM_MN2O >= P_ONEMINUS) Z_SPECPARM_MN2O = P_ONEMINUS
338        Z_SPECMULT_MN2O = 4._JPRB*Z_SPECPARM_MN2O
339        JMN2O = 1 + INT(Z_SPECMULT_MN2O)
340        Z_FMN2O = MOD(Z_SPECMULT_MN2O,1.0_JPRB)
341        Z_FMN2OMF = PMINORFRAC(JLON,JLAY)*Z_FMN2O
342!  In atmospheres where the amount of N2O is too great to be considered
343!  a minor species, adjust the column amount of N2O by an empirical factor
344!  to obtain the proper contribution.
345        Z_CHI_N2O = P_COLN2O(JLON,JLAY)/P_COLDRY(JLON,JLAY)
346        ZRATN2O = 1.E20_JPRB*Z_CHI_N2O/CHI_MLS(4,K_JP(JLON,JLAY)+1)
347        IF (ZRATN2O > 1.5_JPRB) THEN
348           ZADJFAC = 0.5_JPRB+(ZRATN2O-0.5_JPRB)**0.65_JPRB
349           ZADJCOLN2O(JLON,JLAY) = ZADJFAC*CHI_MLS(4,K_JP(JLON,JLAY)+1)*P_COLDRY(JLON,JLAY)*1.E-20_JPRB
350        ELSE
351           ZADJCOLN2O(JLON,JLAY) = P_COLN2O(JLON,JLAY)
352        ENDIF
353       
354        Z_SPECCOMB_PLANCK(JLAY) = P_COLH2O(JLON,JLAY)+ZREFRAT_PLANCK_B*P_COLCO2(JLON,JLAY)
355        Z_SPECPARM_PLANCK = P_COLH2O(JLON,JLAY)/Z_SPECCOMB_PLANCK(JLAY)
356        IF (Z_SPECPARM_PLANCK >= P_ONEMINUS) Z_SPECPARM_PLANCK=P_ONEMINUS
357        Z_SPECMULT_PLANCK = 4._JPRB*Z_SPECPARM_PLANCK
358        JPL= 1 + INT(Z_SPECMULT_PLANCK)
359        Z_FPL = MOD(Z_SPECMULT_PLANCK,1.0_JPRB)
360
361       IND0(JLAY) = ((K_JP(JLON,JLAY)-13)*5+(K_JT(JLON,JLAY)-1))*NSPB(3) + JS
362       IND1(JLAY) = ((K_JP(JLON,JLAY)-12)*5+(K_JT1(JLON,JLAY)-1))*NSPB(3) + JS1
363       INDF(JLAY) = K_INDFOR(JLON,JLAY)
364       INDM(JLAY) = KINDMINOR(JLON,JLAY)
365
366
367!CDIR UNROLL=NG3
368      DO IG = 1, NG3
369         ZTAUFOR = P_FORFAC(JLON,JLAY) * (FORREF(INDF(JLAY),IG) + P_FORFRAC(JLON,JLAY) * &
370               & (FORREF(INDF(JLAY)+1,IG) - FORREF(INDF(JLAY),IG)))
371         ZN2OM1 = KB_MN2O(JMN2O,INDM(JLAY),IG) + Z_FMN2O * &
372               & (KB_MN2O(JMN2O+1,INDM(JLAY),IG) - KB_MN2O(JMN2O,INDM(JLAY),IG))
373         ZN2OM2 = KB_MN2O(JMN2O,INDM(JLAY)+1,IG) + Z_FMN2O * &
374               & (KB_MN2O(JMN2O+1,INDM(JLAY)+1,IG) - KB_MN2O(JMN2O,INDM(JLAY)+1,IG))
375         ZABSN2O = ZN2OM1 + PMINORFRAC(JLON,JLAY) * (ZN2OM2 - ZN2OM1)
376
377
378        P_TAU(JLON,NGS2+IG,JLAY) = Z_SPECCOMB(JLAY) *   &
379          &(Z_FAC000 * ABSB(IND0(JLAY)  ,IG) +&
380          & Z_FAC100 * ABSB(IND0(JLAY)+1,IG) +&
381          & Z_FAC010 * ABSB(IND0(JLAY)+5,IG) +&
382          & Z_FAC110 * ABSB(IND0(JLAY)+6,IG)) +&
383          & Z_SPECCOMB1(JLAY) * &
384          & (Z_FAC001 * ABSB(IND1(JLAY)  ,IG) +&
385          & Z_FAC101 * ABSB(IND1(JLAY)+1,IG) +&
386          & Z_FAC011 * ABSB(IND1(JLAY)+5,IG) +&
387          & Z_FAC111 * ABSB(IND1(JLAY)+6,IG))+&
388          & ZTAUFOR + ZADJCOLN2O(JLON,JLAY)*ZABSN2O &
389          & + P_TAUAERL(JLON,JLAY,3) 
390
391
392        PFRAC(JLON,NGS2+IG,JLAY) = FRACREFB(IG,JPL) + Z_FPL *&
393         & (FRACREFB(IG,JPL+1) - FRACREFB(IG,JPL)) 
394      ENDDO
395    ENDIF
396  ENDDO
397ENDDO
398
399IF (LHOOK) CALL DR_HOOK('RRTM_TAUMOL3',1,ZHOOK_HANDLE)
400
401END ASSOCIATE
402END SUBROUTINE RRTM_TAUMOL3
Note: See TracBrowser for help on using the repository browser.