source: trunk/LMDZ.GENERIC/libf/phystd/optci.F90 @ 848

Last change on this file since 848 was 716, checked in by rwordsworth, 12 years ago

Mainly updates to radiative transfer and gas management scheme.
Most CIA data now read from standard HITRAN datafiles. For the H2O
continuum, two options have been added: the standard CKD continuum,
and the empirical formula in PPC (Pierrehumbert 2010). Use the toggle
'H2Ocont_simple' in callphys.def to choose.

Note to Martians: I've changed the default values of 'sedimentation' and
'co2cond' in inifis to false. Both these are defined in the standard deftank
callphys.def file, so there shouldn't be any compatibility problems.

File size: 12.5 KB
Line 
1subroutine 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
379end subroutine optci
380
381
382
Note: See TracBrowser for help on using the repository browser.