!-------------------------------------- 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 gasoptl (taug, gw, dp, ib, ig, 1,19
1 o3, qq, inptr, inpt, mcont,
2 dir, dip, dt, lev1, gh,
3 il1, il2, ilg, lay, tg)
*
#include "impnone.cdk"
*
integer ilg, lay, ib, ig, mcont, lev1, il1, il2, ng2
integer k, i, ng, lc, ng3
real taug(ilg,lay), gw, fact
*
real dp(ilg,lay), o3(ilg,lay), qq(ilg,lay), dir(ilg,lay),
1 dip(ilg,lay), dt(ilg,lay), tg(ilg,lay)
integer inptr(ilg,lay), inpt(ilg,lay)
logical gh
integer init1,init2
*
*
*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. Lazare (May 2005) new version for gcm15e: pass integer
* variables "init" and "mtl" instead of actual integer values,
* to "tline_" routines.
* 002 J.Li (June 2006) update the minor gas absorption
* 003 K.Winger,P.Vaillancourt (Apr 08) - integer mtl from bandl.cdk
*
*Object
* Calculation of the optical depths due to nongray gaseous
* absorption for the infrared, in each layer for a given band ib
* and cumulative probability gw.
* From band1 to band4, the solar and infrared interaction is
* considered. the total solar energy considered in the infrared
* region is 11.9006 w / m^2
* for gases with constant mixing ratio:
* 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
* dir interpolation factor for mass ratio of h2o / co2
* between two neighboring standard input ratios
* dip interpolation factor for pressure between two
* neighboring standard input data pressure levels
* dt layer temperature - 250 k
* inpr number of the ratio level for the standard 5 ratios
* inpt number of the level for the standard input data pressures
* mcont the highest level for water vapor continuum calculation
*----------------------------------------------------------------------
*
*
#include "tracegases.cdk"
#include "bandl.cdk"
*
c number of vertical levels in absorber pressure-based coefficient
c array ("m" references non-saturated bands active below 1 mb only).
c
data init1,init2 /1,2/
c
if (ib .eq. 1) then
c
c----------------------------------------------------------------------
c band (2500 - 2200 cm^-1), nongray gaseous absorption of h2o and
c co2.
c----------------------------------------------------------------------
c
ng2 = 3
call tline2 (taug, cl1h2o, cl1co2, qq, o3,
1 ng2, dp, dip, dt, inpt,
2 lev1, gh, mtl, il1, il2, ilg, lay, tg)
c
c----------------------------------------------------------------------
c simply add the n2o effect
c----------------------------------------------------------------------
c
do 100 k = lev1, lay
do 100 i = il1, il2
fact = qq(i,k) / (qq(i,k) + 8.e+04 * rmn2o)
taug(i,k) = taug(i,k) + (754.9786 + 10141.5049 * fact * fact) *
1 rmn2o * dp(i,k)
100 continue
c
gw = gwl1(ig)
c
else if (ib .eq. 2) then
c
c----------------------------------------------------------------------
c band (2200 - 1900 cm^-1), nongray gaseous absorption of h2o + n2o
c----------------------------------------------------------------------
c
ng = 1
call tline1 (taug, cl2h2o, qq, ng, dp, dip,
1 dt, inpt, lev1, gh, mtl, init2,
2 il1, il2, ilg, lay, tg)
c
lc = 3
call tcontl (taug, cl2cs, cl2cf, qq, dp, dip, dt,
1 lc, inpt, mcont, gh, il1, il2, ilg, lay)
c
c----------------------------------------------------------------------
c simply add the n2o effect
c----------------------------------------------------------------------
c
do 200 k = lev1, lay
do 200 i = il1, il2
fact = qq(i,k) / (qq(i,k) + 72000. * rmn2o)
taug(i,k) = taug(i,k) + (93. + 3500. * fact * fact) * rmn2o *
1 dp(i,k)
200 continue
c
gw = gwl2(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, cl3h2o(1,1,ig), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, mtl, init2,
2 il1, il2, ilg, lay, tg)
c
lc = 4
call tcontl (taug, cl3cs(1,1,ig), cl3cf(1,1,ig), qq, dp, dip, dt,
1 lc, inpt, mcont, gh, il1, il2, ilg, lay)
c
gw = gwl3(ig)
c
else if (ib .eq. 4) then
c
c----------------------------------------------------------------------
c band3 (1100 - 1400 cm^-1), overlapping absorption of h2o, n2o,
c ch4 and cfc12. direct mapping method for h2o and ch4 and n2o
c cfc are considered as minor gases
c----------------------------------------------------------------------
c
ng2 = 4
ng3 = 5
call tline3 (taug, cl4h2o(1,1,ig), cl4ch4(1,1,ig),
1 cl4n2o(1,1,ig), qq, ng2, ng3, dp, dip, dt, inpt,
2 lev1, gh, mtl, il1, il2, ilg, lay)
c
lc = 4
call tcontl (taug, cl4cs(1,1,ig), cl4cf(1,1,ig), qq, dp, dip, dt,
1 lc, inpt, mcont, gh, il1, il2, ilg, lay)
c
c----------------------------------------------------------------------
c simply add the cfc effect
c----------------------------------------------------------------------
c
do 400 k = lev1, lay
do 400 i = il1, il2
taug(i,k) = taug(i,k) + (cl4f12(ig) * rmf12 + 629.0 * rmf113 +
1 751.5 * rmf114) * dp(i,k)
400 continue
c
gw = gwl4(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. co2 and cfc are simply added
c----------------------------------------------------------------------
c
ng2 = 2
call tline2 (taug, cl5h2o(1,1,ig), cl5o3(1,1,ig), qq, o3,
1 ng2, dp, dip, dt, inpt,
2 lev1, gh, mtl, il1, il2, ilg, lay, tg)
c
lc = 4
call tcontl (taug, cl5cs(1,1,ig), cl5cf(1,1,ig), qq, dp, dip, dt,
1 lc, inpt, mcont, gh, il1, il2, ilg, lay)
c
c----------------------------------------------------------------------
c simply add the co2 + cfc effect
c since the interaction of co2 and h2o, qq(i,k) appears in co2
c effect
c----------------------------------------------------------------------
c
do 500 k = lev1, lay
do 500 i = il1, il2
taug(i,k) = taug(i,k) + ((0.009 + 0.093 * qq(i,k) / (qq(i,k) +
1 2.1 * rmco2)) * rmco2 +
2 cl5f11(ig) * rmf11 + cl5f12(ig) * rmf12 +
3 1023.0 * rmf113 + 1539.0 * rmf114) * dp(i,k)
500 continue
c
gw = gwl5(ig)
c
else if (ib .eq. 6) then
c
c----------------------------------------------------------------------
c band (800 - 980 cm^-1), nongray gaseous absorption of h2o.
c + cfc11 and cfc12
c----------------------------------------------------------------------
c
if (ig .eq. 1) then
ng2 = 7
ng3 = 8
call tline3 (taug, cl6h2o(1,1,ig), cl6f11,
1 cl6f12, qq, ng2, ng3, dp, dip, dt, inpt,
2 lev1, gh, mtl, il1, il2, ilg, lay)
c
lc = 4
call tcontl (taug, cl6cs, cl6cf, qq, dp, dip, dt,
1 lc, inpt, mcont, gh, il1, il2, ilg, lay)
c
c----------------------------------------------------------------------
c simply add the co2 + cfc effect
c----------------------------------------------------------------------
c
do 600 k = lev1, lay
do 600 i = il1, il2
taug(i,k) = taug(i,k) + ( (0.0074 + 0.0396 * qq(i,k) /
1 (qq(i,k) + 2.8 * rmco2)) * rmco2 +
2 722.0 * rmf113 + 578.0 * rmf114 ) * dp(i,k)
600 continue
else
ng = 1
call tline1 (taug, cl6h2o(1,1,ig), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, mtl, init2,
2 il1, il2, ilg, lay, tg)
endif
c
gw = gwl6(ig)
c
else if (ib .eq. 7) then
c
c----------------------------------------------------------------------
c band6 (540 - 800 cm^-1), overlapping absorption of h2o and co2
c exact mapping method for h2o and co2, direct mapping for n2o
c o3 effect is simply added
c----------------------------------------------------------------------
c
call tlinehc (taug, cl7h2ou(1,1,ig), cl7h2od(1,1,1,ig),
1 cl7co2u(1,1,ig), cl7co2d(1,1,1,ig), qq, dp, dip,dir,
2 dt, inptr, inpt, lev1, il1, il2, ilg, lay)
c
call tconthl2(taug, cl7cs(1,1,1,ig), cl7cf(1,1,1,ig), qq, dp, dip,
1 dir, dt, inptr, inpt, mcont, il1, il2, ilg, lay)
c
ng = 5
call tline1 (taug, cl7n2o(1,1,ig), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, mtl, init1,
2 il1, il2, ilg, lay, tg)
c
c----------------------------------------------------------------------
c simply add the o3 effect
c----------------------------------------------------------------------
c
do 700 k = lev1, lay
do 700 i = il1, il2
taug(i,k) = taug(i,k) + cl7o3(ig) * o3(i,k) * dp(i,k)
700 continue
c
gw = gwl7(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, cl8h2o(1,1,ig), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, mtl, init2,
2 il1, il2, ilg, lay, tg)
c
if (ig .le. 4) then
lc = 6
call tcontl (taug, cl8cs(1,1,ig), cl8cf(1,1,ig), qq, dp, dip,dt,
1 lc, inpt, mcont, gh, il1, il2, ilg, lay)
endif
c
gw = gwl8(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, cl9h2o(1,1,ig), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, mtl, init2,
2 il1, il2, ilg, lay, tg)
c
lc = 6
call tcontl (taug, cl9cs(1,1,ig), cl9cf(1,1,ig), qq, dp, dip, dt,
1 lc, inpt, mcont, gh, il1, il2, ilg, lay)
c
gw = gwl9(ig)
c
endif
c
return
end