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

Last change on this file since 1704 was 1397, checked in by milmd, 10 years ago

In LMDZ.GENERIC replacement of all phystd .h files by module files.

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