CCPP SciDoc v7.0.0  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
rrtmgp_sw_cloud_optics.F90
1
3
5 use machine, only: kind_phys
6 use mo_rte_kind, only: wl
7 use mo_cloud_optics, only: ty_cloud_optics
8 use rrtmgp_sw_gas_optics, only: sw_gas_props
9 use radiation_tools, only: check_error_msg
10 use netcdf
11#ifdef MPI
12 use mpi_f08
13#endif
14
15 implicit none
16
17 type(ty_cloud_optics) :: sw_cloud_props
18 integer :: &
19 nrghice_fromfilesw, nbandsw, nsize_liqsw, nsize_icesw, nsizeregsw, &
20 ncoeff_extsw, ncoeff_ssa_gsw, nboundsw, npairssw
21 real(kind_phys) :: &
22 radliq_facsw, & !< Factor for calculating LUT interpolation indices for liquid
23 radice_facsw
24 real(kind_phys), dimension(:,:), allocatable :: &
25 lut_extliqsw, & !< LUT shortwave liquid extinction coefficient
26 lut_ssaliqsw, & !< LUT shortwave liquid single scattering albedo
27 lut_asyliqsw, & !< LUT shortwave liquid asymmetry parameter
28 band_limscldsw
29 real(kind_phys), dimension(:,:,:), allocatable :: &
30 lut_exticesw, & !< LUT shortwave ice extinction coefficient
31 lut_ssaicesw, & !< LUT shortwave ice single scattering albedo
32 lut_asyicesw
33 real(kind_phys), dimension(:), allocatable :: &
34 pade_sizereg_extliqsw, & !< Particle size regime boundaries for shortwave liquid extinction
35
36 pade_sizereg_ssaliqsw, &
38 pade_sizereg_asyliqsw, &
40 pade_sizereg_exticesw, &
42 pade_sizereg_ssaicesw, &
44 pade_sizereg_asyicesw
46 real(kind_phys), dimension(:,:,:), allocatable :: &
47 pade_extliqsw, & !< PADE coefficients for shortwave liquid extinction
48 pade_ssaliqsw, & !< PADE coefficients for shortwave liquid single scattering albedo
49 pade_asyliqsw
50 real(kind_phys), dimension(:,:,:,:), allocatable :: &
51 pade_exticesw, & !< PADE coefficients for shortwave ice extinction
52 pade_ssaicesw, & !< PADE coefficients for shortwave ice single scattering albedo
53 pade_asyicesw
54 real(kind_phys) :: &
55 radliq_lwrsw, & !< Liquid particle size lower bound for LUT interpolation
56 radliq_uprsw, & !< Liquid particle size upper bound for LUT interpolation
57 radice_lwrsw, & !< Ice particle size upper bound for LUT interpolation
58 radice_uprsw
59
60 ! Parameters used for rain and snow(+groupel) RRTMGP cloud-optics. *NOTE* Same as in RRTMG
61 ! Need to document these magic numbers below.
62 real(kind_phys),parameter :: &
63 a0r = 3.07e-3, & !
64 a0s = 0.0, & !
65 a1s = 1.5 !
66 real(kind_phys),dimension(:),allocatable :: b0r,b0s,b1s,c0r,c0s
67
68contains
69 ! ######################################################################################
70 ! SUBROUTINE sw_cloud_optics_init
71 ! ######################################################################################
73 subroutine rrtmgp_sw_cloud_optics_init( rrtmgp_root_dir, rrtmgp_sw_file_clouds, &
74 doGP_cldoptics_PADE, doGP_cldoptics_LUT, nrghice, mpicomm, mpirank, mpiroot, &
75 errmsg, errflg)
76
77 ! Inputs
78 character(len=128),intent(in) :: &
79 rrtmgp_root_dir, & !< RTE-RRTMGP root directory
80 rrtmgp_sw_file_clouds
81 logical, intent(in) :: &
82 doGP_cldoptics_PADE,& !< Use RRTMGP cloud-optics: PADE approximation?
83 doGP_cldoptics_LUT
84 integer, intent(inout) :: &
85 nrghice
86 type(mpi_comm), intent(in) :: &
87 mpicomm
88 integer, intent(in) :: &
89 mpirank, & !< Current MPI rank
90 mpiroot
91
92 ! Outputs
93 character(len=*), intent(out) :: &
94 errmsg
95 integer, intent(out) :: &
96 errflg
97
98 ! Local variables
99 integer :: status,ncid,dimid,varID,mpierr
100 character(len=264) :: sw_cloud_props_file
101
102 ! Initialize
103 errmsg = ''
104 errflg = 0
105
106 ! Filenames are set in the physics_nml
107 sw_cloud_props_file = trim(rrtmgp_root_dir)//trim(rrtmgp_sw_file_clouds)
108
109 ! #######################################################################################
110 !
111 ! Read dimensions for shortwave cloud-optics fields...
112 ! (ONLY master processor(0), if MPI enabled)
113 !
114 ! #######################################################################################
115#ifdef MPI
116 if (mpirank .eq. mpiroot) then
117#endif
118 write (*,*) 'Reading RRTMGP shortwave cloud-optics metadata ... '
119
120 ! Open file
121 status = nf90_open(trim(sw_cloud_props_file), nf90_nowrite, ncid)
122
123 ! Read dimensions
124 status = nf90_inq_dimid(ncid, 'nband', dimid)
125 status = nf90_inquire_dimension(ncid, dimid, len=nbandsw)
126 status = nf90_inq_dimid(ncid, 'nrghice', dimid)
127 status = nf90_inquire_dimension(ncid, dimid, len=nrghice_fromfilesw)
128 status = nf90_inq_dimid(ncid, 'nsize_liq', dimid)
129 status = nf90_inquire_dimension(ncid, dimid, len=nsize_liqsw)
130 status = nf90_inq_dimid(ncid, 'nsize_ice', dimid)
131 status = nf90_inquire_dimension(ncid, dimid, len=nsize_icesw)
132 status = nf90_inq_dimid(ncid, 'nsizereg', dimid)
133 status = nf90_inquire_dimension(ncid, dimid, len=nsizeregsw)
134 status = nf90_inq_dimid(ncid, 'ncoeff_ext', dimid)
135 status = nf90_inquire_dimension(ncid, dimid, len=ncoeff_extsw)
136 status = nf90_inq_dimid(ncid, 'ncoeff_ssa_g', dimid)
137 status = nf90_inquire_dimension(ncid, dimid, len=ncoeff_ssa_gsw)
138 status = nf90_inq_dimid(ncid, 'nbound', dimid)
139 status = nf90_inquire_dimension(ncid, dimid, len=nboundsw)
140 status = nf90_inq_dimid(ncid, 'pair', dimid)
141 status = nf90_inquire_dimension(ncid, dimid, len=npairssw)
142#ifdef MPI
143 endif ! On master processor
144
145 ! Other processors waiting...
146 call mpi_barrier(mpicomm, mpierr)
147
148 ! #######################################################################################
149 !
150 ! Broadcast dimensions...
151 ! (ALL processors)
152 !
153 ! #######################################################################################
154 call mpi_bcast(nbandsw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
155 call mpi_bcast(nsize_liqsw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
156 call mpi_bcast(nsize_icesw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
157 call mpi_bcast(nsizeregsw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
158 call mpi_bcast(ncoeff_extsw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
159 call mpi_bcast(ncoeff_ssa_gsw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
160 call mpi_bcast(nboundsw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
161 call mpi_bcast(npairssw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
162#endif
163
164 ! Has the number of ice-roughnes categories been provided from the namelist?
165 ! If so, override nrghice from cloud-optics file
166 if (nrghice .ne. 0) nrghice_fromfilesw = nrghice
167#ifdef MPI
168 call mpi_bcast(nrghice_fromfilesw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
169#endif
170
171 ! #######################################################################################
172 !
173 ! Allocate space for arrays...
174 ! (ALL processors)
175 !
176 ! #######################################################################################
177 if (dogp_cldoptics_lut) then
178 allocate(lut_extliqsw(nsize_liqsw, nbandsw))
179 allocate(lut_ssaliqsw(nsize_liqsw, nbandsw))
180 allocate(lut_asyliqsw(nsize_liqsw, nbandsw))
181 allocate(lut_exticesw(nsize_icesw, nbandsw, nrghice_fromfilesw))
182 allocate(lut_ssaicesw(nsize_icesw, nbandsw, nrghice_fromfilesw))
183 allocate(lut_asyicesw(nsize_icesw, nbandsw, nrghice_fromfilesw))
184 endif
185 if (dogp_cldoptics_pade) then
186 allocate(pade_extliqsw(nbandsw, nsizeregsw, ncoeff_extsw ))
187 allocate(pade_ssaliqsw(nbandsw, nsizeregsw, ncoeff_ssa_gsw))
188 allocate(pade_asyliqsw(nbandsw, nsizeregsw, ncoeff_ssa_gsw))
189 allocate(pade_exticesw(nbandsw, nsizeregsw, ncoeff_extsw, nrghice_fromfilesw))
190 allocate(pade_ssaicesw(nbandsw, nsizeregsw, ncoeff_ssa_gsw, nrghice_fromfilesw))
191 allocate(pade_asyicesw(nbandsw, nsizeregsw, ncoeff_ssa_gsw, nrghice_fromfilesw))
192 allocate(pade_sizereg_extliqsw(nboundsw))
193 allocate(pade_sizereg_ssaliqsw(nboundsw))
194 allocate(pade_sizereg_asyliqsw(nboundsw))
195 allocate(pade_sizereg_exticesw(nboundsw))
196 allocate(pade_sizereg_ssaicesw(nboundsw))
197 allocate(pade_sizereg_asyicesw(nboundsw))
198 endif
199 allocate(band_limscldsw(2,nbandsw))
200
201 ! #######################################################################################
202 !
203 ! Read in data ...
204 ! (ONLY master processor(0), if MPI enabled)
205 !
206 ! #######################################################################################
207#ifdef MPI
208 if (mpirank .eq. mpiroot) then
209#endif
210 if (dogp_cldoptics_lut) then
211 write (*,*) 'Reading RRTMGP shortwave cloud data (LUT) ... '
212 status = nf90_inq_varid(ncid,'radliq_lwr',varid)
213 status = nf90_get_var(ncid,varid,radliq_lwrsw)
214 status = nf90_inq_varid(ncid,'radliq_upr',varid)
215 status = nf90_get_var(ncid,varid,radliq_uprsw)
216 status = nf90_inq_varid(ncid,'radliq_fac',varid)
217 status = nf90_get_var(ncid,varid,radliq_facsw)
218 status = nf90_inq_varid(ncid,'radice_lwr',varid)
219 status = nf90_get_var(ncid,varid,radice_lwrsw)
220 status = nf90_inq_varid(ncid,'radice_upr',varid)
221 status = nf90_get_var(ncid,varid,radice_uprsw)
222 status = nf90_inq_varid(ncid,'radice_fac',varid)
223 status = nf90_get_var(ncid,varid,radice_facsw)
224 status = nf90_inq_varid(ncid,'lut_extliq',varid)
225 status = nf90_get_var(ncid,varid,lut_extliqsw)
226 status = nf90_inq_varid(ncid,'lut_ssaliq',varid)
227 status = nf90_get_var(ncid,varid,lut_ssaliqsw)
228 status = nf90_inq_varid(ncid,'lut_asyliq',varid)
229 status = nf90_get_var(ncid,varid,lut_asyliqsw)
230 status = nf90_inq_varid(ncid,'lut_extice',varid)
231 status = nf90_get_var(ncid,varid,lut_exticesw)
232 status = nf90_inq_varid(ncid,'lut_ssaice',varid)
233 status = nf90_get_var(ncid,varid,lut_ssaicesw)
234 status = nf90_inq_varid(ncid,'lut_asyice',varid)
235 status = nf90_get_var(ncid,varid,lut_asyicesw)
236 status = nf90_inq_varid(ncid,'bnd_limits_wavenumber',varid)
237 status = nf90_get_var(ncid,varid,band_limscldsw)
238 endif
239 if (dogp_cldoptics_pade) then
240 write (*,*) 'Reading RRTMGP shortwave cloud data (PADE) ... '
241 status = nf90_inq_varid(ncid,'radliq_lwr',varid)
242 status = nf90_get_var(ncid,varid,radliq_lwrsw)
243 status = nf90_inq_varid(ncid,'radliq_upr',varid)
244 status = nf90_get_var(ncid,varid,radliq_uprsw)
245 status = nf90_inq_varid(ncid,'radliq_fac',varid)
246 status = nf90_get_var(ncid,varid,radliq_facsw)
247 status = nf90_inq_varid(ncid,'radice_lwr',varid)
248 status = nf90_get_var(ncid,varid,radice_lwrsw)
249 status = nf90_inq_varid(ncid,'radice_upr',varid)
250 status = nf90_get_var(ncid,varid,radice_uprsw)
251 status = nf90_inq_varid(ncid,'radice_fac',varid)
252 status = nf90_get_var(ncid,varid,radice_facsw)
253 status = nf90_inq_varid(ncid,'pade_extliq',varid)
254 status = nf90_get_var(ncid,varid,pade_extliqsw)
255 status = nf90_inq_varid(ncid,'pade_ssaliq',varid)
256 status = nf90_get_var(ncid,varid,pade_ssaliqsw)
257 status = nf90_inq_varid(ncid,'pade_asyliq',varid)
258 status = nf90_get_var(ncid,varid,pade_asyliqsw)
259 status = nf90_inq_varid(ncid,'pade_extice',varid)
260 status = nf90_get_var(ncid,varid,pade_exticesw)
261 status = nf90_inq_varid(ncid,'pade_ssaice',varid)
262 status = nf90_get_var(ncid,varid,pade_ssaicesw)
263 status = nf90_inq_varid(ncid,'pade_asyice',varid)
264 status = nf90_get_var(ncid,varid,pade_asyicesw)
265 status = nf90_inq_varid(ncid,'pade_sizreg_extliq',varid)
266 status = nf90_get_var(ncid,varid,pade_sizereg_extliqsw)
267 status = nf90_inq_varid(ncid,'pade_sizreg_ssaliq',varid)
268 status = nf90_get_var(ncid,varid,pade_sizereg_ssaliqsw)
269 status = nf90_inq_varid(ncid,'pade_sizreg_asyliq',varid)
270 status = nf90_get_var(ncid,varid,pade_sizereg_asyliqsw)
271 status = nf90_inq_varid(ncid,'pade_sizreg_extice',varid)
272 status = nf90_get_var(ncid,varid,pade_sizereg_exticesw)
273 status = nf90_inq_varid(ncid,'pade_sizreg_ssaice',varid)
274 status = nf90_get_var(ncid,varid,pade_sizereg_ssaicesw)
275 status = nf90_inq_varid(ncid,'pade_sizreg_asyice',varid)
276 status = nf90_get_var(ncid,varid,pade_sizereg_asyicesw)
277 status = nf90_inq_varid(ncid,'bnd_limits_wavenumber',varid)
278 status = nf90_get_var(ncid,varid,band_limscldsw)
279 endif
280
281 ! Close file
282 status = nf90_close(ncid)
283
284#ifdef MPI
285 endif ! Master process
286
287 ! Other processors waiting...
288 call mpi_barrier(mpicomm, mpierr)
289
290 ! #######################################################################################
291 !
292 ! Broadcast data...
293 ! (ALL processors)
294 !
295 ! #######################################################################################
296
297 ! Real scalars
298 call mpi_bcast(radliq_facsw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
299 call mpi_bcast(radice_facsw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
300 call mpi_bcast(radliq_lwrsw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
301 call mpi_bcast(radliq_uprsw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
302 call mpi_bcast(radice_lwrsw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
303 call mpi_bcast(radice_uprsw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
304
305 ! Real arrays
306 call mpi_bcast(band_limscldsw, size(band_limscldsw), &
307 mpi_double_precision, mpiroot, mpicomm, mpierr)
308 if (dogp_cldoptics_lut) then
309 call mpi_bcast(lut_extliqsw, size(lut_extliqsw), &
310 mpi_double_precision, mpiroot, mpicomm, mpierr)
311 call mpi_bcast(lut_ssaliqsw, size(lut_ssaliqsw), &
312 mpi_double_precision, mpiroot, mpicomm, mpierr)
313 call mpi_bcast(lut_asyliqsw, size(lut_asyliqsw), &
314 mpi_double_precision, mpiroot, mpicomm, mpierr)
315 call mpi_bcast(lut_exticesw, size(lut_exticesw), &
316 mpi_double_precision, mpiroot, mpicomm, mpierr)
317 call mpi_bcast(lut_ssaicesw, size(lut_ssaicesw), &
318 mpi_double_precision, mpiroot, mpicomm, mpierr)
319 call mpi_bcast(lut_asyicesw, size(lut_asyicesw), &
320 mpi_double_precision, mpiroot, mpicomm, mpierr)
321 endif
322 if (dogp_cldoptics_pade) then
323 call mpi_bcast(pade_extliqsw, size(pade_extliqsw), &
324 mpi_double_precision, mpiroot, mpicomm, mpierr)
325 call mpi_bcast(pade_ssaliqsw, size(pade_ssaliqsw), &
326 mpi_double_precision, mpiroot, mpicomm, mpierr)
327 call mpi_bcast(pade_asyliqsw, size(pade_asyliqsw), &
328 mpi_double_precision, mpiroot, mpicomm, mpierr)
329 call mpi_bcast(pade_exticesw, size(pade_exticesw), &
330 mpi_double_precision, mpiroot, mpicomm, mpierr)
331 call mpi_bcast(pade_ssaicesw, size(pade_ssaicesw), &
332 mpi_double_precision, mpiroot, mpicomm, mpierr)
333 call mpi_bcast(pade_asyicesw, size(pade_asyicesw), &
334 mpi_double_precision, mpiroot, mpicomm, mpierr)
335 call mpi_bcast(pade_sizereg_extliqsw, size(pade_sizereg_extliqsw), &
336 mpi_double_precision, mpiroot, mpicomm, mpierr)
337 call mpi_bcast(pade_sizereg_ssaliqsw, size(pade_sizereg_ssaliqsw), &
338 mpi_double_precision, mpiroot, mpicomm, mpierr)
339 call mpi_bcast(pade_sizereg_asyliqsw, size(pade_sizereg_asyliqsw), &
340 mpi_double_precision, mpiroot, mpicomm, mpierr)
341 call mpi_bcast(pade_sizereg_exticesw, size(pade_sizereg_exticesw), &
342 mpi_double_precision, mpiroot, mpicomm, mpierr)
343 call mpi_bcast(pade_sizereg_ssaicesw, size(pade_sizereg_ssaicesw), &
344 mpi_double_precision, mpiroot, mpicomm, mpierr)
345 call mpi_bcast(pade_sizereg_asyicesw, size(pade_sizereg_asyicesw), &
346 mpi_double_precision, mpiroot, mpicomm, mpierr)
347 endif
348#endif
349
350 ! #######################################################################################
351 !
352 ! Initialize RRTMGP DDT's...
353 !
354 ! #######################################################################################
355 if (dogp_cldoptics_lut) then
356 call check_error_msg('sw_cloud_optics_init',sw_cloud_props%load(band_limscldsw, &
357 radliq_lwrsw, radliq_uprsw, radliq_facsw, radice_lwrsw, radice_uprsw, &
358 radice_facsw, lut_extliqsw, lut_ssaliqsw, lut_asyliqsw, lut_exticesw, &
359 lut_ssaicesw, lut_asyicesw))
360 endif
361
362 if (dogp_cldoptics_pade) then
363 call check_error_msg('sw_cloud_optics_init', sw_cloud_props%load(band_limscldsw, &
364 pade_extliqsw, pade_ssaliqsw, pade_asyliqsw, pade_exticesw, pade_ssaicesw, &
365 pade_asyicesw, pade_sizereg_extliqsw, pade_sizereg_ssaliqsw, &
366 pade_sizereg_asyliqsw, pade_sizereg_exticesw, pade_sizereg_ssaicesw, &
367 pade_sizereg_asyicesw))
368 endif
369
370 call check_error_msg('sw_cloud_optics_init',sw_cloud_props%set_ice_roughness(nrghice_fromfilesw))
371
372 ! Initialize coefficients for rain and snow(+groupel) cloud optics
373 allocate(b0r(sw_cloud_props%get_nband()),b0s(sw_cloud_props%get_nband()), &
374 b1s(sw_cloud_props%get_nband()),c0r(sw_cloud_props%get_nband()), &
375 c0s(sw_cloud_props%get_nband()))
376 b0r = (/0.496, 0.466, 0.437, 0.416, 0.391, 0.374, 0.352, &
377 0.183, 0.048, 0.012, 0.000, 0.000, 0.000, 0.000/)
378 b0s = (/0.460, 0.460, 0.460, 0.460, 0.460, 0.460, 0.460, &
379 0.460, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
380 b1s = (/0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, &
381 0.000, 1.62e-5, 1.62e-5, 0.000, 0.000, 0.000, 0.000/)
382 c0r = (/0.980, 0.975, 0.965, 0.960, 0.955, 0.952, 0.950, &
383 0.944, 0.894, 0.884, 0.883, 0.883, 0.883, 0.883/)
384 c0s = (/0.970, 0.970, 0.970, 0.970, 0.970, 0.970, 0.970, &
385 0.970, 0.970, 0.970, 0.700, 0.700, 0.700, 0.700/)
386
387 end subroutine rrtmgp_sw_cloud_optics_init
388end module rrtmgp_sw_cloud_optics