!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
***S/P GASOPTL - OPTICAL DEPTHS CALCULATION
*
#include "phy_macros_f.h"
subroutine gasoptlgh (taug, gwgh, dp, ib, ig, 1,12
1 o3, qq, inpt, mcont, dir,
2 dip, dt, lev1, gh,
3 il1, il2, ilg, lay, tg)
*
#include "impnone.cdk"
*
integer ilg, lay, ib, ig, mcont, lev1, il1, il2, ng, lc
integer ng2, ng3, k, i
real taug(ilg,lay), gwgh
*
real dp(ilg,lay), o3(ilg,lay), qq(ilg,lay), dir(ilg,lay),
1 dip(ilg,lay), dt(ilg,lay), tg(ilg,lay)
integer inpt(ilg,lay)
logical gh
*
integer initaug
*
*Authors
* J. Li, M. Lazare, CCCMA, rt code for gcm4
* (Ref: J. Li, H. W. Barker, 2005:
* JAS Vol. 62, no. 2, pp. 286\226309)
* P. Vaillancourt, D. Talbot, RPN/CMC;
* adapted for CMC/RPN physics (May 2006)
*
*Revisions
* 001 M.Lazarre,K.Winger,P.Vaillancourt (Apr 08) - use integer variables instead of actual integers
*
*Object
*
* The same as gasoptl but for intervals close to 1 in the
* accumulated probability space
* 1 = h2o
* 2 = o3
* 3 = co2
* 4 = ch4
* 5 = n2o
* 6 = o2
* 7 = cfc11
* 8 = cfc12
* tline, etc., deal with line absorption and tcontl and tconthl
* deal with water vapor continuum
*
*Arguments
*
* taug gaseous optical depth
* dp air mass path for a model layer (explained in raddriv).
* o3 o3 mass mixing ratio
* qq water vapor mass mixing ratio
* dip interpolation factor for pressure between two
* neighboring standard input data pressure levels
* dt layer temperature - 250 k
* inpt number of the level for the standard input data pressures
*----------------------------------------------------------------------
*
**
*
#include "bandlh.cdk"
C
C * initaug is a switch used in tline1y (as "iplus") which
C * initializes taug to zero if its value is two. this is what
C * we require throughout this routine.
C
data initaug /2/
c
if (ib .eq. 1) then
c
c----------------------------------------------------------------------
c band (2500 - 2200 cm^-1), nongray gaseous absorption of co2.
c----------------------------------------------------------------------
c
ng = 3
call tline1 (taug, cl1co2gh(1,1,ig), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, ntl, initaug,
2 il1, il2, ilg, lay, tg)
c
gwgh = gwl1gh(ig)
c
else if (ib .eq. 2) then
c
c----------------------------------------------------------------------
c band (2200 - 1900 cm^-1), nongray gaseous absorption of h2o
c----------------------------------------------------------------------
c
ng = 1
call tline1 (taug, cl2h2ogh, qq, ng, dp, dip,
1 dt, inpt, lev1, gh, ntl, initaug,
2 il1, il2, ilg, lay, tg)
c
lc = 3
call tcontl (taug, cl2csgh, cl2cfgh, qq, dp, dip, dt,
1 lc, inpt, mcont, gh, il1, il2, ilg, lay)
c
gwgh = gwl2gh(ig)
c
else if (ib .eq. 3) then
c
c----------------------------------------------------------------------
c band (1900 - 1400 cm^-1), nongray gaseous absorption of h2o.
c----------------------------------------------------------------------
c
ng = 1
call tline1 (taug, cl3h2ogh(1,1,ig), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, ntl, initaug,
2 il1, il2, ilg, lay, tg)
c
if (ig .eq. 1) then
lc = 4
call tcontl (taug, cl3csgh, cl3cfgh, qq, dp, dip, dt,
1 lc, inpt, mcont, gh, il1, il2, ilg, lay)
c
endif
c
gwgh = gwl3gh(ig)
c
else if (ib .eq. 4) then
c
c----------------------------------------------------------------------
c band3 (1100 - 1400 cm^-1), overlapping absorption of h2o, n2o,
c and ch4. direct mapping method for h2o and ch4 and n2o
c----------------------------------------------------------------------
c
ng2 = 4
ng3 = 5
call tline3 (taug,cl4h2ogh(1,1,ig),cl4ch4gh(1,1,ig),
1 cl4n2ogh(1,1,ig), qq, ng2, ng3, dp, dip, dt, inpt,
2 lev1, gh, ntl, il1, il2, ilg, lay)
c
gwgh = gwl4gh(ig)
c
else if (ib .eq. 5) then
c
c----------------------------------------------------------------------
c band5 (980 - 1100 cm^-1), overlapping absorption of h2o and o3
c direct mapping method
c----------------------------------------------------------------------
c
ng2 = 2
call tline2 (taug, cl5h2ogh(1,1,ig), cl5o3gh(1,1,ig), qq, o3,
1 ng2, dp, dip, dt, inpt,
2 lev1, gh, ntl, il1, il2, ilg, lay, tg)
c
if (ig .le. 2) then
lc = 4
call tcontl (taug, cl5csgh(1,1,ig), cl5cfgh(1,1,ig), qq, dp, dip,
1 dt, lc, inpt, mcont, gh, il1, il2, ilg, lay)
endif
c
gwgh = gwl5gh(ig)
c
c----------------------------------------------------------------------
c band (800 - 980 cm^-1), no gh
c----------------------------------------------------------------------
c
else if (ib .eq. 7) then
c
c----------------------------------------------------------------------
c band6 (540 - 800 cm^-1), overlapping absorption of h2o and co2
c direct mapping method. for ig > 4, the contribution by h2o is
c very small.
c----------------------------------------------------------------------
c
if (ig .le. 4) then
ng2 = 3
call tline2 (taug, cl7h2ogh(1,1,ig), cl7co2gh(1,1,ig), qq, o3,
1 ng2, dp, dip, dt, inpt,
2 lev1, gh, ntl, il1, il2, ilg, lay, tg)
c
c----------------------------------------------------------------------
c simply add the o3 effect
c----------------------------------------------------------------------
c
if (ig .le. 2) then
do 700 k = 1, lay
do 700 i = il1, il2
taug(i,k) = taug(i,k) + cl7o3gh(ig) * o3(i,k) * dp(i,k)
700 continue
endif
else
c
ng = 3
call tline1 (taug, cl7co2gh(1,1,ig), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, ntl, initaug,
2 il1, il2, ilg, lay, tg)
endif
c
gwgh = gwl7gh(ig)
c
else if (ib .eq. 8) then
c
c----------------------------------------------------------------------
c band (340 - 540 cm^-1), nongray gaseous absorption of h2o.
c----------------------------------------------------------------------
c
ng = 1
call tline1 (taug, cl8h2ogh(1,1,ig), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, ntl, initaug,
2 il1, il2, ilg, lay, tg)
c
gwgh = gwl8gh(ig)
c
else if (ib .eq. 9) then
c
c----------------------------------------------------------------------
c band (0 - 340 cm^-1), nongray gaseous absorption of h2o.
c----------------------------------------------------------------------
c
ng = 1
call tline1 (taug, cl9h2ogh(1,1,ig), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, ntl, initaug,
2 il1, il2, ilg, lay, tg)
c
gwgh = gwl9gh(ig)
c
endif
c
return
end