Line data Source code
1 : ! Cloud optical properties (to-be-ccppized utility module)
2 : ! Computes liquid and ice particle size and emissivity
3 : ! Author: Byron Boville, Sept 2002 assembled from existing subroutines
4 : module cloud_optical_properties
5 :
6 : use shr_kind_mod, only: r8 => shr_kind_r8
7 : use ppgrid, only: pcols, pver, pverp
8 :
9 : implicit none
10 : private
11 : save
12 :
13 : public :: cldefr, cldovrlap, cldclw, reitab, reltab
14 : public :: cldems_rk, cldems
15 :
16 : contains
17 :
18 : ! Compute cloud water and ice particle size [um]
19 : ! using empirical formulas to construct effective radii
20 : ! Original author: J.T. Kiehl, B.A. Boville, P. Rasch
21 70392 : subroutine cldefr( &
22 : ncol, pver, &
23 : tmelt, &
24 70392 : landfrac, t, rel, rei, ps, pmid, landm, icefrac, snowh)
25 : ! Input arguments
26 : integer, intent(in) :: ncol ! number of atmospheric columns
27 : integer, intent(in) :: pver
28 : real(r8), intent(in) :: tmelt
29 :
30 : real(r8), intent(in) :: landfrac(:) ! Land fraction
31 : real(r8), intent(in) :: icefrac(:) ! Ice fraction
32 : real(r8), intent(in) :: t(:, :) ! Temperature
33 : real(r8), intent(in) :: ps(:) ! Surface pressure
34 : real(r8), intent(in) :: pmid(:, :) ! Midpoint pressures
35 : real(r8), intent(in) :: landm(:)
36 : real(r8), intent(in) :: snowh(:) ! Snow depth over land, water equivalent [m]
37 :
38 : ! Output arguments
39 : real(r8), intent(out) :: rel(:, :) ! Liquid effective drop size [um]
40 : real(r8), intent(out) :: rei(:, :) ! Ice effective drop size [um]
41 :
42 : ! following Kiehl
43 70392 : call reltab(ncol, pver, tmelt, t(:ncol,:), landfrac(:ncol), landm(:ncol), icefrac(:ncol), snowh(:), rel(:ncol,:))
44 :
45 : ! following Kristjansson and Mitchell
46 70392 : call reitab(ncol, pver, t(:ncol,:), rei(:ncol,:))
47 70392 : end subroutine cldefr
48 :
49 : ! Compute cloud emissivity using cloud liquid water path [g m-2]
50 : ! Original author: J.T. Kiehl
51 : !
52 : ! Variant 1 used for RK microphysics
53 33520 : subroutine cldems_rk(ncol, pver, clwp, fice, rei, emis, cldtau)
54 : integer, intent(in) :: ncol ! number of atmospheric columns
55 : integer, intent(in) :: pver ! number of vertical levels
56 : real(r8), intent(in) :: clwp(pcols, pver) ! cloud liquid water path (g/m**2)
57 : real(r8), intent(in) :: rei(pcols, pver) ! ice effective drop size (microns)
58 : real(r8), intent(in) :: fice(pcols, pver) ! fractional ice content within cloud
59 :
60 : real(r8), intent(out) :: emis(pcols, pver) ! cloud emissivity (fraction)
61 : real(r8), intent(out) :: cldtau(pcols, pver) ! cloud optical depth
62 :
63 : integer :: i, k ! longitude, level indices
64 : real(r8) :: kabs ! longwave absorption coeff (m**2/g)
65 : real(r8) :: kabsi ! ice absorption coefficient
66 : real(r8) :: kabsl ! longwave liquid absorption coeff (m**2/g)
67 : parameter(kabsl=0.090361_r8)
68 :
69 905040 : do k = 1, pver
70 13541040 : do i = 1, ncol
71 : ! note that optical properties for ice valid only
72 : ! in range of 13 > rei > 130 micron (Ebert and Curry 92)
73 12636000 : kabsi = 0.005_r8 + 1._r8/rei(i, k)
74 12636000 : kabs = kabsl*(1._r8 - fice(i, k)) + kabsi*fice(i, k)
75 12636000 : emis(i, k) = 1._r8 - exp(-1.66_r8*kabs*clwp(i, k))
76 13507520 : cldtau(i, k) = kabs*clwp(i, k)
77 : end do
78 : end do
79 33520 : end subroutine cldems_rk
80 :
81 : ! Variant 2 used for other microphysical schemes
82 0 : subroutine cldems(ncol, pver, clwp, fice, rei, emis, cldtau)
83 : integer, intent(in) :: ncol ! number of atmospheric columns
84 : integer, intent(in) :: pver ! number of vertical levels
85 : real(r8), intent(in) :: clwp(pcols, pver) ! cloud liquid water path (g/m**2)
86 : real(r8), intent(in) :: rei(pcols, pver) ! ice effective drop size (microns)
87 : real(r8), intent(in) :: fice(pcols, pver) ! fractional ice content within cloud
88 :
89 : real(r8), intent(out) :: emis(pcols, pver) ! cloud emissivity (fraction)
90 : real(r8), intent(out) :: cldtau(pcols, pver) ! cloud optical depth
91 :
92 : integer :: i, k ! longitude, level indices
93 : real(r8) :: kabs ! longwave absorption coeff (m**2/g)
94 : real(r8) :: kabsi ! ice absorption coefficient
95 : real(r8) :: kabsl ! longwave liquid absorption coeff (m**2/g)
96 : parameter(kabsl=0.090361_r8)
97 :
98 0 : do k = 1, pver
99 0 : do i = 1, ncol
100 : ! note that optical properties for ice valid only
101 : ! in range of 13 > rei > 130 micron (Ebert and Curry 92)
102 0 : kabsi = 0.005_r8 + 1._r8/min(max(13._r8, rei(i, k)), 130._r8)
103 0 : kabs = kabsl*(1._r8 - fice(i, k)) + kabsi*fice(i, k)
104 0 : emis(i, k) = 1._r8 - exp(-1.66_r8*kabs*clwp(i, k))
105 0 : cldtau(i, k) = kabs*clwp(i, k)
106 : end do
107 : end do
108 0 : end subroutine cldems
109 :
110 : ! Partitions each column into regions with clouds in neighboring layers.
111 : ! This information is used to implement maximum overlap in these regions
112 : ! with random overlap between them.
113 : ! On output,
114 : ! nmxrgn contains the number of regions in each column
115 : ! pmxrgn contains the interface pressures for the lower boundaries of
116 : ! each region!
117 33520 : subroutine cldovrlap(ncol, pver, pverp, pint, cld, nmxrgn, pmxrgn)
118 :
119 : ! Input arguments
120 : integer, intent(in) :: ncol
121 : integer, intent(in) :: pver
122 : integer, intent(in) :: pverp
123 :
124 : real(r8), intent(in) :: pint(:, :) ! Interface pressure
125 : real(r8), intent(in) :: cld(:, :) ! Fractional cloud cover
126 :
127 : ! Output arguments
128 : integer, intent(out) :: nmxrgn(:) ! Number of maximally overlapped regions
129 : real(r8), intent(out) :: pmxrgn(:, :) ! Maximum values of pressure for each
130 : ! maximally overlapped region.
131 : ! 0->pmxrgn(i,1) is range of pressure for
132 : ! 1st region,pmxrgn(i,1)->pmxrgn(i,2) for
133 : ! 2nd region, etc
134 : ! (ncol, pverp)
135 :
136 : integer :: i, k
137 : integer :: n ! Max-overlap region counter
138 67040 : real(r8) :: pnm(ncol, pverp) ! Interface pressure
139 : logical :: cld_found ! Flag for detection of cloud
140 67040 : logical :: cld_layer(pver) ! Flag for cloud in layer
141 :
142 519520 : do i = 1, ncol
143 486000 : cld_found = .false.
144 13122000 : cld_layer(:) = cld(i, :) > 0.0_r8
145 13608000 : pmxrgn(i, :) = 0.0_r8
146 13608000 : pnm(i, :) = pint(i, :)*10._r8
147 486000 : n = 1
148 12406225 : do k = 1, pver
149 12406225 : if (cld_layer(k) .and. .not. cld_found) then
150 767659 : cld_found = .true.
151 11465973 : else if (.not. cld_layer(k) .and. cld_found) then
152 616906 : cld_found = .false.
153 4642578 : if (count(cld_layer(k:pver)) == 0) then
154 313407 : exit
155 : end if
156 303499 : pmxrgn(i, n) = pnm(i, k)
157 303499 : n = n + 1
158 : end if
159 : end do
160 486000 : pmxrgn(i, n) = pnm(i, pverp)
161 519520 : nmxrgn(i) = n
162 : end do
163 33520 : end subroutine cldovrlap
164 :
165 : ! Evaluate cloud liquid water path clwp [g m-2]
166 : ! Original author: Author: J.T. Kiehl
167 33520 : subroutine cldclw(ncol, zi, clwp, tpw, hl)
168 :
169 : ! Input arguments
170 : integer, intent(in) :: ncol ! number of atmospheric columns
171 :
172 : real(r8), intent(in) :: zi(pcols, pverp) ! height at layer interfaces(m)
173 : real(r8), intent(in) :: tpw(pcols) ! total precipitable water (mm)
174 :
175 : ! Output arguments
176 : real(r8), intent(out) :: clwp(pcols, pver) ! cloud liquid water path (g/m**2)
177 : real(r8), intent(out) :: hl(pcols) ! liquid water scale height
178 :
179 : integer :: i, k ! longitude, level indices
180 : real(r8) :: clwc0 ! reference liquid water concentration (g/m**3)
181 : real(r8) :: emziohl(pcols, pverp) ! exp(-zi/hl)
182 : real(r8) :: rhl(pcols) ! 1/hl
183 :
184 : ! Set reference liquid water concentration
185 33520 : clwc0 = 0.21_r8
186 :
187 : ! Diagnose liquid water scale height from precipitable water
188 519520 : do i = 1, ncol
189 486000 : hl(i) = 700.0_r8*log(max(tpw(i) + 1.0_r8, 1.0_r8))
190 519520 : rhl(i) = 1.0_r8/hl(i)
191 : end do
192 :
193 : ! Evaluate cloud liquid water path (vertical integral of exponential fn)
194 938560 : do k = 1, pverp
195 14060560 : do i = 1, ncol
196 14027040 : emziohl(i, k) = exp(-zi(i, k)*rhl(i))
197 : end do
198 : end do
199 905040 : do k = 1, pver
200 13541040 : do i = 1, ncol
201 13507520 : clwp(i, k) = clwc0*hl(i)*(emziohl(i, k + 1) - emziohl(i, k))
202 : end do
203 : end do
204 33520 : end subroutine cldclw
205 :
206 :
207 : ! Compute cloud water size
208 : ! analytic formula following the formulation originally developed by J. T. Kiehl
209 : ! Author: Phil Rasch
210 140784 : subroutine reltab(ncol, pver, tmelt, t, landfrac, landm, icefrac, snowh, rel)
211 :
212 : ! Input arguments
213 : integer, intent(in) :: ncol
214 : integer, intent(in) :: pver
215 : real(r8), intent(in) :: tmelt
216 : real(r8), intent(in) :: landfrac(:) ! Land fraction
217 : real(r8), intent(in) :: landm(:) ! Land fraction ramping to zero over ocean
218 : real(r8), intent(in) :: icefrac(:) ! Ice fraction
219 : real(r8), intent(in) :: t(:, :) ! Temperature [K]
220 : real(r8), intent(in) :: snowh(:) ! Snow depth over land, water equivalent [m]
221 :
222 : ! Output arguments
223 : real(r8), intent(out) :: rel(:, :) ! Liquid effective drop size (microns)
224 :
225 : integer i, k
226 : real(r8) :: rliqland ! liquid drop size if over land
227 : real(r8) :: rliqocean ! liquid drop size if over ocean
228 : real(r8) :: rliqice ! liquid drop size if over sea ice
229 :
230 140784 : rliqocean = 14.0_r8
231 140784 : rliqice = 14.0_r8
232 140784 : rliqland = 8.0_r8
233 :
234 3801168 : do k = 1, pver
235 56872368 : do i = 1, ncol
236 : ! jrm Reworked effective radius algorithm
237 : ! Start with temperature-dependent value appropriate for continental air
238 : ! Note: findmcnew has a pressure dependence here
239 53071200 : rel(i, k) = rliqland + (rliqocean - rliqland)*min(1.0_r8, max(0.0_r8, (tmelt - t(i, k))*0.05_r8))
240 : ! Modify for snow depth over land
241 53071200 : rel(i, k) = rel(i, k) + (rliqocean - rel(i, k))*min(1.0_r8, max(0.0_r8, snowh(i)*10._r8))
242 : ! Ramp between polluted value over land to clean value over ocean.
243 53071200 : rel(i, k) = rel(i, k) + (rliqocean - rel(i, k))*min(1.0_r8, max(0.0_r8, 1.0_r8 - landm(i)))
244 : ! Ramp between the resultant value and a sea ice value in the presence of ice.
245 56731584 : rel(i, k) = rel(i, k) + (rliqice - rel(i, k))*min(1.0_r8, max(0.0_r8, icefrac(i)))
246 : ! end jrm
247 : end do
248 : end do
249 140784 : end subroutine reltab
250 :
251 140784 : subroutine reitab(ncol, pver, t, re)
252 :
253 : integer, intent(in) :: ncol
254 : integer, intent(in) :: pver
255 : real(r8), intent(in) :: t(:, :)
256 : real(r8), intent(out) :: re(:, :)
257 : integer, parameter :: len_retab = 138
258 : real(r8), parameter :: min_retab = 136._r8
259 : real(r8) :: retab(len_retab)
260 : real(r8) :: corr
261 : integer :: i
262 : integer :: k
263 : integer :: index
264 : !
265 : ! Tabulated values of re(T) in the temperature interval
266 : ! 180 K -- 274 K; hexagonal columns assumed:
267 : !
268 : ! Modified for pmc formation: 136K -- 274K
269 : !
270 : data retab / &
271 : 0.05_r8, 0.05_r8, 0.05_r8, 0.05_r8, 0.05_r8, 0.05_r8, &
272 : 0.055_r8, 0.06_r8, 0.07_r8, 0.08_r8, 0.09_r8, 0.1_r8, &
273 : 0.2_r8, 0.3_r8, 0.40_r8, 0.50_r8, 0.60_r8, 0.70_r8, &
274 : 0.8_r8, 0.9_r8, 1.0_r8, 1.1_r8, 1.2_r8, 1.3_r8, &
275 : 1.4_r8, 1.5_r8, 1.6_r8, 1.8_r8, 2.0_r8, 2.2_r8, &
276 : 2.4_r8, 2.6_r8, 2.8_r8, 3.0_r8, 3.2_r8, 3.5_r8, &
277 : 3.8_r8, 4.1_r8, 4.4_r8, 4.7_r8, 5.0_r8, 5.3_r8, &
278 : 5.6_r8, &
279 : 5.92779_r8, 6.26422_r8, 6.61973_r8, 6.99539_r8, 7.39234_r8, &
280 : 7.81177_r8, 8.25496_r8, 8.72323_r8, 9.21800_r8, 9.74075_r8, 10.2930_r8, &
281 : 10.8765_r8, 11.4929_r8, 12.1440_r8, 12.8317_r8, 13.5581_r8, 14.2319_r8, &
282 : 15.0351_r8, 15.8799_r8, 16.7674_r8, 17.6986_r8, 18.6744_r8, 19.6955_r8, &
283 : 20.7623_r8, 21.8757_r8, 23.0364_r8, 24.2452_r8, 25.5034_r8, 26.8125_r8, &
284 : 27.7895_r8, 28.6450_r8, 29.4167_r8, 30.1088_r8, 30.7306_r8, 31.2943_r8, &
285 : 31.8151_r8, 32.3077_r8, 32.7870_r8, 33.2657_r8, 33.7540_r8, 34.2601_r8, &
286 : 34.7892_r8, 35.3442_r8, 35.9255_r8, 36.5316_r8, 37.1602_r8, 37.8078_r8, &
287 : 38.4720_r8, 39.1508_r8, 39.8442_r8, 40.5552_r8, 41.2912_r8, 42.0635_r8, &
288 : 42.8876_r8, 43.7863_r8, 44.7853_r8, 45.9170_r8, 47.2165_r8, 48.7221_r8, &
289 : 50.4710_r8, 52.4980_r8, 54.8315_r8, 57.4898_r8, 60.4785_r8, 63.7898_r8, &
290 : 65.5604_r8, 71.2885_r8, 75.4113_r8, 79.7368_r8, 84.2351_r8, 88.8833_r8, &
291 : 93.6658_r8, 98.5739_r8, 103.603_r8, 108.752_r8, 114.025_r8, 119.424_r8, &
292 : 124.954_r8, 130.630_r8, 136.457_r8, 142.446_r8, 148.608_r8, 154.956_r8, &
293 : 161.503_r8, 168.262_r8, 175.248_r8, 182.473_r8, 189.952_r8, 197.699_r8, &
294 : 205.728_r8, 214.055_r8, 222.694_r8, 231.661_r8, 240.971_r8, 250.639_r8/
295 : save retab
296 :
297 3801168 : do k = 1, pver
298 56872368 : do i = 1, ncol
299 53071200 : index = int(t(i, k) - min_retab)
300 53071200 : index = min(max(index, 1), len_retab - 1)
301 53071200 : corr = t(i, k) - int(t(i, k))
302 159213600 : re(i, k) = retab(index)*(1._r8 - corr) &
303 215945184 : + retab(index + 1)*corr
304 : ! re(i,k) = amax1(amin1(re(i,k),30.),10.)
305 : end do
306 : end do
307 140784 : end subroutine reitab
308 :
309 : end module cloud_optical_properties
|