!-------------------------------------- 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 STRANDNGH - CALCULATION OF THE DOWNWARD SOLAR FLUX
*
#include "phy_macros_f.h"
subroutine strandngh (tran, gwgh, atten, taua, tauoma, 1,7
1 taucs, tauomc, cldfrac, rmu, dp,
2 o3, qq, ib, ig, inpt,
3 dip, dt, lev1, gh, cut,
4 il1, il2, ilg, lay, lev,
5 taug, s)
*
#include "impnone.cdk"
*
integer ilg, lay, lev, ib, ig, lev1, il1, il2, i, k, kp1, ng
integer im, ng2
real gw1, cs1o3, cs1o21
real gwgh, cut, absc
real tran(ilg,2,lev), atten(ilg), taua(ilg,lay), tauoma(ilg,lay),
1 taucs(ilg,lay), tauomc(ilg,lay), cldfrac(ilg,lay), rmu(ilg),
2 dp(ilg,lay), o3(ilg,lay), qq(ilg,lay), dip(ilg,lay),
3 dt(ilg,lay), taug(ilg,lay), s(ilg,lay)
integer inpt(ilg,lay)
logical gh
real tau(ilg),dtr1(ilg)
integer init
*
*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
*
* Calculation of the downward solar flux under the condition that
* the extinction coefficient of gas is very large, the scattering
* effects can be neglected. the cloud optical depth is much smaller
* than the gaseous optical depth, the cloud effect is very small
* and be treated simply
*
* hrs solar heating rate (k / sec)
* tran downward flux
* atten attenuation factor for downward flux from toa to the
* model top level
* taucs cloud optical depth
* cldfrac cloud fraction
* rmu cos of solar zenith angle
* dp air mass path for a model layer (explained in raddriv)
* o3 o3 mass mixing ratio
* qq water vapor mass mixing ratio
* inpt number of the level for the standard input data pressures
* dip interpolation factor for pressure between two
* neighboring standard input data pressure levels
* dt layer temperature - 250 k
*
*Implicites
*
#include "tracegases.cdk"
#include "bandsh.cdk"
*
**
do 10 i = il1, il2
tran(i,1,1) = atten(i)
tran(i,2,1) = atten(i)
10 continue
c
if (ib .eq. 1) then
c
c----------------------------------------------------------------------
* band1 for uvc (35700 - 50000 cm^-1), nongray gaseous absorption
c of o2 and o3. solar energy 6.9015 w m^-2
c----------------------------------------------------------------------
c
if (ig .eq. 3) then
do 105 k = 1, lay
kp1 = k + 1
do i = il1, il2
tau(i) = (cs1o3gh(ig) * o3(i,k) + cs1o2gh3 *
1 rmo2) * dp(i,k) + taua(i,k)
dtr1(i) = - (tau(i) - tauoma(i,k)) / rmu(i)
enddo
call vsexp(dtr1(il1),dtr1(il1),il2-il1+1)
do 100 i = il1, il2
c tau = (cs1o3gh(ig) * o3(i,k) + cs1o2gh3 *
c 1 rmo2) * dp(i,k) + taua(i,k)
tran(i,1,kp1) = tran(i,1,k) * dtr1(i)
c
if (cldfrac(i,k) .lt. cut) then
tran(i,2,kp1) = tran(i,2,k) * dtr1(i)
else
absc = (1.0-cldfrac(i,k))*dtr1(i)+cldfrac(i,k)*
1 exp( -(tau(i)+taucs(i,k)-tauomc(i,k))
2 / rmu(i))
tran(i,2,kp1) = tran(i,2,k) * absc
endif
100 continue
105 continue
else
do 115 k = 1, lay
kp1 = k + 1
do i = il1, il2
tau(i) = cs1o3gh(ig) * o3(i,k) * dp(i,k) +
1 taua(i,k)
dtr1(i) = - (tau(i) - tauoma(i,k)) / rmu(i)
enddo
call vsexp(dtr1(il1),dtr1(il1),il2-il1+1)
do 110 i = il1, il2
c tau = cs1o3gh(ig) * o3(i,k) * dp(i,k) +
c 1 taua(i,k)
tran(i,1,kp1) = tran(i,1,k) * dtr1(i)
c
if (cldfrac(i,k) .lt. cut) then
tran(i,2,kp1) = tran(i,2,k) * dtr1(i)
else
absc =(1.0-cldfrac(i,k))*dtr1(i)+cldfrac(i,k) *
1 exp( - (tau(i)+taucs(i,k)-tauomc(i,k))
2 / rmu(i))
tran(i,2,kp1) = tran(i,2,k) * absc
endif
110 continue
115 continue
endif
gwgh = gws1gh(ig)
c
else if (ib .eq. 2) then
c
c----------------------------------------------------------------------
c band (8400 - 14500 cm^-1), nongray gaseous absorption of o2
c and o3. solar energy 8.72450 w m^-2
c----------------------------------------------------------------------
c
if (ig .eq. 1) then
ng = 1
init=2
call tline1 (taug, cs2h2ogh(1,1), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, ntl, init,
2 il1, il2, ilg, lay, s)
else
im = ig - 1
ng = 6
init=2
call tline1 (taug, cs2o2gh(1,1,im), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, ntl, init,
2 il1, il2, ilg, lay, s)
endif
c
do 205 k = 1, lay
kp1 = k + 1
do i = il1, il2
tau(i) = taug(i,k) + taua(i,k)
dtr1(i) = - (tau(i) - tauoma(i,k)) / rmu(i)
enddo
call vsexp(dtr1(il1),dtr1(il1),il2-il1+1)
do 200 i = il1, il2
c tau = taug(i,k) + taua(i,k)
tran(i,1,kp1) = tran(i,1,k) * dtr1(i)
c
if (cldfrac(i,k) .lt. cut) then
tran(i,2,kp1) = tran(i,2,k) * dtr1(i)
else
absc = (1.0-cldfrac(i,k))*dtr1(i)+cldfrac(i,k)*
1 exp( -(tau(i)+taucs(i,k)-tauomc(i,k))
2 / rmu(i))
tran(i,2,kp1) = tran(i,2,k) * absc
endif
200 continue
205 continue
c
gwgh = gws2gh(ig)
c
else if (ib .eq. 3) then
c
c----------------------------------------------------------------------
c band (4200 - 8400 cm^-1), nongray gaseous absorption of h2o and
c co2. solar energy 4.0330 w m^-2
c----------------------------------------------------------------------
c
if (ig .le. 2) then
ng2 = 3
call tline2 (taug, cs3h2ogh(1,1,ig), cs3co2gh(1,1,ig), qq, o3,
1 ng2, dp, dip, dt, inpt,
2 lev1, gh, ntl, il1, il2, ilg, lay, s)
else
ng = 3
init=2
call tline1 (taug, cs3co2gh(1,1,ig), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, ntl, init,
2 il1, il2, ilg, lay, s)
endif
c
do 305 k = 1, lay
kp1 = k + 1
do i = il1, il2
tau(i) = taug(i,k) + taua(i,k)
dtr1(i) = - (tau(i) - tauoma(i,k)) / rmu(i)
enddo
call vsexp(dtr1(il1),dtr1(il1),il2-il1+1)
do 300 i = il1, il2
c tau = taug(i,k) + taua(i,k)
tran(i,1,kp1) = tran(i,1,k) * dtr1(i)
c
if (cldfrac(i,k) .lt. cut) then
tran(i,2,kp1) = tran(i,2,k) * dtr1(i)
else
absc = (1.0-cldfrac(i,k))*dtr1(i)+cldfrac(i,k)*
1 exp( - (tau(i)+taucs(i,k)-tauomc(i,k))
2 / rmu(i))
tran(i,2,kp1) = tran(i,2,k) * absc
endif
300 continue
305 continue
c
gwgh = gws3gh(ig)
c
else if (ib .eq. 4) then
c
c----------------------------------------------------------------------
c band (2500 - 4200 cm^-1), nongray gaseous absorption of h2o
c and co2. solar energy 9.6020 w m^-2
c----------------------------------------------------------------------
c
if (ig .le. 3) then
ng2 = 3
call tline2 (taug, cs4h2ogh(1,1,ig), cs4co2gh(1,1,ig), qq, o3,
1 ng2, dp, dip, dt, inpt,
2 lev1, gh, ntl, il1, il2, ilg, lay, s)
else if (ig .eq. 4 .or. ig .eq. 6 .or. ig .eq. 8) then
ng = 1
if (ig .eq. 4) im = 4
if (ig .eq. 6) im = 5
if (ig .eq. 8) im = 6
init=2
call tline1 (taug, cs4h2ogh(1,1,im), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, ntl, init,
2 il1, il2, ilg, lay, s)
else
ng = 3
if (ig .eq. 5) im = 4
if (ig .eq. 7) im = 5
if (ig .eq. 9) im = 6
init=2
call tline1 (taug, cs4co2gh(1,1,im), qq, ng, dp, dip,
1 dt, inpt, lev1, gh, ntl, init,
2 il1, il2, ilg, lay, s)
endif
c
do 405 k = 1, lay
kp1 = k + 1
do i = il1, il2
tau(i) = taug(i,k) + taua(i,k)
dtr1(i) = - (tau(i) - tauoma(i,k)) / rmu(i)
enddo
call vsexp(dtr1(il1),dtr1(il1),il2-il1+1)
do 400 i = il1, il2
c tau = taug(i,k) + taua(i,k)
tran(i,1,kp1) = tran(i,1,k) * dtr1(i)
c
if (cldfrac(i,k) .lt. cut) then
tran(i,2,kp1) = tran(i,2,k) * dtr1(i)
else
absc = (1.0-cldfrac(i,k))*dtr1(i)+cldfrac(i,k)*
1 exp(-(tau(i)+taucs(i,k)-tauomc(i,k))
2 / rmu(i))
tran(i,2,kp1) = tran(i,2,k) * absc
endif
400 continue
405 continue
c
gwgh = gws4gh(ig)
c
endif
c
return
end