- Timestamp:
- Jun 23, 2023, 4:10:41 PM (12 months ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/branches/Portage_acc/libf/phylmd/ecrad/radiation_single_level.F90
r3908 r4584 95 95 96 96 !--------------------------------------------------------------------- 97 ! Allocate the arrays of a single-level type 97 98 subroutine allocate_single_level(this, ncol, nalbedobands, nemisbands, & 98 99 & use_sw_albedo_direct, is_simple_surface) … … 142 143 143 144 !--------------------------------------------------------------------- 145 ! Deallocate the arrays of a single-level type 144 146 subroutine deallocate_single_level(this) 145 147 … … 227 229 ! Temporary storage of albedo in ecRad bands 228 230 real(jprb) :: sw_albedo_band(istartcol:iendcol, config%n_bands_sw) 229 real(jprb) :: lw_albedo_band 231 real(jprb) :: lw_albedo_band(istartcol:iendcol, config%n_bands_lw) 230 232 231 233 ! Number of albedo bands … … 233 235 234 236 ! Loop indices for ecRad bands and albedo bands 235 integer :: jband, jalbedoband 237 integer :: jband, jalbedoband, jcol 236 238 237 239 real(jprb) :: hook_handle … … 239 241 if (lhook) call dr_hook('radiation_single_level:get_albedos',0,hook_handle) 240 242 241 ! Albedos/emissivities are stored in single_level in their own 242 ! spectral intervals and with column as the first dimension 243 if (config%use_canopy_full_spectrum_sw) then 244 ! Albedos provided in each g point 245 sw_albedo_diffuse = transpose(this%sw_albedo(istartcol:iendcol,:)) 246 if (allocated(this%sw_albedo_direct)) then 247 sw_albedo_direct = transpose(this%sw_albedo_direct(istartcol:iendcol,:)) 248 end if 249 elseif (.not. config%do_nearest_spectral_sw_albedo) then 250 ! Albedos averaged accurately to ecRad spectral bands 251 nalbedoband = size(config%sw_albedo_weights,1) 252 sw_albedo_band = 0.0_jprb 253 do jband = 1,config%n_bands_sw 254 do jalbedoband = 1,nalbedoband 255 if (config%sw_albedo_weights(jalbedoband,jband) /= 0.0_jprb) then 256 sw_albedo_band(istartcol:iendcol,jband) & 257 & = sw_albedo_band(istartcol:iendcol,jband) & 258 & + config%sw_albedo_weights(jalbedoband,jband) & 259 & * this%sw_albedo(istartcol:iendcol, jalbedoband) 260 end if 261 end do 262 end do 263 264 sw_albedo_diffuse = transpose(sw_albedo_band(istartcol:iendcol, & 265 & config%i_band_from_reordered_g_sw)) 266 if (allocated(this%sw_albedo_direct)) then 243 if (config%do_sw) then 244 ! Albedos/emissivities are stored in single_level in their own 245 ! spectral intervals and with column as the first dimension 246 if (config%use_canopy_full_spectrum_sw) then 247 ! Albedos provided in each g point 248 if (size(this%sw_albedo,2) /= config%n_g_sw) then 249 write(nulerr,'(a,i0,a)') '*** Error: single_level%sw_albedo does not have the expected ', & 250 & config%n_g_sw, ' spectral intervals' 251 call radiation_abort() 252 end if 253 sw_albedo_diffuse = transpose(this%sw_albedo(istartcol:iendcol,:)) 254 if (allocated(this%sw_albedo_direct)) then 255 sw_albedo_direct = transpose(this%sw_albedo_direct(istartcol:iendcol,:)) 256 end if 257 else if (.not. config%do_nearest_spectral_sw_albedo) then 258 ! Albedos averaged accurately to ecRad spectral bands 259 nalbedoband = size(config%sw_albedo_weights,1) 260 if (size(this%sw_albedo,2) /= nalbedoband) then 261 write(nulerr,'(a,i0,a)') '*** Error: single_level%sw_albedo does not have the expected ', & 262 & nalbedoband, ' bands' 263 call radiation_abort() 264 end if 265 267 266 sw_albedo_band = 0.0_jprb 268 267 do jband = 1,config%n_bands_sw 269 268 do jalbedoband = 1,nalbedoband 270 269 if (config%sw_albedo_weights(jalbedoband,jband) /= 0.0_jprb) then 271 sw_albedo_band(istartcol:iendcol,jband) & 272 & = sw_albedo_band(istartcol:iendcol,jband) & 273 & + config%sw_albedo_weights(jalbedoband,jband) & 274 & * this%sw_albedo_direct(istartcol:iendcol, jalbedoband) 270 do jcol = istartcol,iendcol 271 sw_albedo_band(jcol,jband) & 272 & = sw_albedo_band(jcol,jband) & 273 & + config%sw_albedo_weights(jalbedoband,jband) & 274 & * this%sw_albedo(jcol, jalbedoband) 275 end do 275 276 end if 276 277 end do 277 278 end do 278 sw_albedo_direct = transpose(sw_albedo_band(istartcol:iendcol, & 279 & config%i_band_from_reordered_g_sw)) 279 280 sw_albedo_diffuse = transpose(sw_albedo_band(istartcol:iendcol, & 281 & config%i_band_from_reordered_g_sw)) 282 if (allocated(this%sw_albedo_direct)) then 283 sw_albedo_band = 0.0_jprb 284 do jband = 1,config%n_bands_sw 285 do jalbedoband = 1,nalbedoband 286 if (config%sw_albedo_weights(jalbedoband,jband) /= 0.0_jprb) then 287 sw_albedo_band(istartcol:iendcol,jband) & 288 & = sw_albedo_band(istartcol:iendcol,jband) & 289 & + config%sw_albedo_weights(jalbedoband,jband) & 290 & * this%sw_albedo_direct(istartcol:iendcol, jalbedoband) 291 end if 292 end do 293 end do 294 sw_albedo_direct = transpose(sw_albedo_band(istartcol:iendcol, & 295 & config%i_band_from_reordered_g_sw)) 296 else 297 sw_albedo_direct = sw_albedo_diffuse 298 end if 280 299 else 281 sw_albedo_direct = sw_albedo_diffuse 300 ! Albedos mapped less accurately to ecRad spectral bands 301 sw_albedo_diffuse = transpose(this%sw_albedo(istartcol:iendcol, & 302 & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw))) 303 if (allocated(this%sw_albedo_direct)) then 304 sw_albedo_direct = transpose(this%sw_albedo_direct(istartcol:iendcol, & 305 & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw))) 306 else 307 sw_albedo_direct = sw_albedo_diffuse 308 end if 282 309 end if 283 else 284 ! Albedos mapped less accurately to ecRad spectral bands 285 sw_albedo_diffuse = transpose(this%sw_albedo(istartcol:iendcol, & 286 & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw))) 287 if (allocated(this%sw_albedo_direct)) then 288 sw_albedo_direct = transpose(this%sw_albedo_direct(istartcol:iendcol, & 289 & config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw))) 290 else 291 sw_albedo_direct = sw_albedo_diffuse 292 end if 293 end if 294 295 if (present(lw_albedo)) then 310 end if 311 312 if (config%do_lw .and. present(lw_albedo)) then 296 313 if (config%use_canopy_full_spectrum_lw) then 297 314 if (config%n_g_lw /= size(this%lw_emissivity,2)) then 298 write(nulerr,'(a)') '*** Error: single_level%lw_emissivity has the wrong number of spectral intervals' 299 call radiation_abort() 315 write(nulerr,'(a,i0,a)') '*** Error: single_level%lw_emissivity does not have the expected ', & 316 & config%n_g_lw, ' spectral intervals' 317 call radiation_abort() 300 318 end if 301 319 lw_albedo = 1.0_jprb - transpose(this%lw_emissivity(istartcol:iendcol,:)) … … 303 321 ! Albedos averaged accurately to ecRad spectral bands 304 322 nalbedoband = size(config%lw_emiss_weights,1) 323 if (nalbedoband /= size(this%lw_emissivity,2)) then 324 write(nulerr,'(a,i0,a)') '*** Error: single_level%lw_emissivity does not have the expected ', & 325 & nalbedoband, ' bands' 326 call radiation_abort() 327 end if 305 328 lw_albedo_band = 0.0_jprb 306 329 do jband = 1,config%n_bands_lw 307 330 do jalbedoband = 1,nalbedoband 308 331 if (config%lw_emiss_weights(jalbedoband,jband) /= 0.0_jprb) then 309 lw_albedo_band(istartcol:iendcol,jband) & 310 & = lw_albedo_band(istartcol:iendcol,jband) & 311 & + config%lw_emiss_weights(jalbedoband,jband) & 312 & * (1.0_jprb-this%lw_emissivity(istartcol:iendcol, jalbedoband)) 332 do jcol = istartcol,iendcol 333 lw_albedo_band(jcol,jband) & 334 & = lw_albedo_band(jcol,jband) & 335 & + config%lw_emiss_weights(jalbedoband,jband) & 336 & * (1.0_jprb-this%lw_emissivity(jcol, jalbedoband)) 337 end do 313 338 end if 314 339 end do … … 335 360 336 361 use yomhook, only : lhook, dr_hook 337 use radiation_c onfig,only : out_of_bounds_1d, out_of_bounds_2d362 use radiation_check, only : out_of_bounds_1d, out_of_bounds_2d 338 363 339 364 class(single_level_type), intent(inout) :: this
Note: See TracChangeset
for help on using the changeset viewer.
