diff --git a/.github/workflows/self-hosted-ci.yml b/.github/workflows/self-hosted-ci.yml new file mode 100644 index 000000000..7438197a1 --- /dev/null +++ b/.github/workflows/self-hosted-ci.yml @@ -0,0 +1,83 @@ +name: Self-hosted CI + +on: [push, pull_request, workflow_dispatch] + +jobs: + CI: + runs-on: daint + strategy: + matrix: + include: + - config_name: pgi_default_gpu + compiler_base: pgi + compiler_module: pgi + accel_module: craype-accel-nvidia60 + # Generic accelerator flag + FCFLAGS: "-O3 -acc -Mallocatable=03 -gopt" + RTE_KERNELS: openacc + - config_name: cce-cpu-icon-production + compiler_base: cray + compiler_module: cce-icon/11.0.0 + accel_module: "" + # Production flags for Icon model + RTE_KERNELS: default + FCFLAGS: "-hadd_paren -r am -Ktrap=divz,ovf,inv -hflex_mp=intolerant -hfp1 -hnoacc -O1,cache0" + - config_name: cce-openmp + compiler_base: cray + compiler_module: cce/11.0.0 + accel_module: craype-accel-nvidia60 + # OpenMP flags from Nichols Romero (Argonne) + FCFLAGS: "-hnoacc -homp -O0" + RTE_KERNELS: openacc + env: + FCFLAGS: ${{ matrix.FCFLAGS }} + RTE_KERNELS: ${{ matrix.RTE_KERNELS }} + RUN_CMD: "srun -C gpu -A pr55 -p cscsci -t 15:00" + steps: + - name: Check out code + uses: actions/checkout@v2 + - name: Create module environment + run: | + set -e + echo ' + module load daint-gpu + export PATH=$CRAY_BINUTILS_BIN:$PATH + module swap PrgEnv-cray PrgEnv-${{ matrix.compiler_base }} + module swap ${{ matrix.compiler_base }} ${{ matrix.compiler_module }} + module load ${{ matrix.accel_module }} + module load cray-netcdf cray-hdf5 + export LD_LIBRARY_PATH=$CRAY_LD_LIBRARY_PATH:$LD_LIBRARY_PATH + export CUDA_HOME=$CUDATOOLKIT_HOME + echo Compiler Environment: + module list + echo LD_LIBRARY_PATH is: + echo $LD_LIBRARY_PATH + ' > compiler_modules + - name: Stage files + run: | + set -e + cd examples/rfmip-clear-sky + source ./stage_files.sh + - name: Make + run: | + set -e + source compiler_modules + export RRTMGP_ROOT=$PWD + export FC=ftn + make clean + make libs + - name: Run + run: | + set -e + source compiler_modules + module load cray-python + export RRTMGP_ROOT=$PWD + make tests + - name: Check results + run: | + set -e + module load daint-gpu + export RRTMGP_ROOT=$PWD + # This module will unload some of the build modules, so do the checks separately + module load netcdf-python + make check diff --git a/.gitignore b/.gitignore index 8e033b713..61d99bf98 100644 --- a/.gitignore +++ b/.gitignore @@ -7,6 +7,13 @@ # Object files *.o +# Dependency files +*.d + +# Fortran module files +*.mod +*.mod.proxy + # Intel vectorization reports *.optrpt diff --git a/azure-pipelines.yml b/azure-pipelines.yml deleted file mode 100644 index 624c3af20..000000000 --- a/azure-pipelines.yml +++ /dev/null @@ -1,80 +0,0 @@ -jobs: -- job: build_daint - pool: CSCS - strategy: - matrix: - pgi_default_gpu: - compiler_base: pgi - compiler_module: pgi - accel_module: craype-accel-nvidia60 - # Generic accelerator flag - FCFLAGS: "-O3 -acc -Mallocatable=03 -gopt" - RTE_KERNELS: openacc - RUN_CMD: "srun -C gpu -A pr55 -p cscsci" - cce-cpu-icon-production: - compiler_base: cray - compiler_module: cce-icon/11.0.0 - accel_module: - # Production flags for Icon model - FCFLAGS: "-hadd_paren -r am -Ktrap=divz,ovf,inv -hflex_mp=intolerant -hfp1 -hnoacc -O1,cache0" - cce-openmp: - compiler_base: cray - compiler_module: cce/11.0.0 - accel_module: craype-accel-nvidia60 - # OpenMP flags from Nichols Romero (Argonne) - FCFLAGS: "-hnoacc -homp -O0" - RTE_KERNELS: openacc - RUN_CMD: "srun -C gpu -A pr55 -p cscsci" - maxParallel: 2 - - workspace: - clean: all - - steps: - - script: | - set -e - - echo ' - module load daint-gpu - export PATH=$CRAY_BINUTILS_BIN:$PATH - module swap PrgEnv-cray PrgEnv-$(compiler_base) - module swap $(compiler_base) $(compiler_module) - module load $(accel_module) - module load cray-netcdf cray-hdf5 - export LD_LIBRARY_PATH=$CRAY_LD_LIBRARY_PATH:$LD_LIBRARY_PATH - export CUDA_HOME=$CUDATOOLKIT_HOME - echo Compiler Environment: - module list - echo LD_LIBRARY_PATH is: - echo $LD_LIBRARY_PATH - ' > compiler_modules - - displayName: 'Create module environment' - - script: | - set -e - cd examples/rfmip-clear-sky - source ./stage_files.sh - displayName: 'Stage files' - - script: | - set -e - source compiler_modules - export RRTMGP_ROOT=$PWD - export FC=ftn - make clean - make libs - displayName: 'Make' - - script: | - set -e - source compiler_modules - module load cray-python - export RRTMGP_ROOT=$PWD - make tests - displayName: 'Run' - - script: | - set -e - module load daint-gpu - export RRTMGP_ROOT=$PWD - # This module will unload some of the build modules, so do the checks separately - module load netcdf-python - make check - displayName: 'Check results' diff --git a/examples/all-sky/mo_garand_atmos_io.F90 b/examples/all-sky/mo_garand_atmos_io.F90 index 473decba3..5b730c9ab 100644 --- a/examples/all-sky/mo_garand_atmos_io.F90 +++ b/examples/all-sky/mo_garand_atmos_io.F90 @@ -24,7 +24,6 @@ module mo_garand_atmos_io ! use mo_rte_kind, only: wp use mo_gas_concentrations, only: ty_gas_concs - use mo_rrtmgp_util_reorder,only: reorder123x312 use mo_optical_props, only: ty_optical_props ! ! NetCDF I/O routines, shared with other RTE+RRTMGP examples @@ -148,7 +147,7 @@ subroutine stop_on_err(msg) character(len=*), intent(in) :: msg if(len_trim(msg) > 0) then write(error_unit,*) trim(msg) - stop + error stop 1 end if end subroutine !-------------------------------------------------------------------------------------------------------------------- diff --git a/examples/all-sky/mo_load_cloud_coefficients.F90 b/examples/all-sky/mo_load_cloud_coefficients.F90 index f43ce712b..e7c537011 100644 --- a/examples/all-sky/mo_load_cloud_coefficients.F90 +++ b/examples/all-sky/mo_load_cloud_coefficients.F90 @@ -180,7 +180,7 @@ subroutine stop_on_err(msg) character(len=*), intent(in) :: msg if(len_trim(msg) > 0) then write (error_unit,*) trim(msg) - stop + error stop 1 end if end subroutine diff --git a/examples/mo_load_coefficients.F90 b/examples/mo_load_coefficients.F90 index 6bc0c4386..6f4a6dd17 100644 --- a/examples/mo_load_coefficients.F90 +++ b/examples/mo_load_coefficients.F90 @@ -37,7 +37,7 @@ subroutine stop_on_err(msg) if(msg /= "") then write(error_unit, *) msg - stop + error stop 1 end if end subroutine !-------------------------------------------------------------------------------------------------------------------- @@ -128,7 +128,7 @@ subroutine load_and_init(kdist, filename, available_gases) ! Read the many arrays ! gas_names = read_char_vec(ncid, 'gas_names', nabsorbers) - key_species = read_field(ncid, 'key_species', 2, nlayers, nbnds) + key_species = int(read_field(ncid, 'key_species', 2, nlayers, nbnds)) band_lims = read_field(ncid, 'bnd_limits_wavenumber', 2, nbnds) band2gpt = int(read_field(ncid, 'bnd_limits_gpt', 2, nbnds)) press_ref = read_field(ncid, 'press_ref', npress) @@ -161,9 +161,9 @@ subroutine load_and_init(kdist, filename, available_gases) scaling_gas_upper & = read_char_vec(ncid, 'scaling_gas_upper', nminor_absorber_intervals_upper) kminor_start_lower & - = read_field(ncid, 'kminor_start_lower', nminor_absorber_intervals_lower) + = int(read_field(ncid, 'kminor_start_lower', nminor_absorber_intervals_lower)) kminor_start_upper & - = read_field(ncid, 'kminor_start_upper', nminor_absorber_intervals_upper) + = int(read_field(ncid, 'kminor_start_upper', nminor_absorber_intervals_upper)) vmr_ref = read_field(ncid, 'vmr_ref', nlayers, nextabsorbers, ntemps) kmajor = read_field(ncid, 'kmajor', ngpts, nmixingfracs, npress+1, ntemps) diff --git a/examples/mo_simple_netcdf.F90 b/examples/mo_simple_netcdf.F90 index a50f22581..a3ffeaae8 100644 --- a/examples/mo_simple_netcdf.F90 +++ b/examples/mo_simple_netcdf.F90 @@ -217,24 +217,6 @@ function write_4d_field(ncid, varName, var) result(err_msg) end function write_4d_field !-------------------------------------------------------------------------------------------------------------------- - function write_string(ncid, varName, var) result(err_msg) - integer, intent(in) :: ncid - character(len=*), intent(in) :: varName - character(len=*), intent(in) :: var - character(len=128) :: err_msg - - integer :: varid - - err_msg = "" - if(nf90_inq_varid(ncid, trim(varName), varid) /= NF90_NOERR) then - err_msg = "write_field: can't find variable " // trim(varName) - return - end if - if(nf90_put_var(ncid, varid, var) /= NF90_NOERR) & - err_msg = "write_field: can't write variable " // trim(varName) - - end function write_string - !-------------------------------------------------------------------------------------------------------------------- function read_logical_vec(ncid, varName, nx) integer, intent(in) :: ncid character(len=*), intent(in) :: varName @@ -308,7 +290,7 @@ subroutine create_dim(ncid, dimName, dimLength) character(len=*), intent(in) :: dimName integer, intent(in) :: dimLength - integer :: i, dimid + integer :: dimid if(dim_exists(ncid, dimName)) then if (dimLength /= get_dim_size(ncid, trim(dimName))) & @@ -415,7 +397,7 @@ subroutine stop_on_err(msg) character(len=*), intent(in) :: msg if(len_trim(msg) > 0) then write(error_unit,*) trim(msg) - stop + error stop 1 end if end subroutine !-------------------------------------------------------------------------------------------------------------------- diff --git a/examples/rfmip-clear-sky/mo_rfmip_io.F90 b/examples/rfmip-clear-sky/mo_rfmip_io.F90 index 187d35252..ce18187d1 100644 --- a/examples/rfmip-clear-sky/mo_rfmip_io.F90 +++ b/examples/rfmip-clear-sky/mo_rfmip_io.F90 @@ -130,8 +130,10 @@ subroutine read_and_block_sw_bc(fileName, blocksize, & integer :: nblocks real(wp), dimension(ncol_l, nexp_l) :: temp2D ! --------------------------- - if(any([ncol_l, nlay_l, nexp_l] == 0)) call stop_on_err("read_and_block_sw_bc: Haven't read problem size yet.") - if(mod(ncol_l*nexp_l, blocksize) /= 0 ) call stop_on_err("read_and_block_sw_bc: number of columns doesn't fit evenly into blocks.") + if(any([ncol_l, nlay_l, nexp_l] == 0)) & + call stop_on_err("read_and_block_sw_bc: Haven't read problem size yet.") + if(mod(ncol_l*nexp_l, blocksize) /= 0 ) & + call stop_on_err("read_and_block_sw_bc: number of columns doesn't fit evenly into blocks.") nblocks = (ncol_l*nexp_l)/blocksize ! ! Check that output arrays are sized correctly : blocksize, nlay, (ncol * nexp)/blocksize @@ -374,7 +376,8 @@ subroutine read_and_block_gases_ty(fileName, blocksize, gas_names, names_in_file if(string_in_array(gas_names(g), ['h2o', 'o3 ', 'no2'])) cycle ! Read the values as a function of experiment - gas_conc_temp_1d = read_field(ncid, trim(names_in_file(g)) // "_GM", nexp_l) * read_scaling(ncid, trim(names_in_file(g)) // "_GM") + gas_conc_temp_1d = read_field (ncid, trim(names_in_file(g)) // "_GM", nexp_l) * & + read_scaling(ncid, trim(names_in_file(g)) // "_GM") do b = 1, nblocks ! Does every value in this block belong to the same experiment? @@ -431,12 +434,15 @@ subroutine unblock_and_write(fileName, varName, values) integer :: b, blocksize, nlev, nblocks real(wp), dimension(:,:), allocatable :: temp2d ! --------------------------- - if(any([ncol_l, nlay_l, nexp_l] == 0)) call stop_on_err("unblock_and_write: Haven't read problem size yet.") + if(any([ncol_l, nlay_l, nexp_l] == 0)) & + call stop_on_err("unblock_and_write: Haven't read problem size yet.") blocksize = size(values,1) nlev = size(values,2) nblocks = size(values,3) - if(nlev /= nlay_l+1) call stop_on_err('unblock_and_write: array values has the wrong number of levels') - if(blocksize*nblocks /= ncol_l*nexp_l) call stop_on_err('unblock_and_write: array values has the wrong number of blocks/size') + if(nlev /= nlay_l+1) call & + stop_on_err('unblock_and_write: array values has the wrong number of levels') + if(blocksize*nblocks /= ncol_l*nexp_l) & + call stop_on_err('unblock_and_write: array values has the wrong number of blocks/size') allocate(temp2D(nlev, ncol_l*nexp_l)) do b = 1, nblocks @@ -462,7 +468,7 @@ subroutine stop_on_err(msg) character(len=*), intent(in) :: msg if(len_trim(msg) > 0) then write(error_unit,*) trim(msg) - stop + error stop 1 end if end subroutine end module mo_rfmip_io diff --git a/extensions/cloud_optics/mo_cloud_optics.F90 b/extensions/cloud_optics/mo_cloud_optics.F90 index 3e4309eb7..d30be3cbc 100644 --- a/extensions/cloud_optics/mo_cloud_optics.F90 +++ b/extensions/cloud_optics/mo_cloud_optics.F90 @@ -412,28 +412,32 @@ function cloud_optics(this, & ! ! Array sizes ! - if(size(liqmsk,1) /= ncol .or. size(liqmsk,2) /= nlay) & - error_msg = "cloud optics: liqmask has wrong extents" - if(size(icemsk,1) /= ncol .or. size(icemsk,2) /= nlay) & - error_msg = "cloud optics: icemsk has wrong extents" - if(size(ciwp, 1) /= ncol .or. size(ciwp, 2) /= nlay) & - error_msg = "cloud optics: ciwp has wrong extents" - if(size(reliq, 1) /= ncol .or. size(reliq, 2) /= nlay) & - error_msg = "cloud optics: reliq has wrong extents" - if(size(reice, 1) /= ncol .or. size(reice, 2) /= nlay) & - error_msg = "cloud optics: reice has wrong extents" - if(optical_props%get_ncol() /= ncol .or. optical_props%get_nlay() /= nlay) & - error_msg = "cloud optics: optical_props have wrong extents" - if(error_msg /= "") return + if (check_extents) then + if(size(liqmsk,1) /= ncol .or. size(liqmsk,2) /= nlay) & + error_msg = "cloud optics: liqmask has wrong extents" + if(size(icemsk,1) /= ncol .or. size(icemsk,2) /= nlay) & + error_msg = "cloud optics: icemsk has wrong extents" + if(size(ciwp, 1) /= ncol .or. size(ciwp, 2) /= nlay) & + error_msg = "cloud optics: ciwp has wrong extents" + if(size(reliq, 1) /= ncol .or. size(reliq, 2) /= nlay) & + error_msg = "cloud optics: reliq has wrong extents" + if(size(reice, 1) /= ncol .or. size(reice, 2) /= nlay) & + error_msg = "cloud optics: reice has wrong extents" + if(optical_props%get_ncol() /= ncol .or. optical_props%get_nlay() /= nlay) & + error_msg = "cloud optics: optical_props have wrong extents" + if(error_msg /= "") return + end if ! ! Spectral consistency ! - if(.not. this%bands_are_equal(optical_props)) & - error_msg = "cloud optics: optical properties don't have the same band structure" - if(optical_props%get_nband() /= optical_props%get_ngpt() ) & - error_msg = "cloud optics: optical properties must be requested by band not g-points" - if(error_msg /= "") return + if(check_values) then + if(.not. this%bands_are_equal(optical_props)) & + error_msg = "cloud optics: optical properties don't have the same band structure" + if(optical_props%get_nband() /= optical_props%get_ngpt() ) & + error_msg = "cloud optics: optical properties must be requested by band not g-points" + if(error_msg /= "") return + end if !$acc data copyin(clwp, ciwp, reliq, reice) & !$acc create(ltau, ltaussa, ltaussag, itau, itaussa, itaussag) & diff --git a/extensions/mo_rrtmgp_clr_all_sky.F90 b/extensions/mo_rrtmgp_clr_all_sky.F90 index d1ecb15ba..203e05384 100644 --- a/extensions/mo_rrtmgp_clr_all_sky.F90 +++ b/extensions/mo_rrtmgp_clr_all_sky.F90 @@ -85,7 +85,11 @@ function rte_lw(k_dist, gas_concs, p_lay, t_lay, p_lev, & ngpt = k_dist%get_ngpt() nband = k_dist%get_nband() + !$acc kernels copyout(top_at_1) + !$omp target map(from:top_at_1) top_at_1 = p_lay(1, 1) < p_lay(1, nlay) + !$acc end kernels + !$omp end target ! ------------------------------------------------------------------------------------ ! Error checking @@ -214,7 +218,11 @@ function rte_sw(k_dist, gas_concs, p_lay, t_lay, p_lev, & ngpt = k_dist%get_ngpt() nband = k_dist%get_nband() + !$acc kernels copyout(top_at_1) + !$omp target map(from:top_at_1) top_at_1 = p_lay(1, 1) < p_lay(1, nlay) + !$acc end kernels + !$omp end target ! ------------------------------------------------------------------------------------ ! Error checking diff --git a/rrtmgp/data/rrtmgp-data-sw-g224-2018-12-04.nc b/rrtmgp/data/rrtmgp-data-sw-g224-2018-12-04.nc index 03cb071b6..2ed67d155 100644 Binary files a/rrtmgp/data/rrtmgp-data-sw-g224-2018-12-04.nc and b/rrtmgp/data/rrtmgp-data-sw-g224-2018-12-04.nc differ diff --git a/rrtmgp/kernels-openacc/mo_gas_optics_kernels.F90 b/rrtmgp/kernels-openacc/mo_gas_optics_kernels.F90 index 75cc0a5dd..b2da94b7b 100644 --- a/rrtmgp/kernels-openacc/mo_gas_optics_kernels.F90 +++ b/rrtmgp/kernels-openacc/mo_gas_optics_kernels.F90 @@ -67,14 +67,14 @@ subroutine interpolation( & ! local indexes integer :: icol, ilay, iflav, igases(2), itropo, itemp - !$acc enter data copyin(flavor,press_ref_log,temp_ref,vmr_ref,play,tlay,col_gas) - !$omp target enter data map(to:flavor, press_ref_log, temp_ref, vmr_ref, play, tlay, col_gas) - !$acc enter data create(jtemp,jpress,tropo,jeta,col_mix,fmajor,fminor) - !$omp target enter data map(alloc:jtemp, jpress, tropo, jeta, col_mix, fmajor, fminor) - !$acc enter data create(ftemp,fpress) - !$omp target enter data map(alloc:ftemp, fpress) - - !$acc parallel loop gang vector collapse(2) + !$acc data copyin(flavor,press_ref_log,temp_ref,vmr_ref,play,tlay,col_gas) & + !$acc copyout(jtemp,jpress,tropo,jeta,col_mix,fmajor,fminor) & + !$acc create(ftemp,fpress) + !$omp target data map(to:flavor, press_ref_log, temp_ref, vmr_ref, play, tlay, col_gas) & + !$omp map(alloc:jtemp, jpress, tropo, jeta, col_mix, fmajor, fminor) & + !$omp map(alloc:ftemp, fpress) + + !$acc parallel loop gang vector collapse(2) default(none) !$omp target teams distribute parallel do simd collapse(2) do ilay = 1, nlay do icol = 1, ncol @@ -96,7 +96,7 @@ subroutine interpolation( & ! loop over implemented combinations of major species ! PGI BUG WORKAROUND: if present(vmr_ref) isn't there, OpenACC runtime ! thinks it isn't present. - !$acc parallel loop gang vector collapse(4) private(igases) present(vmr_ref) + !$acc parallel loop gang vector collapse(4) default(none) private(igases) present(vmr_ref) !$omp target teams distribute parallel do simd collapse(4) private(igases) do ilay = 1, nlay do icol = 1, ncol @@ -132,12 +132,8 @@ subroutine interpolation( & end do ! icol,ilay end do - !$acc exit data delete(flavor,press_ref_log,temp_ref,vmr_ref,play,tlay,col_gas) - !$omp target exit data map(release:flavor, press_ref_log, temp_ref, vmr_ref, play, tlay, col_gas) - !$acc exit data copyout(jtemp,jpress,tropo,jeta,col_mix,fmajor,fminor) - !$omp target exit data map(from:jtemp, jpress, tropo, jeta, col_mix, fmajor, fminor) - !$acc exit data delete(ftemp,fpress) - !$omp target exit data map(release:ftemp, fpress) + !$acc end data + !$omp end target data end subroutine interpolation ! -------------------------------------------------------------------------------------- @@ -229,13 +225,19 @@ subroutine compute_tau_absorption( & ! --------------------- ! Layer limits of upper, lower atmospheres ! --------------------- + + !$acc kernels copyout(top_at_1) + !$omp target map(from:top_at_1) top_at_1 = play(1,1) < play(1, nlay) + !$acc end kernels + !$omp end target + if(top_at_1) then !$acc parallel loop !$omp target teams distribute parallel do simd do icol = 1,ncol itropo_lower(icol,2) = nlay -#ifdef _CRAYFTN +#if defined(_CRAYFTN) || defined(__NVCOMPILER) itropo_upper(icol,1) = 1 call minmaxloc(icol, tropo, play, itropo_lower(icol,1), itropo_upper(icol,2)) #else @@ -249,7 +251,7 @@ subroutine compute_tau_absorption( & !$omp target teams distribute parallel do simd do icol = 1,ncol itropo_lower(icol,1) = 1 -#ifdef _CRAYFTN +#if defined(_CRAYFTN) || defined(__NVCOMPILER) itropo_upper(icol,2) = nlay call minmaxloc(icol, tropo, play, itropo_lower(icol,2), itropo_upper(icol,1)) #else @@ -668,7 +670,7 @@ subroutine compute_Planck_source( & ! Explicitly unroll a time-consuming loop here to increase instruction-level parallelism on a GPU ! Helps to achieve higher bandwidth ! - !$acc parallel loop collapse(3) + !$acc parallel loop present(planck_function) collapse(3) !$omp target teams distribute parallel do simd collapse(3) do icol = 1, ncol, 2 do ilay = 1, nlay @@ -700,7 +702,7 @@ subroutine compute_Planck_source( & ! ! Same unrolling as mentioned before ! - !$acc parallel loop collapse(3) + !$acc parallel loop present(planck_function) collapse(3) !$omp target teams distribute parallel do simd collapse(3) do icol = 1, ncol, 2 do ilay = 1, nlay @@ -900,9 +902,9 @@ end subroutine combine_and_reorder_nstr ! compilers which do not support GPU versions ! subroutine minmaxloc(i, mask, a, minl, maxl) + implicit none !$acc routine seq !$omp declare target - implicit none integer :: i, minl, maxl logical(wl) :: mask(:,:) real(wp) :: a(:,:) diff --git a/rrtmgp/kernels/mo_gas_optics_kernels.F90 b/rrtmgp/kernels/mo_gas_optics_kernels.F90 index 857377a42..4cf77dbcd 100644 --- a/rrtmgp/kernels/mo_gas_optics_kernels.F90 +++ b/rrtmgp/kernels/mo_gas_optics_kernels.F90 @@ -300,7 +300,7 @@ subroutine gas_optical_depths_major(ncol,nlay,nbnd,ngpt,& ! local variables real(wp) :: tau_major(ngpt) ! major species optical depth ! local index - integer :: icol, ilay, iflav, ibnd, igpt, itropo + integer :: icol, ilay, iflav, ibnd, itropo integer :: gptS, gptE ! ----------------- @@ -367,8 +367,8 @@ subroutine gas_optical_depths_minor(ncol,nlay,ngpt, & ! local variables real(wp), parameter :: PaTohPa = 0.01_wp real(wp) :: vmr_fact, dry_fact ! conversion from column abundance to dry vol. mixing ratio; - real(wp) :: scaling, kminor_loc ! minor species absorption coefficient, optical depth - integer :: icol, ilay, iflav, igpt, imnr + real(wp) :: scaling ! optical depth + integer :: icol, ilay, iflav, imnr integer :: gptS, gptE real(wp), dimension(ngpt) :: tau_minor ! ----------------- @@ -455,7 +455,7 @@ subroutine compute_tau_rayleigh(ncol,nlay,nbnd,ngpt, & ! ----------------- ! local variables real(wp) :: k(ngpt) ! rayleigh scattering coefficient - integer :: icol, ilay, iflav, ibnd, igpt, gptS, gptE + integer :: icol, ilay, iflav, ibnd, gptS, gptE integer :: itropo ! ----------------- do ilay = 1, nlay diff --git a/rrtmgp/kernels/mo_rrtmgp_util_reorder_kernels.F90 b/rrtmgp/kernels/mo_rrtmgp_util_reorder_kernels.F90 index 8d876a907..e00f693a0 100644 --- a/rrtmgp/kernels/mo_rrtmgp_util_reorder_kernels.F90 +++ b/rrtmgp/kernels/mo_rrtmgp_util_reorder_kernels.F90 @@ -19,11 +19,11 @@ module mo_rrtmgp_util_reorder_kernels public contains ! ---------------------------------------------------------------------------- - subroutine reorder_123x312_kernel(d1, d2, d3, array_in, array_out) & - bind(C, name = "reorder_123x312_kernel") + subroutine reorder_123x321_kernel(d1, d2, d3, array_in, array_out) & + bind(C, name="reorder_123x321_kernel") integer, intent( in) :: d1, d2, d3 real(wp), dimension(d1, d2, d3), intent( in) :: array_in - real(wp), dimension(d3, d1, d2), intent(out) :: array_out + real(wp), dimension(d3, d2, d1), intent(out) :: array_out integer :: i1, i2, i3, i10, i30, i1diff, i3diff integer, parameter :: tile = 32 @@ -41,44 +41,6 @@ subroutine reorder_123x312_kernel(d1, d2, d3, array_in, array_out) & !$acc& copyout(array_out) & !$acc& copyin(array_in) !$acc loop gang collapse(3) - !$omp target teams distribute parallel do simd collapse(3) map(to:array_in) map(from:array_out) - do i2 = 1, d2 - do i10 = 1, d1, tile - do i30 = 1, d3, tile - - !$acc loop vector collapse(2) - do i1diff = 0, tile-1 - do i3diff = 0, tile-1 - i1 = i10 + i1diff - i3 = i30 + i3diff - if (i1 > d1 .or. i3 > d3) cycle - - array_out(i3,i1,i2) = array_in(i1,i2,i3) - end do - end do - - end do - end do - end do - !$acc end parallel - - end subroutine reorder_123x312_kernel - ! ---------------------------------------------------------------------------- - subroutine reorder_123x321_kernel(d1, d2, d3, array_in, array_out) & - bind(C, name="reorder_123x321_kernel") - integer, intent( in) :: d1, d2, d3 - real(wp), dimension(d1, d2, d3), intent( in) :: array_in - real(wp), dimension(d3, d2, d1), intent(out) :: array_out - - integer :: i1, i2, i3, i10, i30, i1diff, i3diff, idiff - integer, parameter :: tile = 32 - - ! See the comment above - ! - !$acc parallel vector_length(tile*tile) & - !$acc& copyout(array_out) & - !$acc& copyin(array_in) - !$acc loop gang collapse(3) ! private(cache(:,:)) !$omp target teams distribute parallel do simd collapse(3) map(to:array_in) map(from:array_out) do i2 = 1, d2 diff --git a/rrtmgp/mo_gas_optics_rrtmgp.F90 b/rrtmgp/mo_gas_optics_rrtmgp.F90 index 944e04a9a..61f16f778 100644 --- a/rrtmgp/mo_gas_optics_rrtmgp.F90 +++ b/rrtmgp/mo_gas_optics_rrtmgp.F90 @@ -247,7 +247,7 @@ function gas_optics_int(this, & real(wp), dimension(2,2,2,get_nflav(this),size(play,dim=1), size(play,dim=2)) :: fmajor integer, dimension(2, get_nflav(this),size(play,dim=1), size(play,dim=2)) :: jeta - integer :: ncol, nlay, ngpt, nband, ngas, nflav + integer :: ncol, nlay, ngpt, nband ! ---------------------------------------------------------- ncol = size(play,dim=1) nlay = size(play,dim=2) @@ -543,12 +543,15 @@ function compute_gas_taus(this, & ! Compute dry air column amounts (number of molecule per cm^2) if user hasn't provided them ! idx_h2o = string_loc_in_array('h2o', this%gas_names) - col_dry_wk => col_dry_arr - !$acc enter data create(col_dry_wk, col_dry_arr, col_gas) - !$omp target enter data map(alloc:col_dry_wk, col_dry_arr, col_gas) + !$acc enter data create(col_gas) + !$omp target enter data map(alloc:col_gas) if (present(col_dry)) then + !$acc enter data copyin(col_dry) + !$omp target enter data map(to:col_dry) col_dry_wk => col_dry else + !$acc enter data create(col_dry_arr) + !$omp target enter data map(alloc:col_dry_arr) col_dry_arr = get_col_dry(vmr(:,:,idx_h2o), plev) ! dry air column amounts computation col_dry_wk => col_dry_arr end if @@ -635,8 +638,8 @@ function compute_gas_taus(this, & jeta,jtemp,jpress, & tau) if (allocated(this%krayl)) then - !$acc enter data attach(col_dry_wk) copyin(this%krayl) - !$omp target enter data map(to:col_dry_wk) map(to:this%krayl) + !$acc enter data copyin(this%krayl) + !$omp target enter data map(to:this%krayl) call compute_tau_rayleigh( & !Rayleigh scattering optical depths ncol,nlay,nband,ngpt, & ngas,nflav,neta,npres,ntemp, & ! dimensions @@ -646,8 +649,8 @@ function compute_gas_taus(this, & idx_h2o, col_dry_wk,col_gas, & fminor,jeta,tropo,jtemp, & ! local input tau_rayleigh) - !$acc exit data detach(col_dry_wk) delete(this%krayl) - !$omp target exit data map(from:col_dry_wk) map(release:this%krayl) + !$acc exit data delete(this%krayl) + !$omp target exit data map(release:this%krayl) end if if (error_msg /= '') return @@ -657,8 +660,8 @@ function compute_gas_taus(this, & !$omp target exit data map(release:play, tlay, plev) !$acc exit data delete(tau, tau_rayleigh) !$omp target exit data map(release:tau, tau_rayleigh) - !$acc exit data delete(col_dry_wk, col_dry_arr, col_gas, col_mix, fminor) - !$omp target exit data map(release:col_dry_wk, col_dry_arr, col_gas, col_mix, fminor) + !$acc exit data delete(col_dry_wk, col_gas, col_mix, fminor) + !$omp target exit data map(release:col_dry_wk, col_gas, col_mix, fminor) !$acc exit data delete(this%gpoint_flavor) !$omp target exit data map(release:this%gpoint_flavor) !$acc exit data copyout(jtemp, jpress, jeta, tropo, fmajor) @@ -1224,6 +1227,8 @@ function init_abs_coeffs(this, & allocate(this%krayl(size(rayl_lower,dim=1),size(rayl_lower,dim=2),size(rayl_lower,dim=3),2)) this%krayl(:,:,:,1) = rayl_lower this%krayl(:,:,:,2) = rayl_upper + !$acc enter data copyin(this%krayl) + !$omp target enter data map(to:this%krayl) end if ! ---- post processing ---- @@ -1601,6 +1606,8 @@ subroutine create_idx_minor(gas_names, & idx_minor_atm(imnr) = string_loc_in_array(gas_minor(idx_mnr), gas_names) enddo + !$acc enter data copyin(idx_minor_atm) + !$omp target enter data map(to:idx_minor_atm) end subroutine create_idx_minor ! --------------------------------------------------------------------------------------- @@ -1622,6 +1629,8 @@ subroutine create_idx_minor_scaling(gas_names, & idx_minor_scaling_atm(imnr) = string_loc_in_array(scaling_gas_atm(imnr), gas_names) enddo + !$acc enter data copyin(idx_minor_scaling_atm) + !$omp target enter data map(to:idx_minor_scaling_atm) end subroutine create_idx_minor_scaling ! --------------------------------------------------------------------------------------- subroutine create_key_species_reduce(gas_names,gas_names_red, & @@ -1772,9 +1781,10 @@ subroutine reduce_minor_arrays(available_gases, & endif enddo endif - !$acc enter data copyin(kminor_atm_red) - !$omp target enter data map(to:kminor_atm_red) - + !$acc enter data copyin(kminor_atm_red, kminor_start_atm_red, minor_limits_gpt_atm_red, & + !$acc minor_scales_with_density_atm_red, scale_by_complement_atm_red) + !$omp target enter data map(to:kminor_atm_red, kminor_start_atm_red, minor_limits_gpt_atm_red, & + !$omp minor_scales_with_density_atm_red, scale_by_complement_atm_red) end subroutine reduce_minor_arrays ! --------------------------------------------------------------------------------------- diff --git a/rrtmgp/mo_rrtmgp_util_reorder.F90 b/rrtmgp/mo_rrtmgp_util_reorder.F90 index bfb7a24e0..3411c6a54 100644 --- a/rrtmgp/mo_rrtmgp_util_reorder.F90 +++ b/rrtmgp/mo_rrtmgp_util_reorder.F90 @@ -17,21 +17,11 @@ module mo_rrtmgp_util_reorder use mo_rte_kind, only: wp use mo_rrtmgp_util_reorder_kernels, & - only: reorder_123x312_kernel, reorder_123x321_kernel + only: reorder_123x321_kernel implicit none private - public :: reorder123x312, reorder123x321 + public :: reorder123x321 contains - ! ------------------------------------------------------------------------------------------------- - ! - ! (x,y,z) -> (z,x,y) - ! - subroutine reorder123x312(array, array_out) - real(wp), dimension(:,:,:), intent(in ) :: array - real(wp), dimension(:,:,:), intent(out) :: array_out - - call reorder_123x312_kernel(size(array,dim=1), size(array,dim=2), size(array,dim=3), array, array_out) - end subroutine reorder123x312 ! ------------------------------------------------------------------------------------------------- ! ! (x,y,z) -> (z,y,x) diff --git a/rte/kernels-openacc/mo_optical_props_kernels.F90 b/rte/kernels-openacc/mo_optical_props_kernels.F90 index 711a64778..50455fb35 100644 --- a/rte/kernels-openacc/mo_optical_props_kernels.F90 +++ b/rte/kernels-openacc/mo_optical_props_kernels.F90 @@ -64,9 +64,9 @@ subroutine delta_scale_2str_f_k(ncol, nlay, ngpt, tau, ssa, g, f) & !$acc& copyin(f(:ncol,:nlay,:ngpt)) & !$acc& copy(g(:ncol,:nlay,:ngpt)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(tofrom:ssa(:ncol, :nlay, :ngpt), tau(:ncol, :nlay, :ngpt)) & - !$omp& map(to:f(:ncol, :nlay, :ngpt)) & - !$omp& map(tofrom:g(:ncol, :nlay, :ngpt)) + !$omp& map(tofrom:ssa, tau) & + !$omp& map(to:f) & + !$omp& map(tofrom:g) do igpt = 1, ngpt do ilay = 1, nlay do icol = 1, ncol @@ -97,7 +97,7 @@ subroutine delta_scale_2str_k(ncol, nlay, ngpt, tau, ssa, g) & !$acc parallel loop collapse(3) & !$acc& copy(tau(:ncol,:nlay,:ngpt),ssa(:ncol,:nlay,:ngpt),g(:ncol,:nlay,:ngpt)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(tofrom:tau(:ncol, :nlay, :ngpt), ssa(:ncol, :nlay, :ngpt), g(:ncol, :nlay, :ngpt)) + !$omp& map(tofrom:tau, ssa, g) do igpt = 1, ngpt do ilay = 1, nlay do icol = 1, ncol @@ -144,8 +144,8 @@ subroutine increment_1scalar_by_1scalar(ncol, nlay, ngpt, & !$acc& copyin(tau2(:ncol,:nlay,:ngpt)) & !$acc& copy(tau1(:ncol,:nlay,:ngpt)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(to:tau2(:ncol, :nlay, :ngpt)) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) + !$omp& map(to:tau2) & + !$omp& map(tofrom:tau1) do igpt = 1, ngpt do ilay = 1, nlay do icol = 1, ncol @@ -172,9 +172,9 @@ subroutine increment_1scalar_by_2stream(ncol, nlay, ngpt, & !$acc& copy(tau1(:ncol,:nlay,:ngpt)) & !$acc& copyin(ssa2(:ncol,:nlay,:ngpt)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(to:tau2(:ncol, :nlay, :ngpt)) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:ssa2(:ncol, :nlay, :ngpt)) + !$omp& map(to:tau2) & + !$omp& map(tofrom:tau1) & + !$omp& map(to:ssa2) do igpt = 1, ngpt do ilay = 1, nlay do icol = 1, ncol @@ -202,9 +202,9 @@ subroutine increment_1scalar_by_nstream(ncol, nlay, ngpt, & !$acc& copy(tau1(:ncol,:nlay,:ngpt)) & !$acc& copyin(ssa2(:ncol,:nlay,:ngpt)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(to:tau2(:ncol, :nlay, :ngpt)) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:ssa2(:ncol, :nlay, :ngpt)) + !$omp& map(to:tau2) & + !$omp& map(tofrom:tau1) & + !$omp& map(to:ssa2) do igpt = 1, ngpt do ilay = 1, nlay do icol = 1, ncol @@ -234,9 +234,9 @@ subroutine increment_2stream_by_1scalar(ncol, nlay, ngpt, & !$acc& copyin(tau2(:ncol,:nlay,:ngpt)) & !$acc& copy(tau1(:ncol,:nlay,:ngpt)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(tofrom:ssa1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:tau2(:ncol, :nlay, :ngpt)) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) + !$omp& map(tofrom:ssa1) & + !$omp& map(to:tau2) & + !$omp& map(tofrom:tau1) do igpt = 1, ngpt do ilay = 1, nlay do icol = 1, ncol @@ -270,10 +270,10 @@ subroutine increment_2stream_by_2stream(ncol, nlay, ngpt, & !$acc& copyin(ssa2(:ncol,:nlay,:ngpt),tau2(:ncol,:nlay,:ngpt)) & !$acc& copy(tau1(:ncol,:nlay,:ngpt),g1(:ncol,:nlay,:ngpt)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(to:g2(:ncol, :nlay, :ngpt)) & - !$omp& map(tofrom:ssa1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:ssa2(:ncol, :nlay, :ngpt), tau2(:ncol, :nlay, :ngpt)) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt), g1(:ncol, :nlay, :ngpt)) + !$omp& map(to:g2) & + !$omp& map(tofrom:ssa1) & + !$omp& map(to:ssa2, tau2) & + !$omp& map(tofrom:tau1, g1) do igpt = 1, ngpt do ilay = 1, nlay do icol = 1, ncol @@ -316,10 +316,10 @@ subroutine increment_2stream_by_nstream(ncol, nlay, ngpt, nmom2, & !$acc& copyin(ssa2(:ncol,:nlay,:ngpt),tau2(:ncol,:nlay,:ngpt)) & !$acc& copy(tau1(:ncol,:nlay,:ngpt),g1(:ncol,:nlay,:ngpt)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(to:p2(:1, :ncol, :nlay, :ngpt)) & - !$omp& map(tofrom:ssa1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:ssa2(:ncol, :nlay, :ngpt), tau2(:ncol, :nlay, :ngpt)) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt), g1(:ncol, :nlay, :ngpt)) + !$omp& map(to:p2) & + !$omp& map(tofrom:ssa1) & + !$omp& map(to:ssa2, tau2) & + !$omp& map(tofrom:tau1, g1) do igpt = 1, ngpt do ilay = 1, nlay do icol = 1, ncol @@ -360,9 +360,9 @@ subroutine increment_nstream_by_1scalar(ncol, nlay, ngpt, & !$acc& copyin(tau2(:ncol,:nlay,:ngpt)) & !$acc& copy(tau1(:ncol,:nlay,:ngpt)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(tofrom:ssa1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:tau2(:ncol, :nlay, :ngpt)) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) + !$omp& map(tofrom:ssa1) & + !$omp& map(to:tau2) & + !$omp& map(tofrom:tau1) do igpt = 1, ngpt do ilay = 1, nlay do icol = 1, ncol @@ -389,7 +389,7 @@ subroutine increment_nstream_by_2stream(ncol, nlay, ngpt, nmom1, & integer :: icol, ilay, igpt real(wp) :: tau12, tauscat12 - real(wp), dimension(nmom1) :: temp_moms ! TK + real(wp) :: temp_mom ! TK integer :: imom !TK ! -------------- ! -------------- @@ -399,15 +399,13 @@ subroutine increment_nstream_by_2stream(ncol, nlay, ngpt, nmom1, & !$acc& copyin(ssa2(:ncol,:nlay,:ngpt)) & !$acc& copy(tau1(:ncol,:nlay,:ngpt)) & !$acc& copyin(g2(:ncol,:nlay,:ngpt)) & - !$acc& private(temp_moms) & !$acc& copyin(tau2(:ncol,:nlay,:ngpt)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(tofrom:p1(:nmom1, :ncol, :nlay, :ngpt), ssa1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:ssa2(:ncol, :nlay, :ngpt)) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:g2(:ncol, :nlay, :ngpt)) & - !$omp& private(temp_moms) & - !$omp& map(to:tau2(:ncol, :nlay, :ngpt)) + !$omp& map(tofrom:p1, ssa1) & + !$omp& map(to:ssa2) & + !$omp& map(tofrom:tau1) & + !$omp& map(to:g2) & + !$omp& map(to:tau2) do igpt = 1, ngpt do ilay = 1, nlay do icol = 1, ncol @@ -419,13 +417,13 @@ subroutine increment_nstream_by_2stream(ncol, nlay, ngpt, nmom1, & ! Here assume Henyey-Greenstein ! if(tauscat12 > eps) then - temp_moms(1) = g2(icol,ilay,igpt) - do imom = 2, nmom1 - temp_moms(imom) = temp_moms(imom-1) * g2(icol,ilay,igpt) + temp_mom = g2(icol,ilay,igpt) + do imom = 1, nmom1 + p1(imom, icol,ilay,igpt) = & + (tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) * p1(imom, icol,ilay,igpt) + & + tau2(icol,ilay,igpt) * ssa2(icol,ilay,igpt) * temp_mom) / tauscat12 + temp_mom = temp_mom * g2(icol,ilay,igpt) end do - p1(1:nmom1, icol,ilay,igpt) = & - (tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) * p1(1:nmom1, icol,ilay,igpt) + & - tau2(icol,ilay,igpt) * ssa2(icol,ilay,igpt) * temp_moms(1:nmom1) ) / tauscat12 ssa1(icol,ilay,igpt) = tauscat12 / tau12 tau1(icol,ilay,igpt) = tau12 end if @@ -458,10 +456,10 @@ subroutine increment_nstream_by_nstream(ncol, nlay, ngpt, nmom1, nmom2, & !$acc& copyin(ssa2(:ncol,:nlay,:ngpt),tau2(:ncol,:nlay,:ngpt)) & !$acc& copy(tau1(:ncol,:nlay,:ngpt),p1(:mom_lim,:ncol,:nlay,:ngpt)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(to:p2(:mom_lim, :ncol, :nlay, :ngpt)) & - !$omp& map(tofrom:ssa1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:ssa2(:ncol, :nlay, :ngpt), tau2(:ncol, :nlay, :ngpt)) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt), p1(:mom_lim, :ncol, :nlay, :ngpt)) + !$omp& map(to:p2) & + !$omp& map(tofrom:ssa1) & + !$omp& map(to:ssa2, tau2) & + !$omp& map(tofrom:tau1, p1) do igpt = 1, ngpt do ilay = 1, nlay do icol = 1, ncol @@ -505,9 +503,9 @@ subroutine inc_1scalar_by_1scalar_bybnd(ncol, nlay, ngpt, & !$acc& copy(tau1(:ncol,:nlay,:ngpt)) & !$acc& copyin(gpt_lims(:,:nbnd)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(to:tau2(:ncol, :nlay, :nbnd)) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:gpt_lims(:, :nbnd)) + !$omp& map(to:tau2) & + !$omp& map(tofrom:tau1) & + !$omp& map(to:gpt_lims) do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol @@ -537,9 +535,9 @@ subroutine inc_1scalar_by_2stream_bybnd(ncol, nlay, ngpt, & !$acc& copy(tau1(:ncol,:nlay,:ngpt)) & !$acc& copyin(gpt_lims(:,:nbnd)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(to:tau2(:ncol, :nlay, :nbnd), ssa2(:ncol, :nlay, :nbnd)) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:gpt_lims(:, :nbnd)) + !$omp& map(to:tau2, ssa2) & + !$omp& map(tofrom:tau1) & + !$omp& map(to:gpt_lims) do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol @@ -569,9 +567,9 @@ subroutine inc_1scalar_by_nstream_bybnd(ncol, nlay, ngpt, & !$acc& copy(tau1(:ncol,:nlay,:ngpt)) & !$acc& copyin(ssa2(:ncol,:nlay,:nbnd)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(to:gpt_lims(:, :nbnd), tau2(:ncol, :nlay, :nbnd)) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:ssa2(:ncol, :nlay, :nbnd)) + !$omp& map(to:gpt_lims, tau2) & + !$omp& map(tofrom:tau1) & + !$omp& map(to:ssa2) do igpt = 1 , ngpt do ilay = 1 , nlay do icol = 1 , ncol @@ -605,10 +603,10 @@ subroutine inc_2stream_by_1scalar_bybnd(ncol, nlay, ngpt, & !$acc& copy(ssa1(:ncol,:nlay,:ngpt)) & !$acc& copyin(gpt_lims(:,:nbnd)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:tau2(:ncol, :nlay, :nbnd)) & - !$omp& map(tofrom:ssa1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:gpt_lims(:, :nbnd)) + !$omp& map(tofrom:tau1) & + !$omp& map(to:tau2) & + !$omp& map(tofrom:ssa1) & + !$omp& map(to:gpt_lims) do igpt = 1 , ngpt do ilay = 1, nlay do icol = 1, ncol @@ -645,12 +643,12 @@ subroutine inc_2stream_by_2stream_bybnd(ncol, nlay, ngpt, & !$acc& copy(g1(:ncol,:nlay,:ngpt)) & !$acc& copyin(g2(:ncol,:nlay,:nbnd)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:tau2(:ncol, :nlay, :nbnd), ssa2(:ncol, :nlay, :nbnd)) & - !$omp& map(tofrom:ssa1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:gpt_lims(:, :nbnd)) & - !$omp& map(tofrom:g1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:g2(:ncol, :nlay, :nbnd)) + !$omp& map(tofrom:tau1) & + !$omp& map(to:tau2, ssa2) & + !$omp& map(tofrom:ssa1) & + !$omp& map(to:gpt_lims) & + !$omp& map(tofrom:g1) & + !$omp& map(to:g2) do igpt = 1 , ngpt do ilay = 1, nlay do icol = 1, ncol @@ -696,11 +694,11 @@ subroutine inc_2stream_by_nstream_bybnd(ncol, nlay, ngpt, nmom2, & !$acc& copyin(p2(:1,:ncol,:nlay,:nbnd),gpt_lims(:,:nbnd)) & !$acc& copy(g1(:ncol,:nlay,:ngpt)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:tau2(:ncol, :nlay, :nbnd), ssa2(:ncol, :nlay, :nbnd)) & - !$omp& map(tofrom:ssa1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:p2(:1, :ncol, :nlay, :nbnd), gpt_lims(:, :nbnd)) & - !$omp& map(tofrom:g1(:ncol, :nlay, :ngpt)) + !$omp& map(tofrom:tau1) & + !$omp& map(to:tau2, ssa2) & + !$omp& map(tofrom:ssa1) & + !$omp& map(to:p2, gpt_lims) & + !$omp& map(tofrom:g1) do igpt = 1 , ngpt do ilay = 1, nlay do icol = 1, ncol @@ -744,10 +742,10 @@ subroutine inc_nstream_by_1scalar_bybnd(ncol, nlay, ngpt, & !$acc& copy(ssa1(:ncol,:nlay,:ngpt)) & !$acc& copyin(gpt_lims(:,:nbnd)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:tau2(:ncol, :nlay, :nbnd)) & - !$omp& map(tofrom:ssa1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:gpt_lims(:, :nbnd)) + !$omp& map(tofrom:tau1) & + !$omp& map(to:tau2) & + !$omp& map(tofrom:ssa1) & + !$omp& map(to:gpt_lims) do igpt = 1 , ngpt do ilay = 1, nlay do icol = 1, ncol @@ -778,7 +776,7 @@ subroutine inc_nstream_by_2stream_bybnd(ncol, nlay, ngpt, nmom1, & integer :: icol, ilay, igpt, ibnd real(wp) :: tau12, tauscat12 - real(wp), dimension(nmom1) :: temp_moms ! TK + real(wp) :: temp_mom ! TK integer :: imom !TK !$acc parallel loop collapse(3) & @@ -786,15 +784,13 @@ subroutine inc_nstream_by_2stream_bybnd(ncol, nlay, ngpt, nmom1, & !$acc& copyin(ssa2(:ncol,:nlay,:nbnd)) & !$acc& copy(ssa1(:ncol,:nlay,:ngpt),p1(:nmom1,:ncol,:nlay,:ngpt)) & !$acc& copyin(tau2(:ncol,:nlay,:nbnd)) & - !$acc& private(temp_moms) & !$acc& copyin(gpt_lims(:,:nbnd),g2(:ncol,:nlay,:nbnd)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:ssa2(:ncol, :nlay, :nbnd)) & - !$omp& map(tofrom:ssa1(:ncol, :nlay, :ngpt), p1(:nmom1, :ncol, :nlay, :ngpt)) & - !$omp& map(to:tau2(:ncol, :nlay, :nbnd)) & - !$omp& private(temp_moms) & - !$omp& map(to:gpt_lims(:, :nbnd), g2(:ncol, :nlay, :nbnd)) + !$omp& map(tofrom:tau1) & + !$omp& map(to:ssa2) & + !$omp& map(tofrom:ssa1, p1) & + !$omp& map(to:tau2) & + !$omp& map(to:gpt_lims, g2) do igpt = 1 , ngpt do ilay = 1, nlay do icol = 1, ncol @@ -807,13 +803,13 @@ subroutine inc_nstream_by_2stream_bybnd(ncol, nlay, ngpt, nmom1, & ! ! Here assume Henyey-Greenstein ! - temp_moms(1) = g2(icol,ilay,ibnd) - do imom = 2, nmom1 - temp_moms(imom) = temp_moms(imom-1) * g2(icol,ilay,ibnd) + temp_mom = g2(icol,ilay,ibnd) + do imom = 1, nmom1 + p1(imom, icol,ilay,igpt) = & + (tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) * p1(imom, icol,ilay,igpt) + & + tau2(icol,ilay,ibnd) * ssa2(icol,ilay,ibnd) * temp_mom ) / max(eps,tauscat12) + temp_mom = temp_mom * g2(icol,ilay,igpt) end do - p1(1:nmom1, icol,ilay,igpt) = & - (tau1(icol,ilay,igpt) * ssa1(icol,ilay,igpt) * p1(1:nmom1, icol,ilay,igpt) + & - tau2(icol,ilay,ibnd) * ssa2(icol,ilay,ibnd) * temp_moms(1:nmom1) ) / max(eps,tauscat12) ssa1(icol,ilay,igpt) = tauscat12 / max(eps,tau12) tau1(icol,ilay,igpt) = tau12 endif @@ -850,13 +846,13 @@ subroutine inc_nstream_by_nstream_bybnd(ncol, nlay, ngpt, nmom1, nmom2, & !$acc& copy(p1(:mom_lim,:ncol,:nlay,:ngpt)) & !$acc& copyin(gpt_lims(:,:nbnd)) !$omp target teams distribute parallel do simd collapse(3) & - !$omp& map(to:p2(:mom_lim, :ncol, :nlay, :nbnd)) & - !$omp& map(tofrom:ssa1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:ssa2(:ncol, :nlay, :nbnd)) & - !$omp& map(tofrom:tau1(:ncol, :nlay, :ngpt)) & - !$omp& map(to:tau2(:ncol, :nlay, :nbnd)) & - !$omp& map(tofrom:p1(:mom_lim, :ncol, :nlay, :ngpt)) & - !$omp& map(to:gpt_lims(:, :nbnd)) + !$omp& map(to:p2) & + !$omp& map(tofrom:ssa1) & + !$omp& map(to:ssa2) & + !$omp& map(tofrom:tau1) & + !$omp& map(to:tau2) & + !$omp& map(tofrom:p1) & + !$omp& map(to:gpt_lims) do igpt = 1 , ngpt do ilay = 1, nlay do icol = 1, ncol diff --git a/rte/kernels-openacc/mo_rte_solver_kernels.F90 b/rte/kernels-openacc/mo_rte_solver_kernels.F90 index 719922a92..4cefa958d 100644 --- a/rte/kernels-openacc/mo_rte_solver_kernels.F90 +++ b/rte/kernels-openacc/mo_rte_solver_kernels.F90 @@ -127,8 +127,6 @@ subroutine lw_solver_noscat(ncol, nlay, ngpt, top_at_1, D, weight, !$acc enter data copyin(d,tau,sfc_src,sfc_emis,lev_source_dec,lev_source_inc,lay_source,radn_dn) !$omp target enter data map(to:d, tau, sfc_src, sfc_emis, lev_source_dec, lev_source_inc, lay_source, radn_dn) - !$acc enter data attach(lev_source_up,lev_source_dn) - !$omp target enter data map(to:lev_source_up, lev_source_dn) !$acc enter data create( tau_loc,trans,source_dn,source_up,radn_up) !$omp target enter data map(alloc:tau_loc,trans,source_dn,source_up,radn_up) @@ -198,7 +196,7 @@ subroutine lw_solver_noscat(ncol, nlay, ngpt, top_at_1, D, weight, ! ! Surface reflection and emission ! - !$acc parallel loop collapse(2) + !$acc parallel loop collapse(2) no_create(gpt_Jac) !$omp target teams distribute parallel do simd collapse(2) do igpt = 1, ngpt do icol = 1, ncol @@ -265,8 +263,6 @@ subroutine lw_solver_noscat(ncol, nlay, ngpt, top_at_1, D, weight, !$omp target exit data map(from:radn_dn,radn_up) !$acc exit data delete( d,tau,sfc_src,sfc_emis,lev_source_dec,lev_source_inc,lay_source,tau_loc,trans,source_dn,source_up) !$omp target exit data map(release:d, tau, sfc_src, sfc_emis, lev_source_dec, lev_source_inc, lay_source, tau_loc, trans, source_dn, source_up) - !$acc exit data detach( lev_source_up,lev_source_dn) - !$omp target exit data map(from:lev_source_up, lev_source_dn) !$acc exit data delete( An, Cn) if(do_rescaling) !$omp target exit data map(release:An, Cn) if(do_rescaling) @@ -371,7 +367,7 @@ subroutine lw_solver_noscat_GaussQuad(ncol, nlay, ngpt, top_at_1, nmus, Ds, weig radn_up, radn_dn, & do_Jacobians, sfc_srcJac, radn_upJac, & do_rescaling, ssa, g) - !$acc parallel loop collapse(3) + !$acc parallel loop collapse(3) no_create(flux_upJac) !$omp target teams distribute parallel do simd collapse(3) do igpt = 1, ngpt do ilev = 1, nlay+1 @@ -717,7 +713,7 @@ subroutine lw_transport_noscat_up(ncol, nlay, ngpt, & real(wp), dimension(ncol,nlay ,ngpt), intent(in ) :: source_up ! Diffuse radiation emitted by the layer real(wp), dimension(ncol,nlay+1,ngpt), intent( out) :: radn_up ! Radiances [W/m2-str] logical(wl), intent(in ) :: do_Jacobians - real(wp), dimension(ncol,nlay+1,ngpt), intent( out) :: radn_upJac ! surface temperature Jacobian of Radiances [W/m2-str / K] + real(wp), dimension(ncol,nlay+1,ngpt), intent(inout) :: radn_upJac ! surface temperature Jacobian of Radiances [W/m2-str / K] ! Local variables integer :: igpt, ilev, icol ! --------------------------------------------------- @@ -726,7 +722,7 @@ subroutine lw_transport_noscat_up(ncol, nlay, ngpt, & ! ! Top of domain is index 1 ! - !$acc parallel loop collapse(2) + !$acc parallel loop collapse(2) no_create(radn_upJac) !$omp target teams distribute parallel do simd collapse(2) do igpt = 1, ngpt do icol = 1, ncol @@ -745,7 +741,7 @@ subroutine lw_transport_noscat_up(ncol, nlay, ngpt, & ! ! Top of domain is index nlay+1 ! - !$acc parallel loop collapse(2) + !$acc parallel loop collapse(2) no_create(radn_upJac) !$omp target teams distribute parallel do simd collapse(2) do igpt = 1, ngpt do icol = 1, ncol @@ -1418,7 +1414,7 @@ subroutine lw_transport_1rescl(ncol, nlay, ngpt, top_at_1, & ! Top of domain is index 1 ! ! Downward propagation - !$acc parallel loop collapse(2) + !$acc parallel loop collapse(2) no_create(radn_up_Jac) !$omp target teams distribute parallel do simd collapse(2) do igpt = 1, ngpt do icol = 1, ncol @@ -1453,7 +1449,7 @@ subroutine lw_transport_1rescl(ncol, nlay, ngpt, top_at_1, & enddo enddo else - !$acc parallel loop collapse(2) + !$acc parallel loop collapse(2) no_create(radn_up_Jac) !$omp target teams distribute parallel do simd collapse(2) do igpt = 1, ngpt do icol = 1, ncol diff --git a/rte/kernels/mo_rte_solver_kernels.F90 b/rte/kernels/mo_rte_solver_kernels.F90 index f20557cda..a2333f652 100644 --- a/rte/kernels/mo_rte_solver_kernels.F90 +++ b/rte/kernels/mo_rte_solver_kernels.F90 @@ -387,7 +387,7 @@ pure subroutine sw_solver_noscat(ncol, nlay, ngpt, & real(wp), dimension(ncol ), intent( in) :: mu0 ! cosine of solar zenith angle real(wp), dimension(ncol,nlay+1,ngpt), intent(inout) :: flux_dir ! Direct-beam flux, spectral [W/m2] ! Top level must contain incident flux boundary condition - integer :: icol, ilev, igpt + integer :: ilev, igpt real(wp) :: mu0_inv(ncol) ! ------------------------------------ @@ -562,7 +562,7 @@ subroutine lw_transport_noscat_up(ncol, nlay, top_at_1, & real(wp), dimension(ncol,nlay ), intent(in ) :: source_up ! Diffuse radiation emitted by the layer real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_up ! Radiances [W/m2-str] Top level must contain incident flux boundary condition logical(wl), intent(in ) :: do_Jacobians - real(wp), dimension(ncol,nlay+1), intent( out) :: radn_upJac ! surface temperature Jacobian of Radiances [W/m2-str / K] + real(wp), dimension(ncol,nlay+1), intent(inout) :: radn_upJac ! surface temperature Jacobian of Radiances [W/m2-str / K] ! --------------------------------------------------- ! Local variables diff --git a/rte/mo_optical_props.F90 b/rte/mo_optical_props.F90 index d254b2f49..b2fb5f4c9 100644 --- a/rte/mo_optical_props.F90 +++ b/rte/mo_optical_props.F90 @@ -40,6 +40,7 @@ ! ------------------------------------------------------------------------------------------------- module mo_optical_props use mo_rte_kind, only: wp + use mo_rte_config, only: check_extents, check_values use mo_rte_util_array, only: any_vals_less_than, any_vals_outside, extents_are use mo_optical_props_kernels, only: & increment_1scalar_by_1scalar, increment_1scalar_by_2stream, increment_1scalar_by_nstream, & @@ -232,14 +233,20 @@ function init_base(this, band_lims_wvn, band_lims_gpt, name) result(err_message) err_message = "" if(size(band_lims_wvn,1) /= 2) & err_message = "optical_props%init(): band_lims_wvn 1st dim should be 2" - if(any_vals_less_than(band_lims_wvn, 0._wp) ) & - err_message = "optical_props%init(): band_lims_wvn has values < 0., respectively" + if (check_values) then + if(any_vals_less_than(band_lims_wvn, 0._wp) ) & + err_message = "optical_props%init(): band_lims_wvn has values < 0., respectively" + end if if(err_message /="") return if(present(band_lims_gpt)) then - if(.not. extents_are(band_lims_gpt, 2, size(band_lims_wvn,2))) & - err_message = "optical_props%init(): band_lims_gpt size inconsistent with band_lims_wvn" - if(any(band_lims_gpt < 1) ) & - err_message = "optical_props%init(): band_lims_gpt has values < 1" + if (check_extents) then + if(.not. extents_are(band_lims_gpt, 2, size(band_lims_wvn,2))) & + err_message = "optical_props%init(): band_lims_gpt size inconsistent with band_lims_wvn" + end if + if (check_values) then + if(any(band_lims_gpt < 1) ) & + err_message = "optical_props%init(): band_lims_gpt has values < 1" + end if if(err_message /= "") return band_lims_gpt_lcl(:,:) = band_lims_gpt(:,:) @@ -546,14 +553,18 @@ function delta_scale_2str(this, for) result(err_message) err_message = "" if(present(for)) then - if(.not. extents_are(for, ncol, nlay, ngpt)) then + if (check_extents) then + if(.not. extents_are(for, ncol, nlay, ngpt)) then err_message = "delta_scale: dimension of 'for' don't match optical properties arrays" return end if + end if + if (check_values) then if(any_vals_outside(for, 0._wp, 1._wp)) then err_message = "delta_scale: values of 'for' out of bounds [0,1]" return end if + end if call delta_scale_2str_kernel(ncol, nlay, ngpt, this%tau, this%ssa, this%g, for) else call delta_scale_2str_kernel(ncol, nlay, ngpt, this%tau, this%ssa, this%g) @@ -583,8 +594,10 @@ function validate_1scalar(this) result(err_message) err_message = "validate: tau not allocated/initialized" return end if - if(any_vals_less_than(this%tau, 0._wp)) & + if (check_values) then + if(any_vals_less_than(this%tau, 0._wp)) & err_message = "validate: tau values out of range" + end if if(len_trim(err_message) > 0 .and. len_trim(this%get_name()) > 0) & err_message = trim(this%get_name()) // ': ' // trim(err_message) @@ -600,25 +613,29 @@ function validate_2stream(this) result(err_message) ! ! Array allocation status, sizing ! - if(.not. all([allocated(this%tau), allocated(this%ssa), allocated(this%g)])) then - err_message = "validate: arrays not allocated/initialized" - return + if(check_extents) then + if(.not. all([allocated(this%tau), allocated(this%ssa), allocated(this%g)])) then + err_message = "validate: arrays not allocated/initialized" + return + end if + d1 = size(this%tau, 1) + d2 = size(this%tau, 2) + d3 = size(this%tau, 3) + if(.not. extents_are(this%ssa, d1, d2, d3) .or. & + .not. extents_are(this%g , d1, d2, d3)) & + err_message = "validate: arrays not sized consistently" end if - d1 = size(this%tau, 1) - d2 = size(this%tau, 2) - d3 = size(this%tau, 3) - if(.not. extents_are(this%ssa, d1, d2, d3) .or. & - .not. extents_are(this%g , d1, d2, d3)) & - err_message = "validate: arrays not sized consistently" ! ! Valid values ! - if(any_vals_less_than(this%tau, 0._wp)) & - err_message = "validate: tau values out of range" - if(any_vals_outside (this%ssa, 0._wp, 1._wp)) & - err_message = "validate: ssa values out of range" - if(any_vals_outside (this%g , -1._wp, 1._wp)) & - err_message = "validate: g values out of range" + if (check_values) then + if(any_vals_less_than(this%tau, 0._wp)) & + err_message = "validate: tau values out of range" + if(any_vals_outside (this%ssa, 0._wp, 1._wp)) & + err_message = "validate: ssa values out of range" + if(any_vals_outside (this%g , -1._wp, 1._wp)) & + err_message = "validate: g values out of range" + end if if(len_trim(err_message) > 0 .and. len_trim(this%get_name()) > 0) & err_message = trim(this%get_name()) // ': ' // trim(err_message) @@ -644,24 +661,27 @@ function validate_nstream(this) result(err_message) d2 = size(this%tau, 2) d3 = size(this%tau, 3) d4 = size(this%p, 1) - if(.not. extents_are(this%ssa, d1, d2, d3) .or. & - .not. extents_are(this%p , d4, d1, d2, d3)) & - err_message = "validate: arrays not sized consistently" + if (check_extents) then + if(.not. extents_are(this%ssa, d1, d2, d3) .or. & + .not. extents_are(this%p , d4, d1, d2, d3)) & + err_message = "validate: arrays not sized consistently" + end if ! ! Valid values ! - if(any_vals_less_than(this%tau, 0._wp)) & - err_message = "validate: tau values out of range" - if(any_vals_outside (this%ssa, 0._wp, 1._wp)) & - err_message = "validate: ssa values out of range" - if(any_vals_outside (this%p(1,:,:,:), & - -1._wp, 1._wp)) & - err_message = "validate: p(1,:,:,:) = g values out of range" + if (check_values) then + if(any_vals_less_than(this%tau, 0._wp)) & + err_message = "validate: tau values out of range" + if(any_vals_outside (this%ssa, 0._wp, 1._wp)) & + err_message = "validate: ssa values out of range" + if(any_vals_outside (this%p(1,:,:,:), -1._wp, 1._wp)) & + err_message = "validate: p(1,:,:,:) = g values out of range" + end if if(len_trim(err_message) > 0 .and. len_trim(this%get_name()) > 0) & err_message = trim(this%get_name()) // ': ' // trim(err_message) end function validate_nstream - + ! ------------------------------------------------------------------------------------------ ! ! Routines for array classes: subsetting of optical properties arrays along x (col) direction @@ -837,7 +857,7 @@ function increment(op_in, op_io) result(err_message) class(ty_optical_props_arry), intent(inout) :: op_io character(128) :: err_message ! ----- - integer :: ncol, nlay, ngpt, nmom + integer :: ncol, nlay, ngpt ! ----- err_message = "" if(.not. op_in%is_initialized()) & diff --git a/rte/mo_rte_lw.F90 b/rte/mo_rte_lw.F90 index 940387bdd..d9cb63d62 100644 --- a/rte/mo_rte_lw.F90 +++ b/rte/mo_rte_lw.F90 @@ -84,8 +84,6 @@ function rte_lw(optical_props, top_at_1, & ! integer :: ncol, nlay, ngpt, nband integer :: n_quad_angs - integer :: icol, iband, igpt - real(wp) :: lw_Ds_wt logical :: using_2stream, do_Jacobians real(wp), dimension(:,:,:), allocatable :: gpt_flux_up, gpt_flux_dn real(wp), dimension(:,:), allocatable :: sfc_emis_gpt @@ -222,7 +220,7 @@ function rte_lw(optical_props, top_at_1, & ! ! Ensure values of tau, ssa, and g are reasonable if using scattering ! - if(check_values) error_msg = optical_props%validate() + error_msg = optical_props%validate() if(len_trim(error_msg) > 0) then if(len_trim(optical_props%get_name()) > 0) & @@ -241,7 +239,7 @@ function rte_lw(optical_props, top_at_1, & !$omp target enter data map(alloc:gpt_flux_dn, gpt_flux_up) !$acc enter data create( sfc_emis_gpt) !$omp target enter data map(alloc:sfc_emis_gpt) - !$omp enter data create( flux_up_Jac) if(do_Jacobians) + !$acc enter data create( flux_up_Jac) if(do_Jacobians) !$omp target enter data map(alloc:flux_up_Jac) if(do_Jacobians) call expand_and_transpose(optical_props, sfc_emis, sfc_emis_gpt) @@ -355,7 +353,7 @@ function rte_lw(optical_props, top_at_1, & !$omp target exit data map(release:gpt_flux_up, gpt_flux_dn, sfc_emis_gpt) !$acc exit data delete(optical_props) !!$acc exit data delete(sources%lay_source, sources%lev_source_inc, sources%lev_source_dec, sources%sfc_source,sources) - !$omp exit data copyout( flux_up_Jac) if(do_Jacobians) + !$acc exit data copyout( flux_up_Jac) if(do_Jacobians) !$omp target exit data map(from:flux_up_Jac) if(do_Jacobians) end function rte_lw diff --git a/rte/mo_rte_sw.F90 b/rte/mo_rte_sw.F90 index c698fd538..427912682 100644 --- a/rte/mo_rte_sw.F90 +++ b/rte/mo_rte_sw.F90 @@ -63,7 +63,6 @@ function rte_sw(atmos, top_at_1, & ! Local variables ! integer :: ncol, nlay, ngpt, nband - integer :: icol real(wp), dimension(:,:,:), allocatable :: gpt_flux_up, gpt_flux_dn, gpt_flux_dir real(wp), dimension(:,:), allocatable :: sfc_alb_dir_gpt, sfc_alb_dif_gpt diff --git a/tests/clear_sky_regression.F90 b/tests/clear_sky_regression.F90 index 2d070cd5f..6958d6462 100644 --- a/tests/clear_sky_regression.F90 +++ b/tests/clear_sky_regression.F90 @@ -199,6 +199,8 @@ program rte_clear_sky_regression fluxes%flux_up => flux_up(:,:) fluxes%flux_dn => flux_dn(:,:) if(is_lw) then + call make_optical_props_1scl + call atmos%finalize() call make_optical_props_1scl call atmos%set_name("gas only atmosphere") call lw_clear_sky_default @@ -212,6 +214,8 @@ program rte_clear_sky_regression call make_optical_props_2str call lw_clear_sky_2str else + call make_optical_props_2str + call atmos%finalize() call make_optical_props_2str call sw_clear_sky_default call sw_clear_sky_tsi