1 | subroutine optci(PLEV,TLEV,DTAUI,TAUCUMI, & |
---|
2 | QXIAER,QSIAER,GIAER,COSBI,WBARI,TAUAERO, & |
---|
3 | TMID,PMID,TAUGSURF,QVAR,MUVAR) |
---|
4 | |
---|
5 | use radinc_h |
---|
6 | use radcommon_h, only: gasi,tlimit,wrefVAR,Cmk,tgasref,pfgasref,wnoi,scalep |
---|
7 | use gases_h |
---|
8 | implicit none |
---|
9 | |
---|
10 | !================================================================== |
---|
11 | ! |
---|
12 | ! Purpose |
---|
13 | ! ------- |
---|
14 | ! Calculates longwave optical constants at each level. For each |
---|
15 | ! layer and spectral interval in the IR it calculates WBAR, DTAU |
---|
16 | ! and COSBAR. For each level it calculates TAU. |
---|
17 | ! |
---|
18 | ! TAUI(L,LW) is the cumulative optical depth at level L (or alternatively |
---|
19 | ! at the *bottom* of layer L), LW is the spectral wavelength interval. |
---|
20 | ! |
---|
21 | ! TLEV(L) - Temperature at the layer boundary (i.e., level) |
---|
22 | ! PLEV(L) - Pressure at the layer boundary (i.e., level) |
---|
23 | ! |
---|
24 | ! Authors |
---|
25 | ! ------- |
---|
26 | ! Adapted from the NASA Ames code by R. Wordsworth (2009) |
---|
27 | ! |
---|
28 | !================================================================== |
---|
29 | |
---|
30 | #include "comcstfi.h" |
---|
31 | #include "callkeys.h" |
---|
32 | |
---|
33 | |
---|
34 | real*8 DTAUI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) |
---|
35 | real*8 DTAUKI(L_LEVELS+1,L_NSPECTI,L_NGAUSS) |
---|
36 | real*8 TAUI(L_NLEVRAD,L_NSPECTI,L_NGAUSS) |
---|
37 | real*8 TAUCUMI(L_LEVELS,L_NSPECTI,L_NGAUSS) |
---|
38 | real*8 PLEV(L_LEVELS) |
---|
39 | real*8 TLEV(L_LEVELS) |
---|
40 | real*8 TMID(L_LEVELS), PMID(L_LEVELS) |
---|
41 | real*8 COSBI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) |
---|
42 | real*8 WBARI(L_NLAYRAD,L_NSPECTI,L_NGAUSS) |
---|
43 | |
---|
44 | ! for aerosols |
---|
45 | real*8 QXIAER(L_LEVELS+1,L_NSPECTI,NAERKIND) |
---|
46 | real*8 QSIAER(L_LEVELS+1,L_NSPECTI,NAERKIND) |
---|
47 | real*8 GIAER(L_LEVELS+1,L_NSPECTI,NAERKIND) |
---|
48 | real*8 TAUAERO(L_LEVELS+1,NAERKIND) |
---|
49 | real*8 TAUAEROLK(L_LEVELS+1,L_NSPECTI,NAERKIND) |
---|
50 | real*8 TAEROS(L_LEVELS,L_NSPECTI,NAERKIND) |
---|
51 | |
---|
52 | integer L, NW, NG, K, LK, IAER |
---|
53 | integer MT(L_LEVELS), MP(L_LEVELS), NP(L_LEVELS) |
---|
54 | real*8 ANS, TAUGAS |
---|
55 | real*8 DPR(L_LEVELS), U(L_LEVELS) |
---|
56 | real*8 LCOEF(4), LKCOEF(L_LEVELS,4) |
---|
57 | |
---|
58 | real*8 taugsurf(L_NSPECTI,L_NGAUSS-1) |
---|
59 | real*8 DCONT |
---|
60 | double precision wn_cont, p_cont, p_air, T_cont, dtemp, dtempc |
---|
61 | double precision p_cross |
---|
62 | |
---|
63 | ! variable species mixing ratio variables |
---|
64 | real*8 QVAR(L_LEVELS), WRATIO(L_LEVELS), MUVAR(L_LEVELS) |
---|
65 | real*8 KCOEF(4) |
---|
66 | integer NVAR(L_LEVELS) |
---|
67 | |
---|
68 | ! temporary variables for multiple aerosol calculation |
---|
69 | real*8 atemp, btemp |
---|
70 | |
---|
71 | ! variables for k in units m^-1 |
---|
72 | real*8 rho, dz(L_LEVELS) |
---|
73 | |
---|
74 | integer igas, jgas |
---|
75 | |
---|
76 | !--- Kasting's CIA ---------------------------------------- |
---|
77 | !real*8, parameter :: Ci(L_NSPECTI)=[ & |
---|
78 | ! 3.8E-5, 1.2E-5, 2.8E-6, 7.6E-7, 4.5E-7, 2.3E-7, & |
---|
79 | ! 5.4E-7, 1.6E-6, 0.0, & |
---|
80 | ! 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & |
---|
81 | ! 0.0, 4.0E-7, 4.0E-6, 1.4E-5, & |
---|
82 | ! 1.0E-5, 1.2E-6, 2.0E-7, 5.0E-8, 3.0E-8, 0.0 ] |
---|
83 | !real*8, parameter :: Ti(L_NSPECTI)=[ -2.2, -1.9, & |
---|
84 | ! -1.7, -1.7, -1.7, -1.7, -1.7, -1.7, & |
---|
85 | ! 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & |
---|
86 | ! -1.7,-1.7,-1.7,-1.7,-1.7,-1.7,-1.7, -1.7,0.0 ] |
---|
87 | !---------------------------------------------------------- |
---|
88 | |
---|
89 | !======================================================================= |
---|
90 | ! Determine the total gas opacity throughout the column, for each |
---|
91 | ! spectral interval, NW, and each Gauss point, NG. |
---|
92 | |
---|
93 | taugsurf(:,:) = 0.0 |
---|
94 | dpr(:) = 0.0 |
---|
95 | lkcoef(:,:) = 0.0 |
---|
96 | |
---|
97 | do K=2,L_LEVELS |
---|
98 | DPR(k) = PLEV(K)-PLEV(K-1) |
---|
99 | |
---|
100 | !--- Kasting's CIA ---------------------------------------- |
---|
101 | !dz(k)=dpr(k)*189.02*TMID(K)/(0.03720*PMID(K)) |
---|
102 | ! this is CO2 path length (in cm) as written by Francois |
---|
103 | ! delta_z = delta_p * R_specific * T / (g * P) |
---|
104 | ! But Kasting states that W is in units of _atmosphere_ cm |
---|
105 | ! So we do |
---|
106 | !dz(k)=dz(k)*(PMID(K)/1013.25) |
---|
107 | !dz(k)=dz(k)/100.0 ! in m for SI calc |
---|
108 | !---------------------------------------------------------- |
---|
109 | |
---|
110 | ! if we have continuum opacities, we need dz |
---|
111 | if(kastprof)then |
---|
112 | dz(k) = dpr(k)*(1000.0*8.3145/muvar(k))*TMID(K)/(g*PMID(K)) |
---|
113 | U(k) = (Cmk*mugaz/(muvar(k)))*DPR(k) |
---|
114 | else |
---|
115 | dz(k) = dpr(k)*R*TMID(K)/(g*PMID(K)) |
---|
116 | U(k) = Cmk*DPR(k) ! only Cmk line in optci.F |
---|
117 | endif |
---|
118 | |
---|
119 | call tpindex(PMID(K),TMID(K),QVAR(K),pfgasref,tgasref,WREFVAR, & |
---|
120 | LCOEF,MT(K),MP(K),NVAR(K),WRATIO(K)) |
---|
121 | |
---|
122 | do LK=1,4 |
---|
123 | LKCOEF(K,LK) = LCOEF(LK) |
---|
124 | end do |
---|
125 | |
---|
126 | |
---|
127 | DO NW=1,L_NSPECTI |
---|
128 | do iaer=1,naerkind |
---|
129 | TAEROS(K,NW,IAER) = TAUAERO(K,IAER) * QXIAER(K,NW,IAER) |
---|
130 | end do |
---|
131 | END DO |
---|
132 | end do ! levels |
---|
133 | |
---|
134 | do K=2,L_LEVELS |
---|
135 | do nw=1,L_NSPECTI |
---|
136 | |
---|
137 | DCONT = 0.0 ! continuum absorption |
---|
138 | |
---|
139 | if(Continuum.and.(.not.graybody))then |
---|
140 | ! include continua if necessary |
---|
141 | wn_cont = dble(wnoi(nw)) |
---|
142 | T_cont = dble(TMID(k)) |
---|
143 | do igas=1,ngasmx |
---|
144 | |
---|
145 | if(gfrac(igas).eq.-1)then ! variable |
---|
146 | p_cont = dble(PMID(k)*scalep*QVAR(k)) ! qvar = mol/mol |
---|
147 | else |
---|
148 | p_cont = dble(PMID(k)*scalep*gfrac(igas)*(1.-QVAR(k))) |
---|
149 | endif |
---|
150 | |
---|
151 | dtemp=0.0 |
---|
152 | if(igas.eq.igas_N2)then |
---|
153 | |
---|
154 | call interpolateN2N2(wn_cont,T_cont,p_cont,dtemp,.false.) |
---|
155 | |
---|
156 | elseif(igas.eq.igas_H2)then |
---|
157 | |
---|
158 | ! first do self-induced absorption |
---|
159 | call interpolateH2H2(wn_cont,T_cont,p_cont,dtemp,.false.) |
---|
160 | |
---|
161 | ! then cross-interactions with other gases |
---|
162 | do jgas=1,ngasmx |
---|
163 | p_cross = dble(PMID(k)*scalep*gfrac(jgas)*(1.-QVAR(k))) |
---|
164 | dtempc = 0.0 |
---|
165 | if(jgas.eq.igas_N2)then |
---|
166 | call interpolateN2H2(wn_cont,T_cont,p_cross,p_cont,dtempc,.false.) |
---|
167 | elseif(jgas.eq.igas_He)then |
---|
168 | call interpolateH2He(wn_cont,T_cont,p_cross,p_cont,dtempc,.false.) |
---|
169 | endif |
---|
170 | dtemp = dtemp + dtempc |
---|
171 | enddo |
---|
172 | |
---|
173 | elseif(igas.eq.igas_H2O.and.T_cont.gt.200.0)then |
---|
174 | |
---|
175 | p_air = dble(PMID(k)*scalep) - p_cont ! note assumes background is air! |
---|
176 | if(H2Ocont_simple)then |
---|
177 | call interpolateH2Ocont_PPC(wn_cont,T_cont,p_cont,p_air,dtemp,.false.) |
---|
178 | else |
---|
179 | call interpolateH2Ocont_CKD(wn_cont,T_cont,p_cont,p_air,dtemp,.false.) |
---|
180 | endif |
---|
181 | |
---|
182 | endif |
---|
183 | |
---|
184 | DCONT = DCONT + dtemp |
---|
185 | |
---|
186 | enddo |
---|
187 | |
---|
188 | ! Oobleck test |
---|
189 | !rho = PMID(k)*scalep / (TMID(k)*286.99) |
---|
190 | !if(WNOI(nw).gt.300.0 .and. WNOI(nw).lt.500.0)then |
---|
191 | ! DCONT = rho * 0.125 * 4.6e-4 |
---|
192 | !elseif(WNOI(nw).gt.500.0 .and. WNOI(nw).lt.700.0)then |
---|
193 | ! DCONT = 1000*dpr(k) * 1.0 * 4.6e-4 / g |
---|
194 | ! DCONT = rho * 1.0 * 4.6e-4 |
---|
195 | !elseif(WNOI(nw).gt.700.0 .and. WNOI(nw).lt.900.0)then |
---|
196 | ! DCONT = rho * 0.125 * 4.6e-4 |
---|
197 | !endif |
---|
198 | |
---|
199 | DCONT = DCONT*dz(k) |
---|
200 | |
---|
201 | endif |
---|
202 | |
---|
203 | ! RW 7/3/12: already done above |
---|
204 | !if(.not.Continuum)then |
---|
205 | ! DCONT=0.0 |
---|
206 | !endif |
---|
207 | |
---|
208 | !--- Kasting's CIA ---------------------------------------- |
---|
209 | !DCO2 = dz(k)*Ci(nw)*(1.2859*PMID(k)/1000.0)*(TMID(k)/300.)**Ti(nw) |
---|
210 | !DCO2 = 130*Ci(nw)*(pmid(k)/1013.25)**2*(tmid(k)/300.)**Ti(nw) * dz(k) |
---|
211 | ! these two have been verified to give the same results |
---|
212 | !---------------------------------------------------------- |
---|
213 | |
---|
214 | do ng=1,L_NGAUSS-1 |
---|
215 | |
---|
216 | ! Now compute TAUGAS |
---|
217 | |
---|
218 | ! Interpolate between water mixing ratios |
---|
219 | ! WRATIO = 0.0 if the requested water amount is equal to, or outside the |
---|
220 | ! the water data range |
---|
221 | |
---|
222 | if(L_REFVAR.eq.1)then ! added by RW for special no variable case |
---|
223 | KCOEF(1) = GASI(MT(K),MP(K),1,NW,NG) |
---|
224 | KCOEF(2) = GASI(MT(K),MP(K)+1,1,NW,NG) |
---|
225 | KCOEF(3) = GASI(MT(K)+1,MP(K)+1,1,NW,NG) |
---|
226 | KCOEF(4) = GASI(MT(K)+1,MP(K),1,NW,NG) |
---|
227 | else |
---|
228 | |
---|
229 | KCOEF(1) = GASI(MT(K),MP(K),NVAR(K),NW,NG) + WRATIO(K)* & |
---|
230 | (GASI(MT(K),MP(K),NVAR(K)+1,NW,NG) - & |
---|
231 | GASI(MT(K),MP(K),NVAR(K),NW,NG)) |
---|
232 | |
---|
233 | KCOEF(2) = GASI(MT(K),MP(K)+1,NVAR(K),NW,NG) + WRATIO(K)* & |
---|
234 | (GASI(MT(K),MP(K)+1,NVAR(K)+1,NW,NG) - & |
---|
235 | GASI(MT(K),MP(K)+1,NVAR(K),NW,NG)) |
---|
236 | |
---|
237 | KCOEF(3) = GASI(MT(K)+1,MP(K)+1,NVAR(K),NW,NG) + WRATIO(K)* & |
---|
238 | (GASI(MT(K)+1,MP(K)+1,NVAR(K)+1,NW,NG) - & |
---|
239 | GASI(MT(K)+1,MP(K)+1,NVAR(K),NW,NG)) |
---|
240 | |
---|
241 | KCOEF(4) = GASI(MT(K)+1,MP(K),NVAR(K),NW,NG) + WRATIO(K)* & |
---|
242 | (GASI(MT(K)+1,MP(K),NVAR(K)+1,NW,NG) - & |
---|
243 | GASI(MT(K)+1,MP(K),NVAR(K),NW,NG)) |
---|
244 | endif |
---|
245 | |
---|
246 | ! Interpolate the gaseous k-coefficients to the requested T,P values |
---|
247 | |
---|
248 | ANS = LKCOEF(K,1)*KCOEF(1) + LKCOEF(K,2)*KCOEF(2) + & |
---|
249 | LKCOEF(K,3)*KCOEF(3) + LKCOEF(K,4)*KCOEF(4) |
---|
250 | |
---|
251 | TAUGAS = U(k)*ANS |
---|
252 | |
---|
253 | TAUGSURF(NW,NG) = TAUGSURF(NW,NG) + TAUGAS + DCONT |
---|
254 | DTAUKI(K,nw,ng) = TAUGAS + DCONT ! For parameterized continuum absorption |
---|
255 | |
---|
256 | do iaer=1,naerkind |
---|
257 | DTAUKI(K,nw,ng) = DTAUKI(K,nw,ng) + TAEROS(K,NW,IAER) |
---|
258 | end do ! a bug was here! |
---|
259 | |
---|
260 | end do |
---|
261 | |
---|
262 | ! Now fill in the "clear" part of the spectrum (NG = L_NGAUSS), |
---|
263 | ! which holds continuum opacity only |
---|
264 | |
---|
265 | NG = L_NGAUSS |
---|
266 | DTAUKI(K,nw,ng) = 0.0 + DCONT ! For parameterized continuum absorption |
---|
267 | |
---|
268 | do iaer=1,naerkind |
---|
269 | DTAUKI(K,nw,ng) = DTAUKI(K,nw,ng) + TAEROS(K,NW,IAER) |
---|
270 | end do ! a bug was here! |
---|
271 | |
---|
272 | end do |
---|
273 | end do |
---|
274 | |
---|
275 | |
---|
276 | !======================================================================= |
---|
277 | ! Now the full treatment for the layers, where besides the opacity |
---|
278 | ! we need to calculate the scattering albedo and asymmetry factors |
---|
279 | |
---|
280 | DO NW=1,L_NSPECTI |
---|
281 | DO K=2,L_LEVELS+1 |
---|
282 | do iaer=1,naerkind |
---|
283 | TAUAEROLK(K,NW,IAER) = TAUAERO(K,IAER)*QSIAER(K,NW,IAER) |
---|
284 | end do |
---|
285 | ENDDO |
---|
286 | ENDDO |
---|
287 | |
---|
288 | DO NW=1,L_NSPECTI |
---|
289 | NG = L_NGAUSS |
---|
290 | DO L=1,L_NLAYRAD |
---|
291 | |
---|
292 | K = 2*L+1 |
---|
293 | DTAUI(L,nw,ng) = DTAUKI(K,NW,NG) + DTAUKI(K+1,NW,NG)! + 1.e-50 |
---|
294 | |
---|
295 | atemp = 0. |
---|
296 | btemp = 0. |
---|
297 | if(DTAUI(L,NW,NG) .GT. 1.0E-9) then |
---|
298 | do iaer=1,naerkind |
---|
299 | atemp = atemp + & |
---|
300 | GIAER(K,NW,IAER) * TAUAEROLK(K,NW,IAER) + & |
---|
301 | GIAER(K+1,NW,IAER) * TAUAEROLK(K+1,NW,IAER) |
---|
302 | btemp = btemp + TAUAEROLK(K,NW,IAER) + TAUAEROLK(K+1,NW,IAER) |
---|
303 | ! * + 1.e-10 |
---|
304 | end do |
---|
305 | WBARI(L,nw,ng) = btemp / DTAUI(L,NW,NG) |
---|
306 | else |
---|
307 | WBARI(L,nw,ng) = 0.0D0 |
---|
308 | DTAUI(L,NW,NG) = 1.0E-9 |
---|
309 | endif |
---|
310 | |
---|
311 | if(btemp .GT. 0.0) then |
---|
312 | cosbi(L,NW,NG) = atemp/btemp |
---|
313 | else |
---|
314 | cosbi(L,NW,NG) = 0.0D0 |
---|
315 | end if |
---|
316 | |
---|
317 | END DO ! L vertical loop |
---|
318 | |
---|
319 | ! Now the other Gauss points, if needed. |
---|
320 | |
---|
321 | DO NG=1,L_NGAUSS-1 |
---|
322 | IF(TAUGSURF(NW,NG) .gt. TLIMIT) THEN |
---|
323 | |
---|
324 | DO L=1,L_NLAYRAD |
---|
325 | K = 2*L+1 |
---|
326 | DTAUI(L,nw,ng) = DTAUKI(K,NW,NG)+DTAUKI(K+1,NW,NG)! + 1.e-50 |
---|
327 | |
---|
328 | btemp = 0. |
---|
329 | if(DTAUI(L,NW,NG) .GT. 1.0E-9) then |
---|
330 | |
---|
331 | do iaer=1,naerkind |
---|
332 | btemp = btemp + TAUAEROLK(K,NW,IAER) + TAUAEROLK(K+1,NW,IAER) |
---|
333 | end do |
---|
334 | WBARI(L,nw,ng) = btemp / DTAUI(L,NW,NG) |
---|
335 | |
---|
336 | else |
---|
337 | WBARI(L,nw,ng) = 0.0D0 |
---|
338 | DTAUI(L,NW,NG) = 1.0E-9 |
---|
339 | endif |
---|
340 | |
---|
341 | cosbi(L,NW,NG) = cosbi(L,NW,L_NGAUSS) |
---|
342 | END DO ! L vertical loop |
---|
343 | END IF |
---|
344 | |
---|
345 | END DO ! NG Gauss loop |
---|
346 | END DO ! NW spectral loop |
---|
347 | |
---|
348 | ! Total extinction optical depths |
---|
349 | |
---|
350 | DO NW=1,L_NSPECTI |
---|
351 | DO NG=1,L_NGAUSS ! full gauss loop |
---|
352 | TAUI(1,NW,NG)=0.0D0 |
---|
353 | DO L=1,L_NLAYRAD |
---|
354 | TAUI(L+1,NW,NG)=TAUI(L,NW,NG)+DTAUI(L,NW,NG) |
---|
355 | END DO |
---|
356 | |
---|
357 | TAUCUMI(1,NW,NG)=0.0D0 |
---|
358 | DO K=2,L_LEVELS |
---|
359 | TAUCUMI(K,NW,NG)=TAUCUMI(K-1,NW,NG)+DTAUKI(K,NW,NG) |
---|
360 | END DO |
---|
361 | END DO ! end full gauss loop |
---|
362 | END DO |
---|
363 | |
---|
364 | ! be aware when comparing with textbook results |
---|
365 | ! (e.g. Pierrehumbert p. 218) that |
---|
366 | ! taucumi does not take the <cos theta>=0.5 factor into |
---|
367 | ! account. It is the optical depth for a vertically |
---|
368 | ! ascending ray with angle theta = 0. |
---|
369 | |
---|
370 | !open(127,file='taucum.out') |
---|
371 | !do nw=1,L_NSPECTI |
---|
372 | ! write(127,*) taucumi(L_LEVELS,nw,L_NGAUSS) |
---|
373 | !enddo |
---|
374 | !close(127) |
---|
375 | |
---|
376 | return |
---|
377 | |
---|
378 | |
---|
379 | end subroutine optci |
---|
380 | |
---|
381 | |
---|
382 | |
---|