/
module_aer_opt_out.F
90 lines (87 loc) · 6.51 KB
/
module_aer_opt_out.F
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
MODULE module_aer_opt_out
! SAM lower and upper wavelength limits (microns) for AFWA band averaging - 2 averaging bins considered here
REAL, PARAMETER, PRIVATE :: afwalowv1 = 3. ! lower wavelength for first AFWA band average extinction coefficent
REAL, PARAMETER, PRIVATE :: afwahiwv1 = 5. ! upper wavelength for first AFWA band average extinction coefficent
REAL, PARAMETER, PRIVATE :: afwalowv2 = 8. ! lower wavelength for second AFWA band average extinction coefficent
REAL, PARAMETER, PRIVATE :: afwahiwv2 = 12. ! upper wavelength for second AFWA band average extinction coefficent
CONTAINS
SUBROUTINE aer_opt_out(dz8w &
, ext_coeff, bscat_coeff, asym_par &
, tauaer300, tauaer400, tauaer600, tauaer999 & ! jcb
, gaer300, gaer400, gaer600, gaer999 & ! jcb
, waer300, waer400, waer600, waer999 & ! jcb
, num_ext_coef, num_bscat_coef, num_asym_par &
, ids, ide, jds, jde, kds, kde &
, ims, ime, jms, jme, kms, kme &
, its, ite, jts, jte, kts, kte)
USE module_configure, only:p_extcof3, p_extcof55, p_extcof106, p_extcof3_5, p_extcof8_12, p_bscof3, p_bscof55, &
p_bscof106, p_asympar3, p_asympar55, p_asympar106
IMPLICIT NONE
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
its, ite, jts, jte, kts, kte, &
num_ext_coef, num_bscat_coef, num_asym_par
REAL, DIMENSION(ims:ime, kms:kme, jms:jme, 1:num_ext_coef), INTENT(OUT) :: ext_coeff
REAL, DIMENSION(ims:ime, kms:kme, jms:jme, 1:num_bscat_coef), INTENT(OUT) :: bscat_coeff
REAL, DIMENSION(ims:ime, kms:kme, jms:jme, 1:num_asym_par), INTENT(OUT) :: asym_par
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), &
INTENT(IN) :: tauaer300, tauaer400, tauaer600, tauaer999, &
gaer300, gaer400, gaer600, gaer999, &
waer300, waer400, waer600, waer999, dz8w
real :: ang, slope, slopeg, slopessa, onemang
integer :: i, j, k
!SAM 10/22/09 AFWA ouput. Fill following arrays:
! 0.3 micron extinction coefficient (1/km), scattering coefficient (1/km), assymetry coefficient (unitless)
! 0.55 micron extinction coefficient (1/km), scattering coefficient (1/km), assymetry coefficient (unitless)
! 1.06 micron extinction coefficient (1/km), scattering coefficient (1/km), assymetry coefficient (unitless)
! 3. - 5. micron band averaged extinction coefficient (1/km)
! 8. - 12. micron band averaged extinction coefficient (1/km)
! As in PNNL MOSAIC, extrapolate or interpolate based on 300-999 nm Angstrom coefficient,
! or linear interpolation/extrapolation between 300 and 999 nm for assymetry coefficient
do j = jts, jte
do k = kts, kte
do i = its, ite
! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths
! these are: 300, 550 and 1060
! 300 nm already calculated in aerosol_optical_averaging and miecalc
ext_coeff(i, k, j, p_extcof3) = tauaer300(i, k, j)*1.E3/dz8w(i, k, j) ! 300nm ext. coeff. (1/km)
bscat_coeff(i, k, j, p_bscof3) = tauaer300(i, k, j)*waer300(i, k, j)*1.E3/dz8w(i, k, j) ! 300nm scat. coeff. (1/km)
asym_par(i, k, j, p_asympar3) = gaer300(i, k, j) ! 300nm assym. parameter (no units)
! 550 nm done like PNNL
ang = log(tauaer300(i, k, j)/tauaer999(i, k, j))/log(999./300.)
slopessa = (waer600(i, k, j) - waer400(i, k, j))/.2
slopeg = (gaer600(i, k, j) - gaer400(i, k, j))/.2
ext_coeff(i, k, j, p_extcof55) = tauaer400(i, k, j)*1.E3*((0.4/0.55)**ang)/dz8w(i, k, j) ! 550nm ext. coeff. (1/km)
slope = slopessa*(0.55-.6) + waer600(i, k, j) ! slope is scratch variable, = single scat albedo at .55 micron
slope = AMIN1(1.0, AMAX1(0.4, slope)) ! SSA has same limits as in PNNL
bscat_coeff(i, k, j, p_bscof55) = ext_coeff(i, k, j, p_extcof55)*slope ! 550nm scat. coeff. (1/km)
asym_par(i, k, j, p_asympar55) = AMIN1(1., AMAX1(0.5, slopeg*(.55-.6) + gaer600(i, k, j))) ! 550nm assym. parameter (no units)
! 1060 nm done like PNNL
slopessa = (waer999(i, k, j) - waer600(i, k, j))/.399
slopeg = (gaer999(i, k, j) - gaer600(i, k, j))/.399
ext_coeff(i, k, j, p_extcof106) = tauaer400(i, k, j)*1.E3*((0.4/1.06)**ang)/dz8w(i, k, j) ! 1060nm ext. coeff. (1/km)
slope = slopessa*(1.06-.999) + waer999(i, k, j) ! slope is scratch variable, = single scat albedo at 1.06 micron
slope = AMIN1(1.0, AMAX1(0.4, slope)) ! SSA has same limits as in PNNL
bscat_coeff(i, k, j, p_bscof106) = ext_coeff(i, k, j, p_extcof106)*slope ! 1060nm scat. coeff. (1/km)
asym_par(i, k, j, p_asympar106) = AMIN1(1., AMAX1(0.5, slopeg*(1.06-.999) + gaer600(i, k, j))) ! 1060nm assym. parameter (no units)
! 3.-5. and 8. - 12. micron band averages done by extrapolating .3-.999 calculations, like PNNL
onemang = 1.-ang
if (abs(onemang) .gt. 1.E-3) then ! if ang sufficiently different than one, no need to worry about singularity
slope = tauaer400(i, k, j)*(0.4/afwalowv1)**ang ! Dummy incrumental tau at afwa lower wavelength for band average
slopeg = tauaer400(i, k, j)*(0.4/afwahiwv1)**ang ! Dummy incrumental tau at afwa high wavelength for band average
ext_coeff(i, k, j, p_extcof3_5) = (slopeg*afwahiwv1 - slope*afwalowv1)/(afwahiwv1 - afwalowv1)/onemang
slope = tauaer400(i, k, j)*(0.4/afwalowv2)**ang ! Dummy incrumental tau at afwa lower wavelength for band average
slopeg = tauaer400(i, k, j)*(0.4/afwahiwv2)**ang ! Dummy incrumental tau at afwa high wavelength for band average
ext_coeff(i, k, j, p_extcof8_12) = (slopeg*afwahiwv2 - slope*afwalowv2)/(afwahiwv2 - afwalowv2)/onemang
else ! ang is close to 1., avoid singularity
ext_coeff(i, k, j, p_extcof3_5) = tauaer400(i, k, j)*0.4*log(afwahiwv1/afwalowv1)/(afwahiwv1 - afwalowv1)
ext_coeff(i, k, j, p_extcof8_12) = tauaer400(i, k, j)*0.4*log(afwahiwv2/afwalowv2)/(afwahiwv2 - afwalowv2)
endif
! Convert band average incrumental taus to extinction coefficients (1/km)
ext_coeff(i, k, j, p_extcof3_5) = ext_coeff(i, k, j, p_extcof3_5)*1.E3/dz8w(i, k, j)
ext_coeff(i, k, j, p_extcof8_12) = ext_coeff(i, k, j, p_extcof8_12)*1.E3/dz8w(i, k, j)
end do
end do
end do
END SUBROUTINE AER_OPT_OUT
END MODULE module_aer_opt_out