CCPP SciDoc v7.0.x  v7.0.0
Common Community Physics Package Developed at DTC
 
Loading...
Searching...
No Matches
rrtmgp_sw_cloud_optics.F90
1
3
5module rrtmgp_sw_cloud_optics
6 use mo_rte_kind, only: wl, wp
7 use mo_cloud_optics_rrtmgp, only: ty_cloud_optics => ty_cloud_optics_rrtmgp
8 use rrtmgp_sw_gas_optics, only: sw_gas_props
9 use radiation_tools, only: check_error_msg
10 use netcdf
11 use mpi_f08
12
13 implicit none
14
15 type(ty_cloud_optics) :: sw_cloud_props
16 integer :: &
17 nrghice_fromfilesw, nbandsw, nsize_liqsw, nsize_icesw, nsizeregsw, &
18 ncoeff_extsw, ncoeff_ssa_gsw, nboundsw, npairssw
19 real(wp), dimension(:,:), allocatable :: &
20 lut_extliqsw, & !< LUT shortwave liquid extinction coefficient
21 lut_ssaliqsw, & !< LUT shortwave liquid single scattering albedo
22 lut_asyliqsw, & !< LUT shortwave liquid asymmetry parameter
23 band_limscldsw
24 real(wp), dimension(:,:,:), allocatable :: &
25 lut_exticesw, & !< LUT shortwave ice extinction coefficient
26 lut_ssaicesw, & !< LUT shortwave ice single scattering albedo
27 lut_asyicesw
28 real(wp) :: &
29 radliq_lwrsw, & !< Liquid particle size lower bound for LUT interpolation
30 radliq_uprsw, & !< Liquid particle size upper bound for LUT interpolation
31 radice_lwrsw, & !< Ice particle size upper bound for LUT interpolation
32 radice_uprsw
33
34 ! Parameters used for rain and snow(+groupel) RRTMGP cloud-optics. *NOTE* Same as in RRTMG
35 ! Need to document these magic numbers below.
36 real(wp),parameter :: &
37 a0r = 3.07e-3, & !
38 a0s = 0.0, & !
39 a1s = 1.5 !
40 real(wp),dimension(:),allocatable :: b0r,b0s,b1s,c0r,c0s
41
42contains
43 ! ######################################################################################
44 ! SUBROUTINE sw_cloud_optics_init
45 ! ######################################################################################
47 subroutine rrtmgp_sw_cloud_optics_init( rrtmgp_root_dir, rrtmgp_sw_file_clouds, &
48 nrghice, mpicomm, mpirank, mpiroot, errmsg, errflg)
49
50 ! Inputs
51 character(len=128),intent(in) :: &
52 rrtmgp_root_dir, & !< RTE-RRTMGP root directory
53 rrtmgp_sw_file_clouds
54 integer, intent(inout) :: &
55 nrghice
56 type(mpi_comm), intent(in) :: &
57 mpicomm
58 integer, intent(in) :: &
59 mpirank, & !< Current MPI rank
60 mpiroot
61
62 ! Outputs
63 character(len=*), intent(out) :: &
64 errmsg
65 integer, intent(out) :: &
66 errflg
67
68 ! Local variables
69 integer :: status,ncid,dimid,varID,mpierr
70 character(len=264) :: sw_cloud_props_file
71
72 ! Initialize
73 errmsg = ''
74 errflg = 0
75
76 ! Filenames are set in the physics_nml
77 sw_cloud_props_file = trim(rrtmgp_root_dir)//trim(rrtmgp_sw_file_clouds)
78
79 ! #######################################################################################
80 !
81 ! Read dimensions for shortwave cloud-optics fields...
82 ! (ONLY master processor(0), if MPI enabled)
83 !
84 ! #######################################################################################
85 if (mpirank .eq. mpiroot) then
86 write (*,*) 'Reading RRTMGP shortwave cloud-optics metadata ... '
87
88 ! Open file
89 status = nf90_open(trim(sw_cloud_props_file), nf90_nowrite, ncid)
90
91 ! Read dimensions
92 status = nf90_inq_dimid(ncid, 'nband', dimid)
93 status = nf90_inquire_dimension(ncid, dimid, len=nbandsw)
94 status = nf90_inq_dimid(ncid, 'nrghice', dimid)
95 status = nf90_inquire_dimension(ncid, dimid, len=nrghice_fromfilesw)
96 status = nf90_inq_dimid(ncid, 'nsize_liq', dimid)
97 status = nf90_inquire_dimension(ncid, dimid, len=nsize_liqsw)
98 status = nf90_inq_dimid(ncid, 'nsize_ice', dimid)
99 status = nf90_inquire_dimension(ncid, dimid, len=nsize_icesw)
100 status = nf90_inq_dimid(ncid, 'nsizereg', dimid)
101 status = nf90_inquire_dimension(ncid, dimid, len=nsizeregsw)
102 status = nf90_inq_dimid(ncid, 'ncoeff_ext', dimid)
103 status = nf90_inquire_dimension(ncid, dimid, len=ncoeff_extsw)
104 status = nf90_inq_dimid(ncid, 'ncoeff_ssa_g', dimid)
105 status = nf90_inquire_dimension(ncid, dimid, len=ncoeff_ssa_gsw)
106 status = nf90_inq_dimid(ncid, 'nbound', dimid)
107 status = nf90_inquire_dimension(ncid, dimid, len=nboundsw)
108 status = nf90_inq_dimid(ncid, 'pair', dimid)
109 status = nf90_inquire_dimension(ncid, dimid, len=npairssw)
110 endif ! On master processor
111
112 ! Other processors waiting...
113 call mpi_barrier(mpicomm, mpierr)
114
115 ! #######################################################################################
116 !
117 ! Broadcast dimensions...
118 ! (ALL processors)
119 !
120 ! #######################################################################################
121 call mpi_bcast(nbandsw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
122 call mpi_bcast(nsize_liqsw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
123 call mpi_bcast(nsize_icesw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
124 call mpi_bcast(nsizeregsw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
125 call mpi_bcast(ncoeff_extsw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
126 call mpi_bcast(ncoeff_ssa_gsw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
127 call mpi_bcast(nboundsw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
128 call mpi_bcast(npairssw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
129
130 ! Has the number of ice-roughnes categories been provided from the namelist?
131 ! If so, override nrghice from cloud-optics file
132 if (nrghice .ne. 0) nrghice_fromfilesw = nrghice
133 call mpi_bcast(nrghice_fromfilesw, 1, mpi_integer, mpiroot, mpicomm, mpierr)
134
135 ! #######################################################################################
136 !
137 ! Allocate space for arrays...
138 ! (ALL processors)
139 !
140 ! #######################################################################################
141 allocate(lut_extliqsw(nsize_liqsw, nbandsw))
142 allocate(lut_ssaliqsw(nsize_liqsw, nbandsw))
143 allocate(lut_asyliqsw(nsize_liqsw, nbandsw))
144 allocate(lut_exticesw(nsize_icesw, nbandsw, nrghice_fromfilesw))
145 allocate(lut_ssaicesw(nsize_icesw, nbandsw, nrghice_fromfilesw))
146 allocate(lut_asyicesw(nsize_icesw, nbandsw, nrghice_fromfilesw))
147 allocate(band_limscldsw(2,nbandsw))
148
149 ! #######################################################################################
150 !
151 ! Read in data ...
152 ! (ONLY master processor(0), if MPI enabled)
153 !
154 ! #######################################################################################
155 if (mpirank .eq. mpiroot) then
156 write (*,*) 'Reading RRTMGP shortwave cloud data (LUT) ... '
157 status = nf90_inq_varid(ncid,'radliq_lwr',varid)
158 status = nf90_get_var(ncid,varid,radliq_lwrsw)
159 status = nf90_inq_varid(ncid,'radliq_upr',varid)
160 status = nf90_get_var(ncid,varid,radliq_uprsw)
161 status = nf90_inq_varid(ncid,'radice_lwr',varid)
162 status = nf90_get_var(ncid,varid,radice_lwrsw)
163 status = nf90_inq_varid(ncid,'radice_upr',varid)
164 status = nf90_get_var(ncid,varid,radice_uprsw)
165 status = nf90_inq_varid(ncid,'lut_extliq',varid)
166 status = nf90_get_var(ncid,varid,lut_extliqsw)
167 status = nf90_inq_varid(ncid,'lut_ssaliq',varid)
168 status = nf90_get_var(ncid,varid,lut_ssaliqsw)
169 status = nf90_inq_varid(ncid,'lut_asyliq',varid)
170 status = nf90_get_var(ncid,varid,lut_asyliqsw)
171 status = nf90_inq_varid(ncid,'lut_extice',varid)
172 status = nf90_get_var(ncid,varid,lut_exticesw)
173 status = nf90_inq_varid(ncid,'lut_ssaice',varid)
174 status = nf90_get_var(ncid,varid,lut_ssaicesw)
175 status = nf90_inq_varid(ncid,'lut_asyice',varid)
176 status = nf90_get_var(ncid,varid,lut_asyicesw)
177 status = nf90_inq_varid(ncid,'bnd_limits_wavenumber',varid)
178 status = nf90_get_var(ncid,varid,band_limscldsw)
179
180 ! Close file
181 status = nf90_close(ncid)
182
183 endif ! Master process
184
185 ! Other processors waiting...
186 call mpi_barrier(mpicomm, mpierr)
187
188 ! #######################################################################################
189 !
190 ! Broadcast data...
191 ! (ALL processors)
192 !
193 ! #######################################################################################
194
195 ! Real scalars
196#ifdef RTE_USE_SP
197 call mpi_bcast(radliq_lwrsw, 1, mpi_real, mpiroot, mpicomm, mpierr)
198 call mpi_bcast(radliq_uprsw, 1, mpi_real, mpiroot, mpicomm, mpierr)
199 call mpi_bcast(radice_lwrsw, 1, mpi_real, mpiroot, mpicomm, mpierr)
200 call mpi_bcast(radice_uprsw, 1, mpi_real, mpiroot, mpicomm, mpierr)
201#else
202 call mpi_bcast(radliq_lwrsw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
203 call mpi_bcast(radliq_uprsw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
204 call mpi_bcast(radice_lwrsw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
205 call mpi_bcast(radice_uprsw, 1, mpi_double_precision, mpiroot, mpicomm, mpierr)
206#endif
207
208 ! Real arrays
209#ifdef RTE_USE_SP
210 call mpi_bcast(band_limscldsw, size(band_limscldsw), mpi_real, mpiroot, mpicomm, mpierr)
211 call mpi_bcast(lut_extliqsw, size(lut_extliqsw), mpi_real, mpiroot, mpicomm, mpierr)
212 call mpi_bcast(lut_ssaliqsw, size(lut_ssaliqsw), mpi_real, mpiroot, mpicomm, mpierr)
213 call mpi_bcast(lut_asyliqsw, size(lut_asyliqsw), mpi_real, mpiroot, mpicomm, mpierr)
214 call mpi_bcast(lut_exticesw, size(lut_exticesw), mpi_real, mpiroot, mpicomm, mpierr)
215 call mpi_bcast(lut_ssaicesw, size(lut_ssaicesw), mpi_real, mpiroot, mpicomm, mpierr)
216 call mpi_bcast(lut_asyicesw, size(lut_asyicesw), mpi_real, mpiroot, mpicomm, mpierr)
217#else
218 call mpi_bcast(band_limscldsw, size(band_limscldsw), mpi_double_precision, mpiroot, mpicomm, mpierr)
219 call mpi_bcast(lut_extliqsw, size(lut_extliqsw), mpi_double_precision, mpiroot, mpicomm, mpierr)
220 call mpi_bcast(lut_ssaliqsw, size(lut_ssaliqsw), mpi_double_precision, mpiroot, mpicomm, mpierr)
221 call mpi_bcast(lut_asyliqsw, size(lut_asyliqsw), mpi_double_precision, mpiroot, mpicomm, mpierr)
222 call mpi_bcast(lut_exticesw, size(lut_exticesw), mpi_double_precision, mpiroot, mpicomm, mpierr)
223 call mpi_bcast(lut_ssaicesw, size(lut_ssaicesw), mpi_double_precision, mpiroot, mpicomm, mpierr)
224 call mpi_bcast(lut_asyicesw, size(lut_asyicesw), mpi_double_precision, mpiroot, mpicomm, mpierr)
225#endif
226
227 ! #######################################################################################
228 !
229 ! Initialize RRTMGP DDT's...
230 !
231 ! #######################################################################################
232 call check_error_msg('sw_cloud_optics_init',sw_cloud_props%load(band_limscldsw, &
233 radliq_lwrsw, radliq_uprsw, radice_lwrsw, radice_uprsw, &
234 lut_extliqsw, lut_ssaliqsw, lut_asyliqsw, &
235 lut_exticesw, lut_ssaicesw, lut_asyicesw))
236
237 call check_error_msg('sw_cloud_optics_init',sw_cloud_props%set_ice_roughness(nrghice_fromfilesw))
238
239 ! Initialize coefficients for rain and snow(+groupel) cloud optics
240 allocate(b0r(sw_cloud_props%get_nband()),b0s(sw_cloud_props%get_nband()), &
241 b1s(sw_cloud_props%get_nband()),c0r(sw_cloud_props%get_nband()), &
242 c0s(sw_cloud_props%get_nband()))
243 b0r = (/0.496, 0.466, 0.437, 0.416, 0.391, 0.374, 0.352, &
244 0.183, 0.048, 0.012, 0.000, 0.000, 0.000, 0.000/)
245 b0s = (/0.460, 0.460, 0.460, 0.460, 0.460, 0.460, 0.460, &
246 0.460, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
247 b1s = (/0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, &
248 0.000, 1.62e-5, 1.62e-5, 0.000, 0.000, 0.000, 0.000/)
249 c0r = (/0.980, 0.975, 0.965, 0.960, 0.955, 0.952, 0.950, &
250 0.944, 0.894, 0.884, 0.883, 0.883, 0.883, 0.883/)
251 c0s = (/0.970, 0.970, 0.970, 0.970, 0.970, 0.970, 0.970, &
252 0.970, 0.970, 0.970, 0.700, 0.700, 0.700, 0.700/)
253
254 end subroutine rrtmgp_sw_cloud_optics_init
255end module rrtmgp_sw_cloud_optics
radiation_tools
This module contains tools for radiation.
Definition radiation_tools.F90:5
rrtmgp_sw_cloud_optics
This module contains the cloud optics properties calculation for RRTMGP-SW.
Definition rrtmgp_sw_cloud_optics.F90:5
rrtmgp_sw_gas_optics
This module contains a routine to initialize the k-distribution data used by the RRTMGP shortwave rad...
Definition rrtmgp_sw_gas_optics.F90:6