source: LMDZ5/branches/testing/libf/phymar/rrtm_taumol3.F90 @ 3990

Last change on this file since 3990 was 2160, checked in by Laurent Fairhead, 10 years ago

Merged trunk changes -r2070:2158 into testing branch. Compilation problems introduced by revision r2155 have been corrected by hand
File size: 7.0 KB
Line 
1!----------------------------------------------------------------------------
2SUBROUTINE RRTM_TAUMOL3 (KLEV,TAU,&
3  &TAUAERL,FAC00,FAC01,FAC10,FAC11,FORFAC,JP,JT,JT1,ONEMINUS,&
4  &COLH2O,COLCO2,COLN2O,LAYTROP,SELFFAC,SELFFRAC,INDSELF,PFRAC)
5
6!     BAND 3:  500-630 cm-1 (low - H2O,CO2; high - H2O,CO2)
7
8! Modifications
9!
10!     D Salmond 2000-05-15 speed-up
11
12
13#include "tsmbkind.h"
14
15USE PARRRTM  , ONLY : JPLAY  ,JPBAND ,JPGPT  ,JPXSEC  , NGS2
16USE YOERRTWN , ONLY : NG     ,NSPA   ,NSPB
17USE YOERRTA3 , ONLY : NG3    ,ABSA   ,ABSB   ,FRACREFA, FRACREFB,&
18            &FORREF   ,KA     ,KB     ,SELFREF , ABSN2OA ,&
19            &ABSN2OB  ,ETAREF ,H2OREF ,N2OREF  , CO2REF  ,&
20            &STRRAT
21
22!  Input
23!#include "yoeratm.h"
24
25!      REAL TAUAER(JPLAY)
26
27IMPLICIT NONE
28
29!  Output
30REAL_B :: TAU   (JPGPT,JPLAY)
31
32!     DUMMY INTEGER SCALARS
33INTEGER_M :: KLEV
34
35!- from AER
36REAL_B :: TAUAERL(JPLAY,JPBAND)
37
38!- from INTFAC     
39REAL_B :: FAC00(JPLAY)
40REAL_B :: FAC01(JPLAY)
41REAL_B :: FAC10(JPLAY)
42REAL_B :: FAC11(JPLAY)
43REAL_B :: FORFAC(JPLAY)
44
45!- from INTIND
46INTEGER_M :: JP(JPLAY)
47INTEGER_M :: JT(JPLAY)
48INTEGER_M :: JT1(JPLAY)
49
50!- from PRECISE             
51REAL_B :: ONEMINUS
52
53!- from PROFDATA             
54REAL_B :: COLH2O(JPLAY)
55REAL_B :: COLCO2(JPLAY)
56REAL_B :: COLN2O(JPLAY)
57INTEGER_M :: LAYTROP
58
59!- from SELF             
60REAL_B :: SELFFAC(JPLAY)
61REAL_B :: SELFFRAC(JPLAY)
62INTEGER_M :: INDSELF(JPLAY)
63
64!- from SP             
65REAL_B :: PFRAC(JPGPT,JPLAY)
66
67INTEGER_M :: IJS(JPLAY)
68REAL_B :: ZFS(JPLAY),SPECCOMB(JPLAY)
69INTEGER_M :: IND0(JPLAY),IND1(JPLAY),INDS(JPLAY)
70REAL_B :: N2OMULT(JPLAY)
71
72!     LOCAL INTEGER SCALARS
73INTEGER_M :: IG, JS, LAY, NS
74
75!     LOCAL REAL SCALARS
76REAL_B :: COLREF1, COLREF2, CURRN2O, FAC000, FAC001,&
77          &FAC010, FAC011, FAC100, FAC101, FAC110, FAC111, &
78          &FP, FS, RATIO, SPECMULT, SPECPARM, WCOMB1, &
79          &WCOMB2
80
81!      EQUIVALENCE (TAUAERL(1,3),TAUAER)
82
83!     Compute the optical depth by interpolating in ln(pressure),
84!     temperature, and appropriate species.  Below LAYTROP, the water
85!     vapor self-continuum is interpolated (in temperature) separately. 
86
87DO LAY = 1, LAYTROP
88  SPECCOMB(LAY) = COLH2O(LAY) + STRRAT*COLCO2(LAY)
89  SPECPARM = COLH2O(LAY)/SPECCOMB(LAY)
90  SPECPARM=MIN(ONEMINUS,SPECPARM)
91  SPECMULT = 8._JPRB*(SPECPARM)
92  JS = 1 + INT(SPECMULT)
93  FS = MOD(SPECMULT,_ONE_)
94  IF (JS  ==  8) THEN
95    IF (FS  >=  0.9_JPRB) THEN
96      JS = 9
97      FS = 10._JPRB * (FS - 0.9_JPRB)
98    ELSE
99      FS = FS/0.9_JPRB
100    ENDIF
101  ENDIF
102
103  NS = JS + INT(FS + _HALF_)
104  FP = FAC01(LAY) + FAC11(LAY)
105  IND0(LAY) = ((JP(LAY)-1)*5+(JT(LAY)-1))*NSPA(3) + JS
106  IND1(LAY) = (JP(LAY)*5+(JT1(LAY)-1))*NSPA(3) + JS
107  INDS(LAY) = INDSELF(LAY)
108  COLREF1 = N2OREF(JP(LAY))
109  COLREF2 = N2OREF(JP(LAY)+1)
110  IF (NS  ==  10) THEN
111    WCOMB1 = _ONE_/H2OREF(JP(LAY))
112    WCOMB2 = _ONE_/H2OREF(JP(LAY)+1)
113  ELSE
114    WCOMB1 = (_ONE_-ETAREF(NS))/(STRRAT * CO2REF(JP(LAY)))
115    WCOMB2 = (_ONE_-ETAREF(NS))/(STRRAT * CO2REF(JP(LAY)+1))
116  ENDIF
117  RATIO = (COLREF1*WCOMB1)+FP*((COLREF2*WCOMB2)-(COLREF1*WCOMB1))
118  CURRN2O = SPECCOMB(LAY) * RATIO
119  N2OMULT(LAY) = COLN2O(LAY) - CURRN2O
120
121  ZFS(LAY)=FS
122  IJS(LAY)=JS
123
124ENDDO
125
126!-- DS_000515
127DO IG = 1, NG3
128  DO LAY = 1, LAYTROP
129!-- DS_000515
130
131    FS=ZFS(LAY)
132    JS=IJS(LAY)
133
134!---jjm
135!    FAC000 = (_ONE_ - FS) * FAC00(LAY)
136!    FAC010 = (_ONE_ - FS) * FAC10(LAY)
137!    FAC100 = FS * FAC00(LAY)
138!    FAC110 = FS * FAC10(LAY)
139!    FAC001 = (_ONE_ - FS) * FAC01(LAY)
140!    FAC011 = (_ONE_ - FS) * FAC11(LAY)
141!    FAC101 = FS * FAC01(LAY)
142!    FAC111 = FS * FAC11(LAY)
143!------       
144
145    TAU (NGS2+IG,LAY) = SPECCOMB(LAY) *   &
146!-- DS_000515
147     & ( (1. - FS) *(FAC00(LAY) * ABSA(IND0(LAY)   ,IG) +   &
148     &               FAC10(LAY) * ABSA(IND0(LAY)+10,IG) +   &
149     &               FAC01(LAY) * ABSA(IND1(LAY)   ,IG) +   &
150     &               FAC11(LAY) * ABSA(IND1(LAY)+10,IG))+   &
151     &      FS     *(FAC00(LAY) * ABSA(IND0(LAY)+ 1,IG) +   &
152     &               FAC10(LAY) * ABSA(IND0(LAY)+11,IG) +   &
153     &               FAC01(LAY) * ABSA(IND1(LAY)+ 1,IG) +   &
154     &               FAC11(LAY) * ABSA(IND1(LAY)+11,IG))) + &
155!     &(FAC000 * ABSA(IND0(LAY)   ,IG) +&
156!     & FAC100 * ABSA(IND0(LAY)+ 1,IG) +&
157!     & FAC010 * ABSA(IND0(LAY)+10,IG) +&
158!     & FAC110 * ABSA(IND0(LAY)+11,IG) +&
159!     & FAC001 * ABSA(IND1(LAY),   IG) +&
160!     & FAC101 * ABSA(IND1(LAY)+ 1,IG) +&
161!     & FAC011 * ABSA(IND1(LAY)+10,IG) +&
162!     & FAC111 * ABSA(IND1(LAY)+11,IG))+&
163!-- DS_000515
164     &COLH2O(LAY) * &
165     &SELFFAC(LAY) * (SELFREF(INDS(LAY),IG) + &
166     &SELFFRAC(LAY) *&
167     &(SELFREF(INDS(LAY)+1,IG) - SELFREF(INDS(LAY),IG))&
168     &+ FORFAC(LAY) * FORREF(IG) ) &
169     &+ N2OMULT(LAY) * ABSN2OA(IG) &
170     &+ TAUAERL(LAY,3)
171    PFRAC(NGS2+IG,LAY) = FRACREFA(IG,JS) + FS *&
172     &(FRACREFA(IG,JS+1) - FRACREFA(IG,JS))
173  ENDDO
174ENDDO
175
176DO LAY = LAYTROP+1, KLEV
177  SPECCOMB(LAY) = COLH2O(LAY) + STRRAT*COLCO2(LAY)
178  SPECPARM = COLH2O(LAY)/SPECCOMB(LAY)
179  SPECPARM=MIN(ONEMINUS,SPECPARM)
180  SPECMULT = 4._JPRB*(SPECPARM)
181  JS = 1 + INT(SPECMULT)
182  FS = MOD(SPECMULT,_ONE_)
183  NS = JS + INT(FS + _HALF_)
184  FP = FAC01(LAY) + FAC11(LAY)
185  IND0(LAY) = ((JP(LAY)-13)*5+(JT(LAY)-1))*NSPB(3) + JS
186  IND1(LAY) = ((JP(LAY)-12)*5+(JT1(LAY)-1))*NSPB(3) + JS
187  COLREF1 = N2OREF(JP(LAY))
188  COLREF2 = N2OREF(JP(LAY)+1)
189  IF (NS  ==  5) THEN
190    WCOMB1 = _ONE_/H2OREF(JP(LAY))
191    WCOMB2 = _ONE_/H2OREF(JP(LAY)+1)
192  ELSE
193    WCOMB1 = (_ONE_-ETAREF(NS))/(STRRAT * CO2REF(JP(LAY)))
194    WCOMB2 = (_ONE_-ETAREF(NS))/(STRRAT * CO2REF(JP(LAY)+1))
195  ENDIF
196  RATIO = (COLREF1*WCOMB1)+FP*((COLREF2*WCOMB2)-(COLREF1*WCOMB1))
197  CURRN2O = SPECCOMB(LAY) * RATIO
198  N2OMULT(LAY) = COLN2O(LAY) - CURRN2O
199
200  ZFS(LAY)=FS
201  IJS(LAY)=JS
202
203ENDDO
204
205DO LAY = LAYTROP+1, KLEV
206
207  FS=ZFS(LAY)
208  JS=IJS(LAY)
209!---jjm
210!  FAC000 = (_ONE_ - FS) * FAC00(LAY)
211!  FAC010 = (_ONE_ - FS) * FAC10(LAY)
212!  FAC100 = FS * FAC00(LAY)
213!  FAC110 = FS * FAC10(LAY)
214!  FAC001 = (_ONE_ - FS) * FAC01(LAY)
215!  FAC011 = (_ONE_ - FS) * FAC11(LAY)
216!  FAC101 = FS * FAC01(LAY)
217!  FAC111 = FS * FAC11(LAY)
218!---       
219
220  DO IG = 1, NG3
221    TAU (NGS2+IG,LAY) = SPECCOMB(LAY) *   &
222!-- DS_000515
223     & ( (1. - FS) *(FAC00(LAY) * ABSB(IND0(LAY)  ,IG) +   &
224     &               FAC10(LAY) * ABSB(IND0(LAY)+5,IG) +   &
225     &               FAC01(LAY) * ABSB(IND1(LAY)  ,IG) +   &
226     &               FAC11(LAY) * ABSB(IND1(LAY)+5,IG))+   &
227     &      FS     *(FAC00(LAY) * ABSB(IND0(LAY)+1,IG) +   &
228     &               FAC10(LAY) * ABSB(IND0(LAY)+6,IG) +   &
229     &               FAC01(LAY) * ABSB(IND1(LAY)+1,IG) +   &
230     &               FAC11(LAY) * ABSB(IND1(LAY)+6,IG)))   &
231!     &(FAC000 * ABSB(IND0(LAY)  ,IG) +&
232!     & FAC100 * ABSB(IND0(LAY)+1,IG) +&
233!     & FAC010 * ABSB(IND0(LAY)+5,IG) +&
234!     & FAC110 * ABSB(IND0(LAY)+6,IG) +&
235!     & FAC001 * ABSB(IND1(LAY)  ,IG) +&
236!     & FAC101 * ABSB(IND1(LAY)+1,IG) +&
237!     & FAC011 * ABSB(IND1(LAY)+5,IG) +&
238!     & FAC111 * ABSB(IND1(LAY)+6,IG))&
239!-- DS_000515
240     &+ COLH2O(LAY)*FORFAC(LAY)*FORREF(IG) &
241     &+ N2OMULT(LAY) * ABSN2OB(IG)&
242     &+ TAUAERL(LAY,3)
243    PFRAC(NGS2+IG,LAY) = FRACREFB(IG,JS) + FS *&
244     &(FRACREFB(IG,JS+1) - FRACREFB(IG,JS))
245  ENDDO
246ENDDO
247
248RETURN
249END SUBROUTINE RRTM_TAUMOL3
Note: See TracBrowser for help on using the repository browser.