diff --git a/.github/workflows/fortran-formatting.yaml b/.github/workflows/fortran-formatting.yaml index 85331777..7ca69e8a 100644 --- a/.github/workflows/fortran-formatting.yaml +++ b/.github/workflows/fortran-formatting.yaml @@ -6,7 +6,7 @@ on: types: [opened, synchronize, labeled, unlabeled] env: - CODEE_VERSION: 2025.4.5 + CODEE_VERSION: 2025.4.8 # Only needed when fixing formatting automatically, but this only # works for pull requests from the same repo, not from a fork @@ -16,7 +16,7 @@ env: jobs: format: - name: Check and fix Fortran formatting + name: Check Fortran formatting runs-on: ubuntu-22.04 steps: @@ -25,32 +25,25 @@ jobs: with: fetch-depth: 0 - - name: Get modified Fortran files + - name: Check formatting of modified Fortran files run: | git remote -v show git fetch origin ${{ github.base_ref }} MODIFIED_FILES=$(git diff --name-only --diff-filter=d origin/${{ github.base_ref }}...HEAD -- '*.f90' '*.F90' '*.f' '*.F') - echo "MODIFIED_FILES=${MODIFIED_FILES}" >> ${GITHUB_ENV} - - - name: Install Codee - if: env.MODIFIED_FILES != '' - run: | + if [[ "${MODIFIED_FILES}" == "" ]]; then + exit 0 + fi + # echo "Installing Codee ${CODEE_VERSION} ..." wget https://codee.com/release/codee-${CODEE_VERSION}-linux-x86_64.tar.gz tar -xf codee-${CODEE_VERSION}-linux-x86_64.tar.gz - - - name: Run `codee format` on modified files - if: env.MODIFIED_FILES != '' - run: | export PATH="${PWD}/codee-${CODEE_VERSION}-linux-x86_64/bin:${PATH}" + # codee format --accept-eula --verbose ${MODIFIED_FILES} REFORMATTED_FILES=$(git diff --name-only --diff-filter=d) - echo "REFORMATTED_FILES=${REFORMATTED_FILES}" >> ${GITHUB_ENV} - - - name: Fail if there are uncommitted changes - if: ${{ env.REFORMATTED_FILES != '' }} - run: | + if [[ "${REFORMATTED_FILES}" == "" ]]; then + exit 0 + fi echo "Formatting issues detected. Run 'codee format' locally or apply the following diff manually:" git diff exit 1 - diff --git a/test/capgen_test/CMakeLists.txt b/test/capgen_test/CMakeLists.txt index 8288569f..3a0e1405 100644 --- a/test/capgen_test/CMakeLists.txt +++ b/test/capgen_test/CMakeLists.txt @@ -72,8 +72,25 @@ add_library(CAPGEN_TESTLIB OBJECT ${SCHEME_FORTRAN_FILES} # Setup test executable with needed dependencies add_executable(capgen_host_integration test_capgen_host_integration.F90 ${HOST}.F90) +if(OPENMP) + target_link_libraries(capgen_host_integration PRIVATE OpenMP::OpenMP_Fortran) +endif() target_link_libraries(capgen_host_integration PRIVATE CAPGEN_TESTLIB test_utils) target_include_directories(capgen_host_integration PRIVATE "$") # Add executable to be called with ctest -add_test(NAME ctest_capgen_host_integration COMMAND capgen_host_integration) +add_test(NAME ctest_capgen_host_integration_omp1 + COMMAND capgen_host_integration) + +add_test(NAME ctest_capgen_host_integration_omp2 + COMMAND capgen_host_integration) + +set_tests_properties(ctest_capgen_host_integration_omp1 + PROPERTIES + ENVIRONMENT "OMP_NUM_THREADS=1" +) + +set_tests_properties(ctest_capgen_host_integration_omp2 + PROPERTIES + ENVIRONMENT "OMP_NUM_THREADS=2" +) diff --git a/test/capgen_test/ddt2.F90 b/test/capgen_test/ddt2.F90 index 69e08a50..ce560846 100644 --- a/test/capgen_test/ddt2.F90 +++ b/test/capgen_test/ddt2.F90 @@ -1,12 +1,12 @@ module ddt2 - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys - implicit none + implicit none - type ty_ddt2 - integer :: foo - real(kind_phys) :: bar - end type ty_ddt2 + type ty_ddt2 + integer :: foo + real(kind=kind_phys) :: bar + end type ty_ddt2 end module ddt2 diff --git a/test/capgen_test/make_ddt.F90 b/test/capgen_test/make_ddt.F90 index 91ec2e77..429e8939 100644 --- a/test/capgen_test/make_ddt.F90 +++ b/test/capgen_test/make_ddt.F90 @@ -1,143 +1,142 @@ !Hello demonstration parameterization ! -MODULE make_ddt - - USE ccpp_kinds, ONLY: kind_phys - USE ddt2, only: ty_ddt2 - - IMPLICIT NONE - PRIVATE - - PUBLIC :: make_ddt_init - PUBLIC :: make_ddt_run - PUBLIC :: make_ddt_timestep_final - PUBLIC :: vmr_type - - type ty_ddt3 - integer :: dont_lose - integer :: your_head - integer :: to_gain_a_minute - integer :: you_need_your_head - integer :: your_brains_are_in_it - end type ty_ddt3 - - !> \section arg_table_vmr_type Argument Table - !! \htmlinclude arg_table_vmr_type.html - !! - type vmr_type - integer :: nvmr - real(kind_phys), allocatable :: vmr_array(:,:) - type(ty_ddt2) :: error_maybe - type(ty_ddt3) :: burma_shave - end type vmr_type - - -CONTAINS - - !> \section arg_table_make_ddt_run Argument Table - !! \htmlinclude arg_table_make_ddt_run.html - !! - SUBROUTINE make_ddt_run(cols, cole, O3, HNO3, vmr, errmsg, errflg) - !---------------------------------------------------------------- - IMPLICIT NONE - !---------------------------------------------------------------- - - ! Dummy arguments - integer, intent(in) :: cols - integer, intent(in) :: cole - REAL(kind_phys), intent(in) :: O3(:) - REAL(kind_phys), intent(in) :: HNO3(:) - type(vmr_type), intent(inout) :: vmr - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - ! Local variable - integer :: nbox - !---------------------------------------------------------------- - - errmsg = '' - errflg = 0 - - ! Check for correct threading behavior - nbox = cole - cols + 1 - if (SIZE(O3) /= nbox) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'SIZE(O3) = ', SIZE(O3), ', should be ', nbox - else if (SIZE(HNO3) /= nbox) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'SIZE(HNO3) = ', SIZE(HNO3), & - ', should be ', nbox - else - ! NOTE -- This is prototyping one approach to passing a large number of - ! chemical VMR values and is the predecssor for adding in methods and - ! maybe nesting DDTs (especially for aerosols) - vmr%vmr_array(cols:cole, 1) = O3(:) - vmr%vmr_array(cols:cole, 2) = HNO3(:) - end if - - END SUBROUTINE make_ddt_run - - !> \section arg_table_make_ddt_init Argument Table - !! \htmlinclude arg_table_make_ddt_init.html - !! - subroutine make_ddt_init(nbox, vmr, errmsg, errflg) - - ! Dummy arguments - integer, intent(in) :: nbox - type(vmr_type), intent(out) :: vmr - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! This routine initializes the vmr array - vmr%nvmr = 2 - allocate(vmr%vmr_array(nbox, vmr%nvmr)) - - errmsg = '' - errflg = 0 - - end subroutine make_ddt_init - - !> \section arg_table_make_ddt_timestep_final Argument Table - !! \htmlinclude arg_table_make_ddt_timestep_final.html - !! - subroutine make_ddt_timestep_final (ncols, vmr, errmsg, errflg) - - ! Dummy arguments - integer, intent(in) :: ncols - type(vmr_type), intent(in) :: vmr - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - ! Local variables - integer :: index - real(kind_phys) :: rind - - errmsg = '' - errflg = 0 - - ! This routine checks the array values in vmr - if (SIZE(vmr%vmr_array, 1) /= ncols) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'VMR%VMR_ARRAY first dimension size is, ', & - SIZE(vmr%vmr_array, 1), ', should be, ', ncols - else - do index = 1, ncols - rind = real(index, kind_phys) - if (vmr%vmr_array(index, 1) /= rind * 1.e-6_kind_phys) then - errflg = 1 - write(errmsg, '(a,i0,2(a,e12.4))') 'O3(', index, ') = ', & - vmr%vmr_array(index, 1), ', should be, ', & - rind * 1.e-6_kind_phys - exit - else if (vmr%vmr_array(index, 2) /= rind * 1.e-9_kind_phys) then - errflg = 1 - write(errmsg, '(a,i0,2(a,e12.4))') 'HNO3(', index, ') = ', & - vmr%vmr_array(index, 2), ', should be, ', & - rind * 1.e-9_kind_phys - exit - end if - end do - end if - - end subroutine make_ddt_timestep_final - -END MODULE make_ddt +module make_ddt + + use ccpp_kinds, only: kind_phys + use ddt2, only: ty_ddt2 + + implicit none + private + + public :: make_ddt_init + public :: make_ddt_run + public :: make_ddt_timestep_final + public :: vmr_type + + type ty_ddt3 + integer :: dont_lose + integer :: your_head + integer :: to_gain_a_minute + integer :: you_need_your_head + integer :: your_brains_are_in_it + end type ty_ddt3 + + !> \section arg_table_vmr_type Argument Table + !! \htmlinclude arg_table_vmr_type.html + !! + type vmr_type + integer :: nvmr + real(kind=kind_phys), allocatable :: vmr_array(:, :) + type(ty_ddt2) :: error_maybe + type(ty_ddt3) :: burma_shave + end type vmr_type + +contains + + !> \section arg_table_make_ddt_run Argument Table + !! \htmlinclude arg_table_make_ddt_run.html + !! + subroutine make_ddt_run(cols, cole, o3, hno3, vmr, errmsg, errflg) + !---------------------------------------------------------------- + implicit none + !---------------------------------------------------------------- + + ! Dummy arguments + integer, intent(in) :: cols + integer, intent(in) :: cole + real(kind=kind_phys), intent(in) :: o3(:) + real(kind=kind_phys), intent(in) :: hno3(:) + type(vmr_type), intent(inout) :: vmr + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + ! Local variable + integer :: nbox + !---------------------------------------------------------------- + + errmsg = '' + errflg = 0 + + ! Check for correct threading behavior + nbox = cole - cols + 1 + if (size(o3) /= nbox) then + errflg = 1 + write(errmsg, '(2(a,i0))') 'SIZE(O3) = ', size(o3), ', should be ', nbox + else if (size(hno3) /= nbox) then + errflg = 1 + write(errmsg, '(2(a,i0))') 'SIZE(HNO3) = ', size(hno3), & + ', should be ', nbox + else + ! NOTE -- This is prototyping one approach to passing a large number of + ! chemical VMR values and is the predecssor for adding in methods and + ! maybe nesting DDTs (especially for aerosols) + vmr%vmr_array(cols:cole, 1) = o3(:) + vmr%vmr_array(cols:cole, 2) = hno3(:) + end if + + end subroutine make_ddt_run + + !> \section arg_table_make_ddt_init Argument Table + !! \htmlinclude arg_table_make_ddt_init.html + !! + subroutine make_ddt_init(nbox, vmr, errmsg, errflg) + + ! Dummy arguments + integer, intent(in) :: nbox + type(vmr_type), intent(out) :: vmr + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! This routine initializes the vmr array + vmr%nvmr = 2 + allocate(vmr%vmr_array(nbox, vmr%nvmr)) + + errmsg = '' + errflg = 0 + + end subroutine make_ddt_init + + !> \section arg_table_make_ddt_timestep_final Argument Table + !! \htmlinclude arg_table_make_ddt_timestep_final.html + !! + subroutine make_ddt_timestep_final(ncols, vmr, errmsg, errflg) + + ! Dummy arguments + integer, intent(in) :: ncols + type(vmr_type), intent(in) :: vmr + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + ! Local variables + integer :: index + real(kind=kind_phys) :: rind + + errmsg = '' + errflg = 0 + + ! This routine checks the array values in vmr + if (size(vmr%vmr_array, 1) /= ncols) then + errflg = 1 + write(errmsg, '(2(a,i0))') 'VMR%VMR_ARRAY first dimension size is, ', & + size(vmr%vmr_array, 1), ', should be, ', ncols + else + do index = 1, ncols + rind = real(index, kind_phys) + if (vmr%vmr_array(index, 1) /= rind * 1.e-6_kind_phys) then + errflg = 1 + write(errmsg, '(a,i0,2(a,e12.4))') 'O3(', index, ') = ', & + vmr%vmr_array(index, 1), ', should be, ', & + rind * 1.e-6_kind_phys + exit + else if (vmr%vmr_array(index, 2) /= rind * 1.e-9_kind_phys) then + errflg = 1 + write(errmsg, '(a,i0,2(a,e12.4))') 'HNO3(', index, ') = ', & + vmr%vmr_array(index, 2), ', should be, ', & + rind * 1.e-9_kind_phys + exit + end if + end do + end if + + end subroutine make_ddt_timestep_final + +end module make_ddt diff --git a/test/capgen_test/setup_coeffs.F90 b/test/capgen_test/setup_coeffs.F90 index 09452780..09c7fcc1 100644 --- a/test/capgen_test/setup_coeffs.F90 +++ b/test/capgen_test/setup_coeffs.F90 @@ -1,5 +1,5 @@ module setup_coeffs - use ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys implicit none public :: setup_coeffs_timestep_init @@ -10,9 +10,9 @@ module setup_coeffs !! subroutine setup_coeffs_timestep_init(coeffs, errmsg, errflg) - real(kind_phys), intent(inout) :: coeffs(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(inout) :: coeffs(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 diff --git a/test/capgen_test/temp_adjust.F90 b/test/capgen_test/temp_adjust.F90 index b39baf61..c25d087b 100644 --- a/test/capgen_test/temp_adjust.F90 +++ b/test/capgen_test/temp_adjust.F90 @@ -1,56 +1,58 @@ ! Test parameterization with no vertical level ! -MODULE temp_adjust +module temp_adjust - USE ccpp_kinds, ONLY: kind_phys, kind_temp + use ccpp_kinds, only: kind_phys, kind_temp - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: temp_adjust_register - PUBLIC :: temp_adjust_init - PUBLIC :: temp_adjust_run - PUBLIC :: temp_adjust_finalize + public :: temp_adjust_register + public :: temp_adjust_init + public :: temp_adjust_run + public :: temp_adjust_finalize logical :: module_level_config = .false. -CONTAINS +contains !> \section arg_table_temp_adjust_register Argument Table !! \htmlinclude arg_table_temp_adjust_register.hml !! subroutine temp_adjust_register(config_var, errmsg, errflg) - logical, intent(in) :: config_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + logical, intent(in) :: config_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - module_level_config = config_var - errflg = 0 - errmsg = '' + module_level_config = config_var + errflg = 0 + errmsg = '' end subroutine temp_adjust_register !> \section arg_table_temp_adjust_run Argument Table !! \htmlinclude arg_table_temp_adjust_run.html !! - subroutine temp_adjust_run(foo, timestep, interstitial_var, temp_prev, temp_layer, qv, ps, & - to_promote, promote_pcnst, errmsg, errflg, innie, outie, optsie) - - integer, intent(in) :: foo - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(inout),optional :: qv(:) - real(kind_phys), intent(inout) :: ps(:) - REAL(kind_phys), intent(in) :: temp_prev(:) - REAL(kind_phys), intent(inout) :: temp_layer(foo) - real(kind_temp), intent(in) :: to_promote(:) - real(kind_phys), intent(in) :: promote_pcnst(:) - integer, intent(out) :: interstitial_var(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - real(kind_phys), optional, intent(in) :: innie - real(kind_phys), optional, intent(out) :: outie - real(kind_phys), optional, intent(inout) :: optsie + subroutine temp_adjust_run(foo, timestep, interstitial_var, temp_prev, temp_layer, qv, ps, & + to_promote, promote_pcnst, errmsg, errflg, innie, outie, optsie) + + integer, intent(in) :: foo + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(inout), optional :: qv(:) + real(kind=kind_phys), intent(inout) :: ps(:) + ! codee format off + REAL(kind_phys), intent(in) :: temp_prev(:) + REAL(kind_phys), intent(inout) :: temp_layer(foo) + ! codee format on + real(kind=kind_temp), intent(in) :: to_promote(:) + real(kind=kind_phys), intent(in) :: promote_pcnst(:) + integer, intent(out) :: interstitial_var(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind=kind_phys), optional, intent(in) :: innie + real(kind=kind_phys), optional, intent(out) :: outie + real(kind=kind_phys), optional, intent(inout) :: optsie !---------------------------------------------------------------- integer :: col_index @@ -60,34 +62,34 @@ subroutine temp_adjust_run(foo, timestep, interstitial_var, temp_prev, temp_laye interstitial_var = 6 if (size(interstitial_var) /= 3) then - errflg = 1 - errmsg = 'interstitial variable not allocated properly!' - return + errflg = 1 + errmsg = 'interstitial variable not allocated properly!' + return end if - if (.not. module_level_config) then - ! do nothing - return + if (.not.module_level_config) then + ! do nothing + return end if do col_index = 1, foo - temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) - if (present(qv)) qv(col_index) = qv(col_index) + 1.0_kind_phys + temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) + if (present(qv)) qv(col_index) = qv(col_index) + 1.0_kind_phys end do if (present(innie) .and. present(outie) .and. present(optsie)) then - outie = innie * optsie - optsie = optsie + 1.0_kind_phys + outie = innie * optsie + optsie = optsie + 1.0_kind_phys end if - END SUBROUTINE temp_adjust_run + end subroutine temp_adjust_run !> \section arg_table_temp_adjust_init Argument Table !! \htmlinclude arg_table_temp_adjust_init.html !! - subroutine temp_adjust_init (errmsg, errflg) + subroutine temp_adjust_init(errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg ! This routine currently does nothing @@ -99,26 +101,26 @@ end subroutine temp_adjust_init !> \section arg_table_temp_adjust_finalize Argument Table !! \htmlinclude arg_table_temp_adjust_finalize.html !! - subroutine temp_adjust_finalize (interstitial_var, errmsg, errflg) + subroutine temp_adjust_finalize(interstitial_var, errmsg, errflg) - integer, intent(in) :: interstitial_var(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: interstitial_var(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg ! This routine currently does nothing errmsg = '' errflg = 0 if (size(interstitial_var) /= 3) then - errflg = 1 - errmsg = 'interstitial variable not allocated properly!' - return + errflg = 1 + errmsg = 'interstitial variable not allocated properly!' + return end if if (interstitial_var(1) /= 6) then - errflg = 1 - errmsg = 'interstitial variable not set properly!' + errflg = 1 + errmsg = 'interstitial variable not set properly!' end if end subroutine temp_adjust_finalize -END MODULE temp_adjust +end module temp_adjust diff --git a/test/capgen_test/temp_calc_adjust.F90 b/test/capgen_test/temp_calc_adjust.F90 index cee03dbf..cee0703f 100644 --- a/test/capgen_test/temp_calc_adjust.F90 +++ b/test/capgen_test/temp_calc_adjust.F90 @@ -1,108 +1,111 @@ !Test parameterization with no vertical level and hanging intent(out) variable ! -MODULE temp_calc_adjust +module temp_calc_adjust - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: temp_calc_adjust_register - PUBLIC :: temp_calc_adjust_init - PUBLIC :: temp_calc_adjust_run - PUBLIC :: temp_calc_adjust_finalize + public :: temp_calc_adjust_register + public :: temp_calc_adjust_init + public :: temp_calc_adjust_run + public :: temp_calc_adjust_finalize -CONTAINS +contains - !> \section arg_table_temp_calc_adjust_register Argument Table - !! \htmlinclude arg_table_temp_calc_adjust_register.html - !! - SUBROUTINE temp_calc_adjust_register(dim_inter, errmsg, errflg) - integer, intent(out) :: dim_inter - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg +! codee format off +!> \section arg_table_temp_calc_adjust_register Argument Table +!! \htmlinclude arg_table_temp_calc_adjust_register.html +!! + SUBROUTINE temp_calc_adjust_register(dim_inter, errmsg, errflg) +! codee format on + integer, intent(out) :: dim_inter + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - errflg = 0 - errmsg = '' - dim_inter = 3 - END SUBROUTINE temp_calc_adjust_register - !> \section arg_table_temp_calc_adjust_run Argument Table - !! \htmlinclude arg_table_temp_calc_adjust_run.html - !! - SUBROUTINE temp_calc_adjust_run(nbox, timestep, temp_level, temp_calc, & - errmsg, errflg) + errflg = 0 + errmsg = '' + dim_inter = 3 + end subroutine temp_calc_adjust_register - integer, intent(in) :: nbox - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(in) :: temp_level(:,:) - REAL(kind_phys), intent(out) :: temp_calc(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- + !> \section arg_table_temp_calc_adjust_run Argument Table + !! \htmlinclude arg_table_temp_calc_adjust_run.html + !! + subroutine temp_calc_adjust_run(nbox, timestep, temp_level, temp_calc, & + errmsg, errflg) - integer :: col_index - real(kind_phys) :: bar = 1.0_kind_phys + integer, intent(in) :: nbox + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(in) :: temp_level(:, :) + real(kind=kind_phys), intent(out) :: temp_calc(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- - errmsg = '' - errflg = 0 + integer :: col_index + real(kind=kind_phys) :: bar = 1.0_kind_phys - call temp_calc_adjust_nested_subroutine(temp_calc) - if (check_foo()) then - call foo(bar) - end if + errmsg = '' + errflg = 0 - CONTAINS + call temp_calc_adjust_nested_subroutine(temp_calc) + if (check_foo()) then + call foo(bar) + end if - ELEMENTAL SUBROUTINE temp_calc_adjust_nested_subroutine(temp) + contains - REAL(kind_phys), intent(out) :: temp - !------------------------------------------------------------- + elemental subroutine temp_calc_adjust_nested_subroutine(temp) - temp = 1.0_kind_phys + real(kind=kind_phys), intent(out) :: temp + !------------------------------------------------------------- - END SUBROUTINE temp_calc_adjust_nested_subroutine + temp = 1.0_kind_phys - SUBROUTINE foo(bar) - REAL(kind_phys), intent(inout) :: bar - bar = bar + 1.0_kind_phys + end subroutine temp_calc_adjust_nested_subroutine - END SUBROUTINE + subroutine foo(bar) + real(kind=kind_phys), intent(inout) :: bar + bar = bar + 1.0_kind_phys - logical function check_foo() - check_foo = .true. - end function check_foo + end subroutine foo - END SUBROUTINE + logical function check_foo() + check_foo = .true. + end function check_foo - !> \section arg_table_temp_calc_adjust_init Argument Table - !! \htmlinclude arg_table_temp_calc_adjust_init.html - !! - subroutine temp_calc_adjust_init (errmsg, errflg) + end subroutine temp_calc_adjust_run - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + !> \section arg_table_temp_calc_adjust_init Argument Table + !! \htmlinclude arg_table_temp_calc_adjust_init.html + !! + subroutine temp_calc_adjust_init(errmsg, errflg) - ! This routine currently does nothing + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - errmsg = '' - errflg = 0 + ! This routine currently does nothing - end subroutine temp_calc_adjust_init + errmsg = '' + errflg = 0 - !> \section arg_table_temp_calc_adjust_finalize Argument Table - !! \htmlinclude arg_table_temp_calc_adjust_finalize.html - !! - subroutine temp_calc_adjust_finalize (errmsg, errflg) + end subroutine temp_calc_adjust_init - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + !> \section arg_table_temp_calc_adjust_finalize Argument Table + !! \htmlinclude arg_table_temp_calc_adjust_finalize.html + !! + subroutine temp_calc_adjust_finalize(errmsg, errflg) - ! This routine currently does nothing + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - errmsg = '' - errflg = 0 + ! This routine currently does nothing - end subroutine temp_calc_adjust_finalize + errmsg = '' + errflg = 0 -END MODULE temp_calc_adjust + end subroutine temp_calc_adjust_finalize + +end module temp_calc_adjust diff --git a/test/capgen_test/test_capgen_host_integration.F90 b/test/capgen_test/test_capgen_host_integration.F90 index 745e5678..eb11f2f8 100644 --- a/test/capgen_test/test_capgen_host_integration.F90 +++ b/test/capgen_test/test_capgen_host_integration.F90 @@ -1,86 +1,86 @@ program test - use test_prog, only: test_host, suite_info, cm, cs + use test_prog, only: test_host, suite_info, cm, cs - implicit none + implicit none - character(len=cs), target :: test_parts1(2) = (/ 'physics1 ', & - 'physics2 ' /) - character(len=cs), target :: test_parts2(1) = (/ 'data_prep ' /) - character(len=cm), target :: test_invars1(10) = (/ & - 'potential_temperature ', & - 'potential_temperature_at_interface ', & - 'coefficients_for_interpolation ', & - 'surface_air_pressure ', & - 'water_vapor_specific_humidity ', & - 'potential_temperature_increment ', & - 'soil_levels ', & - 'temperature_at_diagnostic_levels ', & - 'time_step_for_physics ', & - 'array_variable_for_testing ' /) - character(len=cm), target :: test_outvars1(10) = (/ & - 'potential_temperature ', & - 'potential_temperature_at_interface ', & - 'coefficients_for_interpolation ', & - 'surface_air_pressure ', & - 'water_vapor_specific_humidity ', & - 'soil_levels ', & - 'temperature_at_diagnostic_levels ', & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'array_variable_for_testing ' /) - character(len=cm), target :: test_reqvars1(12) = (/ & - 'potential_temperature ', & - 'potential_temperature_at_interface ', & - 'coefficients_for_interpolation ', & - 'surface_air_pressure ', & - 'water_vapor_specific_humidity ', & - 'potential_temperature_increment ', & - 'time_step_for_physics ', & - 'soil_levels ', & - 'temperature_at_diagnostic_levels ', & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'array_variable_for_testing ' /) + character(len=cs), target :: test_parts1(2) = (/ 'physics1 ', & + 'physics2 ' /) + character(len=cs), target :: test_parts2(1) = (/ 'data_prep ' /) + character(len=cm), target :: test_invars1(10) = (/ & + 'potential_temperature ', & + 'potential_temperature_at_interface ', & + 'coefficients_for_interpolation ', & + 'surface_air_pressure ', & + 'water_vapor_specific_humidity ', & + 'potential_temperature_increment ', & + 'soil_levels ', & + 'temperature_at_diagnostic_levels ', & + 'time_step_for_physics ', & + 'array_variable_for_testing ' /) + character(len=cm), target :: test_outvars1(10) = (/ & + 'potential_temperature ', & + 'potential_temperature_at_interface ', & + 'coefficients_for_interpolation ', & + 'surface_air_pressure ', & + 'water_vapor_specific_humidity ', & + 'soil_levels ', & + 'temperature_at_diagnostic_levels ', & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'array_variable_for_testing ' /) + character(len=cm), target :: test_reqvars1(12) = (/ & + 'potential_temperature ', & + 'potential_temperature_at_interface ', & + 'coefficients_for_interpolation ', & + 'surface_air_pressure ', & + 'water_vapor_specific_humidity ', & + 'potential_temperature_increment ', & + 'time_step_for_physics ', & + 'soil_levels ', & + 'temperature_at_diagnostic_levels ', & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'array_variable_for_testing ' /) - character(len=cm), target :: test_invars2(3) = (/ & - 'model_times ', & - 'number_of_model_times ', & - 'surface_air_pressure ' /) + character(len=cm), target :: test_invars2(3) = (/ & + 'model_times ', & + 'number_of_model_times ', & + 'surface_air_pressure ' /) - character(len=cm), target :: test_outvars2(5) = (/ & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'model_times ', & - 'surface_air_pressure ', & - 'number_of_model_times ' /) + character(len=cm), target :: test_outvars2(5) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'model_times ', & + 'surface_air_pressure ', & + 'number_of_model_times ' /) - character(len=cm), target :: test_reqvars2(5) = (/ & - 'model_times ', & - 'number_of_model_times ', & - 'surface_air_pressure ', & - 'ccpp_error_code ', & - 'ccpp_error_message ' /) - type(suite_info) :: test_suites(2) - logical :: run_okay + character(len=cm), target :: test_reqvars2(5) = (/ & + 'model_times ', & + 'number_of_model_times ', & + 'surface_air_pressure ', & + 'ccpp_error_code ', & + 'ccpp_error_message ' /) + type(suite_info) :: test_suites(2) + logical :: run_okay - ! Setup expected test suite info - test_suites(1)%suite_name = 'temp_suite' - test_suites(1)%suite_parts => test_parts1 - test_suites(1)%suite_input_vars => test_invars1 - test_suites(1)%suite_output_vars => test_outvars1 - test_suites(1)%suite_required_vars => test_reqvars1 - test_suites(2)%suite_name = 'ddt_suite' - test_suites(2)%suite_parts => test_parts2 - test_suites(2)%suite_input_vars => test_invars2 - test_suites(2)%suite_output_vars => test_outvars2 - test_suites(2)%suite_required_vars => test_reqvars2 + ! Setup expected test suite info + test_suites(1)%suite_name = 'temp_suite' + test_suites(1)%suite_parts => test_parts1 + test_suites(1)%suite_input_vars => test_invars1 + test_suites(1)%suite_output_vars => test_outvars1 + test_suites(1)%suite_required_vars => test_reqvars1 + test_suites(2)%suite_name = 'ddt_suite' + test_suites(2)%suite_parts => test_parts2 + test_suites(2)%suite_input_vars => test_invars2 + test_suites(2)%suite_output_vars => test_outvars2 + test_suites(2)%suite_required_vars => test_reqvars2 - call test_host(run_okay, test_suites) + call test_host(run_okay, test_suites) - if (run_okay) then - STOP 0 - else - STOP -1 - end if + if (run_okay) then + stop 0 + else + stop -1 + end if end program test diff --git a/test/capgen_test/test_host.F90 b/test/capgen_test/test_host.F90 index 9ed3f47c..6e39c787 100644 --- a/test/capgen_test/test_host.F90 +++ b/test/capgen_test/test_host.F90 @@ -1,280 +1,303 @@ module test_prog - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public test_host + public test_host - ! Public data and interfaces - integer, public, parameter :: cs = 16 - integer, public, parameter :: cm = 36 + ! Public data and interfaces + integer, public, parameter :: cs = 16 + integer, public, parameter :: cm = 36 - !> \section arg_table_suite_info Argument Table - !! \htmlinclude arg_table_suite_info.html - !! - type, public :: suite_info - character(len=cs) :: suite_name = '' - character(len=cs), pointer :: suite_parts(:) => NULL() - character(len=cm), pointer :: suite_input_vars(:) => NULL() - character(len=cm), pointer :: suite_output_vars(:) => NULL() - character(len=cm), pointer :: suite_required_vars(:) => NULL() - end type suite_info + !> \section arg_table_suite_info Argument Table + !! \htmlinclude arg_table_suite_info.html + !! + type, public :: suite_info + character(len=cs) :: suite_name = '' + character(len=cs), pointer :: suite_parts(:) => null() + character(len=cm), pointer :: suite_input_vars(:) => null() + character(len=cm), pointer :: suite_output_vars(:) => null() + character(len=cm), pointer :: suite_required_vars(:) => null() + end type suite_info -CONTAINS +contains - logical function check_suite(test_suite) - use test_host_ccpp_cap, only: ccpp_physics_suite_part_list - use test_host_ccpp_cap, only: ccpp_physics_suite_variables - use test_utils, only: check_list + logical function check_suite(test_suite) + use test_host_ccpp_cap, only: ccpp_physics_suite_part_list + use test_host_ccpp_cap, only: ccpp_physics_suite_variables + use test_utils, only: check_list - ! Dummy argument - type(suite_info), intent(in) :: test_suite - ! Local variables - integer :: sind - logical :: check - integer :: errflg - character(len=512) :: errmsg - character(len=128), allocatable :: test_list(:) + ! Dummy argument + type(suite_info), intent(in) :: test_suite + ! Local variables + integer :: sind + logical :: check + integer :: errflg + character(len=512) :: errmsg + character(len=128), allocatable :: test_list(:) - check_suite = .true. - write(6, *) "Checking suite ", trim(test_suite%suite_name) - ! First, check the suite parts - call ccpp_physics_suite_part_list(test_suite%suite_name, test_list, & - errmsg, errflg) - if (errflg == 0) then - check = check_list(test_list, test_suite%suite_parts, 'part names', & - suite_name=test_suite%suite_name) - else - check = .false. - write(6, '(a,i0,2a)') 'ERROR ', errflg, ': ', trim(errmsg) - end if - check_suite = check_suite .and. check - if (allocated(test_list)) then - deallocate(test_list) - end if - ! Check the input variables - call ccpp_physics_suite_variables(test_suite%suite_name, test_list, & - errmsg, errflg, input_vars=.true., output_vars=.false.) - if (errflg == 0) then - check = check_list(test_list, test_suite%suite_input_vars, & - 'input variable names', suite_name=test_suite%suite_name) - else - check = .false. - write(6, '(a,i0,2a)') 'ERROR ', errflg, ': ', trim(errmsg) - end if - check_suite = check_suite .and. check - if (allocated(test_list)) then - deallocate(test_list) - end if - ! Check the output variables - call ccpp_physics_suite_variables(test_suite%suite_name, test_list, & - errmsg, errflg, input_vars=.false., output_vars=.true.) - if (errflg == 0) then - check = check_list(test_list, test_suite%suite_output_vars, & - 'output variable names', suite_name=test_suite%suite_name) - else - check = .false. - write(6, '(a,i0,2a)') 'ERROR ', errflg, ': ', trim(errmsg) - end if - check_suite = check_suite .and. check - if (allocated(test_list)) then - deallocate(test_list) - end if - ! Check all required variables - call ccpp_physics_suite_variables(test_suite%suite_name, test_list, & - errmsg, errflg) - if (errflg == 0) then - check = check_list(test_list, test_suite%suite_required_vars, & - 'required variable names', suite_name=test_suite%suite_name) - else - check = .false. - write(6, '(a,i0,2a)') 'ERROR ', errflg, ': ', trim(errmsg) - end if - check_suite = check_suite .and. check - if (allocated(test_list)) then - deallocate(test_list) - end if - end function check_suite + check_suite = .true. + write(6, *) "Checking suite ", trim(test_suite%suite_name) + ! First, check the suite parts + call ccpp_physics_suite_part_list(test_suite%suite_name, test_list, & + errmsg, errflg) + if (errflg == 0) then + check = check_list(test_list, test_suite%suite_parts, 'part names', & + suite_name=test_suite%suite_name) + else + check = .false. + write(6, '(a,i0,2a)') 'ERROR ', errflg, ': ', trim(errmsg) + end if + check_suite = check_suite .and. check + if (allocated(test_list)) then + deallocate(test_list) + end if + ! Check the input variables + call ccpp_physics_suite_variables(test_suite%suite_name, test_list, & + errmsg, errflg, input_vars=.true., output_vars=.false.) + if (errflg == 0) then + check = check_list(test_list, test_suite%suite_input_vars, & + 'input variable names', suite_name=test_suite%suite_name) + else + check = .false. + write(6, '(a,i0,2a)') 'ERROR ', errflg, ': ', trim(errmsg) + end if + check_suite = check_suite .and. check + if (allocated(test_list)) then + deallocate(test_list) + end if + ! Check the output variables + call ccpp_physics_suite_variables(test_suite%suite_name, test_list, & + errmsg, errflg, input_vars=.false., output_vars=.true.) + if (errflg == 0) then + check = check_list(test_list, test_suite%suite_output_vars, & + 'output variable names', suite_name=test_suite%suite_name) + else + check = .false. + write(6, '(a,i0,2a)') 'ERROR ', errflg, ': ', trim(errmsg) + end if + check_suite = check_suite .and. check + if (allocated(test_list)) then + deallocate(test_list) + end if + ! Check all required variables + call ccpp_physics_suite_variables(test_suite%suite_name, test_list, & + errmsg, errflg) + if (errflg == 0) then + check = check_list(test_list, test_suite%suite_required_vars, & + 'required variable names', suite_name=test_suite%suite_name) + else + check = .false. + write(6, '(a,i0,2a)') 'ERROR ', errflg, ': ', trim(errmsg) + end if + check_suite = check_suite .and. check + if (allocated(test_list)) then + deallocate(test_list) + end if + end function check_suite + !> \section arg_table_test_host Argument Table + !! \htmlinclude arg_table_test_host.html + !! + subroutine test_host(retval, test_suites) - !> \section arg_table_test_host Argument Table - !! \htmlinclude arg_table_test_host.html - !! - subroutine test_host(retval, test_suites) +#ifdef _OPENMP + use omp_lib +#endif + use test_host_mod, only: ncols, num_time_steps + use test_host_ccpp_cap, only: test_host_ccpp_physics_register + use test_host_ccpp_cap, only: test_host_ccpp_physics_initialize + use test_host_ccpp_cap, only: test_host_ccpp_physics_timestep_initial + use test_host_ccpp_cap, only: test_host_ccpp_physics_run + use test_host_ccpp_cap, only: test_host_ccpp_physics_timestep_final + use test_host_ccpp_cap, only: test_host_ccpp_physics_finalize + use test_host_ccpp_cap, only: ccpp_physics_suite_list + use test_host_mod, only: init_data, compare_data, check_model_times + use test_utils, only: check_list - use test_host_mod, only: ncols, num_time_steps - use test_host_ccpp_cap, only: test_host_ccpp_physics_register - use test_host_ccpp_cap, only: test_host_ccpp_physics_initialize - use test_host_ccpp_cap, only: test_host_ccpp_physics_timestep_initial - use test_host_ccpp_cap, only: test_host_ccpp_physics_run - use test_host_ccpp_cap, only: test_host_ccpp_physics_timestep_final - use test_host_ccpp_cap, only: test_host_ccpp_physics_finalize - use test_host_ccpp_cap, only: ccpp_physics_suite_list - use test_host_mod, only: init_data, compare_data, check_model_times - use test_utils, only: check_list + type(suite_info), intent(in) :: test_suites(:) + logical, intent(out) :: retval - type(suite_info), intent(in) :: test_suites(:) - logical, intent(out) :: retval + logical :: check + integer :: col_start, col_end + integer :: thread_num, num_threads + integer :: index, sind + integer :: time_step + integer :: num_suites + character(len=128), allocatable :: suite_names(:) + character(len=512) :: errmsg + integer :: errflg - logical :: check - integer :: col_start, col_end - integer :: index, sind - integer :: time_step - integer :: num_suites - character(len=128), allocatable :: suite_names(:) - character(len=512) :: errmsg - integer :: errflg + ! Initialize our 'data' + call init_data() - ! Initialize our 'data' - call init_data() + ! Gather and test the inspection routines + num_suites = size(test_suites) + call ccpp_physics_suite_list(suite_names) + retval = check_list(suite_names, test_suites(:)%suite_name, & + 'suite names') + write(6, *) 'Available suites are:' + do index = 1, size(suite_names) + do sind = 1, num_suites + if (trim(test_suites(sind)%suite_name) == & + trim(suite_names(index))) then + exit + end if + end do + write(6, '(i0,3a,i0,a)') index, ') ', trim(suite_names(index)), & + ' = test_suites(', sind, ')' + end do + if (retval) then + do sind = 1, num_suites + check = check_suite(test_suites(sind)) + retval = retval .and. check + end do + end if + !!! Return here if any check failed + if (.not.retval) then + return + end if - ! Gather and test the inspection routines - num_suites = size(test_suites) - call ccpp_physics_suite_list(suite_names) - retval = check_list(suite_names, test_suites(:)%suite_name, & - 'suite names') - write(6, *) 'Available suites are:' - do index = 1, size(suite_names) - do sind = 1, num_suites - if (trim(test_suites(sind)%suite_name) == & - trim(suite_names(index))) then - exit - end if - end do - write(6, '(i0,3a,i0,a)') index, ') ', trim(suite_names(index)), & - ' = test_suites(', sind, ')' - end do - if (retval) then - do sind = 1, num_suites - check = check_suite(test_suites(sind)) - retval = retval .and. check - end do - end if - !!! Return here if any check failed - if (.not. retval) then - return - end if + ! Use the suite information to call the register phase + do sind = 1, num_suites + call test_host_ccpp_physics_register(test_suites(sind)%suite_name, & + errmsg, errflg) + if (errflg /= 0) then + write(6, '(4a)') 'ERROR in register of ', & + trim(test_suites(sind)%suite_name), ': ', trim(errmsg) + end if + end do + ! Use the suite information to setup the run + do sind = 1, num_suites + call test_host_ccpp_physics_initialize(test_suites(sind)%suite_name, & + errmsg, errflg) + if (errflg /= 0) then + write(6, '(4a)') 'ERROR in initialize of ', & + trim(test_suites(sind)%suite_name), ': ', trim(errmsg) + end if + end do + ! Loop over time steps + do time_step = 1, num_time_steps + ! Initialize the timestep + do sind = 1, num_suites + if (errflg /= 0) then + exit + end if + if (errflg == 0) then + call test_host_ccpp_physics_timestep_initial( & + test_suites(sind)%suite_name, errmsg, errflg) + end if + if (errflg /= 0) then + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(errmsg) + exit + end if + if (errflg /= 0) then + exit + end if + end do - ! Use the suite information to call the register phase - do sind = 1, num_suites - call test_host_ccpp_physics_register(test_suites(sind)%suite_name, & - errmsg, errflg) + run_phase_if_no_error: if (errflg == 0) then +#ifdef _OPENMP + num_threads = omp_get_max_threads() +#else + num_threads = 1 +#endif + !$OMP parallel num_threads (num_threads) & + !$OMP default (none) & + !$OMP shared (num_threads, num_suites, test_suites) & + !$OMP private (thread_num, col_start, col_end, errmsg) & + !$OMP reduction (+:errflg) +#ifdef _OPENMP + thread_num = omp_get_thread_num() +#else + thread_num = 0 +#endif + !$OMP do + do col_start = 1, ncols, 5 if (errflg /= 0) then - write(6, '(4a)') 'ERROR in register of ', & - trim(test_suites(sind)%suite_name), ': ', trim(errmsg) + continue end if - end do - ! Use the suite information to setup the run - do sind = 1, num_suites - call test_host_ccpp_physics_initialize(test_suites(sind)%suite_name, & - errmsg, errflg) - if (errflg /= 0) then - write(6, '(4a)') 'ERROR in initialize of ', & - trim(test_suites(sind)%suite_name), ': ', trim(errmsg) - end if - end do - ! Loop over time steps - do time_step = 1, num_time_steps - ! Initialize the timestep + col_end = min(col_start + 4, ncols) do sind = 1, num_suites - if (errflg /= 0) then - exit - end if - if (errflg == 0) then - call test_host_ccpp_physics_timestep_initial( & - test_suites(sind)%suite_name, errmsg, errflg) - end if - if (errflg /= 0) then - write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(errmsg) - exit - end if - if (errflg /= 0) then - exit - end if + if (errflg /= 0) then + continue + end if + do index = 1, size(test_suites(sind)%suite_parts) + if (errflg /= 0) then + continue + end if + write(0, '(a,i0,a,i0,5a,i0,a,i0)') 'Thread ', thread_num, '/', num_threads, & + ': calling run phase for suite ', trim(test_suites(sind)%suite_name), & + ' part ', trim(test_suites(sind)%suite_parts(index)), & + ' columns ', col_start, ':', col_end + call test_host_ccpp_physics_run( & + test_suites(sind)%suite_name, & + test_suites(sind)%suite_parts(index), & + col_start, col_end, errmsg, errflg) + if (errflg /= 0) then + write(6, '(5a)') trim(test_suites(sind)%suite_name), & + '/', trim(test_suites(sind)%suite_parts(index)), & + ': ', trim(errmsg) + end if + end do end do + end do + !$OMP end do + !$OMP end parallel + end if run_phase_if_no_error - do col_start = 1, ncols, 5 - if (errflg /= 0) then - exit - end if - col_end = MIN(col_start + 4, ncols) + do sind = 1, num_suites + if (errflg /= 0) then + exit + end if + if (errflg == 0) then + call test_host_ccpp_physics_timestep_final( & + test_suites(sind)%suite_name, errmsg, errflg) + end if + if (errflg /= 0) then + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(errmsg) + exit + end if + end do + end do ! End time step loop - do sind = 1, num_suites - if (errflg /= 0) then - exit - end if - do index = 1, size(test_suites(sind)%suite_parts) - if (errflg /= 0) then - exit - end if - if (errflg == 0) then - call test_host_ccpp_physics_run( & - test_suites(sind)%suite_name, & - test_suites(sind)%suite_parts(index), & - col_start, col_end, errmsg, errflg) - end if - if (errflg /= 0) then - write(6, '(5a)') trim(test_suites(sind)%suite_name), & - '/', trim(test_suites(sind)%suite_parts(index)), & - ': ', trim(errmsg) - exit - end if - end do - end do - end do + do sind = 1, num_suites + if (errflg /= 0) then + exit + end if + if (errflg == 0) then + call test_host_ccpp_physics_finalize( & + test_suites(sind)%suite_name, errmsg, errflg) + end if + if (errflg /= 0) then + write(6, '(3a)') test_suites(sind)%suite_parts(index), ': ', & + trim(errmsg) + write(6, '(2a)') 'An error occurred in ccpp_timestep_final, ', & + 'Exiting...' + exit + end if + end do - do sind = 1, num_suites - if (errflg /= 0) then - exit - end if - if (errflg == 0) then - call test_host_ccpp_physics_timestep_final( & - test_suites(sind)%suite_name, errmsg, errflg) - end if - if (errflg /= 0) then - write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(errmsg) - exit - end if - end do - end do ! End time step loop - - do sind = 1, num_suites - if (errflg /= 0) then - exit - end if - if (errflg == 0) then - call test_host_ccpp_physics_finalize( & - test_suites(sind)%suite_name, errmsg, errflg) - end if - if (errflg /= 0) then - write(6, '(3a)') test_suites(sind)%suite_parts(index), ': ', & - trim(errmsg) - write(6,'(2a)') 'An error occurred in ccpp_timestep_final, ', & - 'Exiting...' - exit - end if - end do - - if (errflg == 0) then - ! Run finished without error, check answers - if (.not. check_model_times()) then - write(6, *) 'Model times error!' - errflg = -1 - else if (compare_data()) then - write(6, *) 'Answers are correct!' - errflg = 0 - else - write(6, *) 'Answers are not correct!' - errflg = -1 - end if - end if + if (errflg == 0) then + ! Run finished without error, check answers + if (.not.check_model_times()) then + write(6, *) 'Model times error!' + errflg = -1 + else if (compare_data()) then + write(6, *) 'Answers are correct!' + errflg = 0 + else + write(6, *) 'Answers are not correct!' + errflg = -1 + end if + end if - retval = errflg == 0 + retval = errflg == 0 - end subroutine test_host + end subroutine test_host - end module test_prog +end module test_prog diff --git a/test/capgen_test/test_host_data.F90 b/test/capgen_test/test_host_data.F90 index 1b0a45c1..32c421a4 100644 --- a/test/capgen_test/test_host_data.F90 +++ b/test/capgen_test/test_host_data.F90 @@ -8,15 +8,15 @@ module test_host_data !> \section arg_table_physics_state Argument Table !! \htmlinclude arg_table_physics_state.html type physics_state - real(kind_phys), dimension(:), allocatable :: & - ps, & ! surface pressure - soil_levs ! soil temperature (cm) - real(kind_phys), dimension(:,:), allocatable :: & - u, & ! zonal wind (m/s) - v, & ! meridional wind (m/s) - pmid ! midpoint pressure (Pa) - real(kind_phys), dimension(:,:,:),allocatable :: & - q ! constituent mixing ratio (kg/kg moist or dry air depending on type) + real(kind=kind_phys), dimension(:), allocatable :: & + ps, & ! surface pressure + soil_levs ! soil temperature (cm) + real(kind=kind_phys), dimension(:, :), allocatable :: & + u, & ! zonal wind (m/s) + v, & ! meridional wind (m/s) + pmid ! midpoint pressure (Pa) + real(kind=kind_phys), dimension(:, :, :), allocatable :: & + q ! constituent mixing ratio (kg/kg moist or dry air depending on type) end type physics_state public :: physics_state @@ -25,36 +25,36 @@ module test_host_data contains subroutine allocate_physics_state(cols, levels, constituents, lbnd_slev, ubnd_slev, state) - integer, intent(in) :: cols - integer, intent(in) :: levels - integer, intent(in) :: constituents - integer, intent(in) :: lbnd_slev, ubnd_slev + integer, intent(in) :: cols + integer, intent(in) :: levels + integer, intent(in) :: constituents + integer, intent(in) :: lbnd_slev, ubnd_slev type(physics_state), intent(out) :: state if (allocated(state%ps)) then - deallocate(state%ps) + deallocate(state%ps) end if allocate(state%ps(cols)) if (allocated(state%u)) then - deallocate(state%u) + deallocate(state%u) end if allocate(state%u(cols, levels)) if (allocated(state%v)) then - deallocate(state%v) + deallocate(state%v) end if allocate(state%v(cols, levels)) if (allocated(state%pmid)) then - deallocate(state%pmid) + deallocate(state%pmid) end if allocate(state%pmid(cols, levels)) if (allocated(state%q)) then - deallocate(state%q) + deallocate(state%q) end if allocate(state%q(cols, levels, constituents)) if (allocated(state%soil_levs)) then - deallocate(state%soil_levs) + deallocate(state%soil_levs) end if allocate(state%soil_levs(lbnd_slev:ubnd_slev)) - + end subroutine allocate_physics_state end module test_host_data diff --git a/test/capgen_test/test_host_mod.F90 b/test/capgen_test/test_host_mod.F90 index f2586a77..aecc5f15 100644 --- a/test/capgen_test/test_host_mod.F90 +++ b/test/capgen_test/test_host_mod.F90 @@ -1,45 +1,45 @@ module test_host_mod - use ccpp_kinds, only: kind_phys - use test_host_data, only: physics_state, allocate_physics_state - - implicit none - public - - !> \section arg_table_test_host_mod Argument Table - !! \htmlinclude arg_table_test_host_host.html - !! - integer, parameter :: ncols = 10 - integer, parameter :: pver = 5 - integer, parameter :: pverP = 6 - integer, parameter :: pcnst = 2 - integer, parameter :: slevs = 4 - integer, parameter :: slev_lbound = -3 - integer, parameter :: slev_ubound = 0 - integer, parameter :: DiagDimStart = 2 - integer, parameter :: index_qv = 1 - logical, parameter :: config_var = .true. - real(kind_phys), allocatable :: temp_midpoints(:,:) - real(kind_phys) :: temp_interfaces(ncols, pverP) - real(kind_phys) :: temp_diag(ncols,6) - real(kind_phys) :: coeffs(ncols) - real(kind_phys) :: var_array(ncols,2,4,6) - real(kind_phys), dimension(DiagDimStart:ncols, DiagDimStart:pver) :: & - diag1, & - diag2 - real(kind_phys) :: dt - real(kind_phys), parameter :: temp_inc = 0.05_kind_phys - type(physics_state) :: phys_state - integer :: num_model_times = -1 - integer, allocatable :: model_times(:) - - integer, parameter :: num_time_steps = 2 - real(kind_phys), parameter :: tolerance = 1.0e-13_kind_phys - real(kind_phys) :: tint_save(ncols, pverP) - - public :: init_data - public :: compare_data - public :: check_model_times + use ccpp_kinds, only: kind_phys + use test_host_data, only: physics_state, allocate_physics_state + + implicit none + public + + !> \section arg_table_test_host_mod Argument Table + !! \htmlinclude arg_table_test_host_host.html + !! + integer, parameter :: ncols = 10 + integer, parameter :: pver = 5 + integer, parameter :: pverp = 6 + integer, parameter :: pcnst = 2 + integer, parameter :: slevs = 4 + integer, parameter :: slev_lbound = -3 + integer, parameter :: slev_ubound = 0 + integer, parameter :: diagdimstart = 2 + integer, parameter :: index_qv = 1 + logical, parameter :: config_var = .true. + real(kind=kind_phys), allocatable :: temp_midpoints(:, :) + real(kind=kind_phys) :: temp_interfaces(ncols, pverp) + real(kind=kind_phys) :: temp_diag(ncols, 6) + real(kind=kind_phys) :: coeffs(ncols) + real(kind=kind_phys) :: var_array(ncols, 2, 4, 6) + real(kind=kind_phys), dimension(diagdimstart:ncols, diagdimstart:pver) :: & + diag1, & + diag2 + real(kind=kind_phys) :: dt + real(kind=kind_phys), parameter :: temp_inc = 0.05_kind_phys + type(physics_state) :: phys_state + integer :: num_model_times = -1 + integer, allocatable :: model_times(:) + + integer, parameter :: num_time_steps = 2 + real(kind=kind_phys), parameter :: tolerance = 1.0e-13_kind_phys + real(kind=kind_phys) :: tint_save(ncols, pverp) + + public :: init_data + public :: compare_data + public :: check_model_times contains @@ -53,22 +53,23 @@ subroutine init_data() ! Allocate and initialize temperature allocate(temp_midpoints(ncols, pver)) temp_midpoints = 0.0_kind_phys - do lev = 1, pverP - offsize = ((cind - 1) * (ncols * pver)) + ((lev - 1) * ncols) - do col = 1, ncols - temp_interfaces(col, lev) = real(offsize + col, kind=kind_phys) - tint_save(col, lev) = temp_interfaces(col, lev) - end do + cind = 1 + do lev = 1, pverp + offsize = ((cind - 1) * (ncols * pver)) + ((lev - 1) * ncols) + do col = 1, ncols + temp_interfaces(col, lev) = real(offsize + col, kind=kind_phys) + tint_save(col, lev) = temp_interfaces(col, lev) + end do end do ! Allocate and initialize state call allocate_physics_state(ncols, pver, pcnst, slev_lbound, slev_ubound, phys_state) do cind = 1, pcnst - do lev = 1, pver - offsize = ((cind - 1) * (ncols * pver)) + ((lev - 1) * ncols) - do col = 1, ncols - phys_state%q(col, lev, cind) = real(offsize + col, kind=kind_phys) - end do - end do + do lev = 1, pver + offsize = ((cind - 1) * (ncols * pver)) + ((lev - 1) * ncols) + do col = 1, ncols + phys_state%q(col, lev, cind) = real(offsize + col, kind=kind_phys) + end do + end do end do end subroutine init_data @@ -77,70 +78,86 @@ logical function check_model_times() check_model_times = (num_model_times > 0) if (check_model_times) then - check_model_times = (size(model_times) == num_model_times) - if (.not. check_model_times) then - write(6, '(2(a,i0))') 'model_times size mismatch, ', & - size(model_times), ' should be ', num_model_times - end if + check_model_times = (size(model_times) == num_model_times) + if (.not.check_model_times) then + write(6, '(2(a,i0))') 'model_times size mismatch, ', & + size(model_times), ' should be ', num_model_times + end if else - write(6, '(a,i0,a)') 'num_model_times mismatch, ',num_model_times, & - ' should be greater than zero' + write(6, '(a,i0,a)') 'num_model_times mismatch, ', num_model_times, & + ' should be greater than zero' end if end function check_model_times logical function compare_data() - integer :: col - integer :: lev - integer :: cind - integer :: offsize - logical :: need_header - real(kind_phys) :: avg + integer :: col + integer :: lev + integer :: cind + integer :: offsize + logical :: need_header + real(kind=kind_phys) :: avg integer, parameter :: cincrements(pcnst) = (/ 1, 0 /) + real(kind=kind_phys) :: total_test + real(kind=kind_phys), parameter :: total_ref = 6730.0_kind_phys compare_data = .true. + total_test = 0.0_kind_phys need_header = .true. do lev = 1, pver - do col = 1, ncols - avg = (tint_save(col,lev) + tint_save(col,lev+1)) - avg = 1.0_kind_phys + (avg / 2.0_kind_phys) - avg = avg + (temp_inc * num_time_steps) - if (abs((temp_midpoints(col, lev) - avg) / avg) > tolerance) then - if (need_header) then - write(6, '(" COL LEV T MIDPOINTS EXPECTED")') - need_header = .false. - end if - write(6, '(2i5,2(3x,es15.7))') col, lev, & - temp_midpoints(col, lev), avg - compare_data = .false. + do col = 1, ncols + avg = (tint_save(col, lev) + tint_save(col, lev + 1)) + avg = 1.0_kind_phys + (avg / 2.0_kind_phys) + avg = avg + (temp_inc * num_time_steps) + total_test = total_test + avg + if (abs((temp_midpoints(col, lev) - avg) / avg) > tolerance) then + if (need_header) then + write(6, '(" COL LEV T MIDPOINTS EXPECTED")') + need_header = .false. end if - end do + write(6, '(2i5,2(3x,es15.7))') col, lev, & + temp_midpoints(col, lev), avg + compare_data = .false. + end if + end do end do ! Check constituents need_header = .true. do cind = 1, pcnst - do lev = 1, pver - offsize = ((cind - 1) * (ncols * pver)) + ((lev - 1) * ncols) - do col = 1, ncols - avg = real(offsize + col + (cincrements(cind) * num_time_steps), & - kind=kind_phys) - if (abs((phys_state%q(col, lev, cind) - avg) / avg) > & - tolerance) then - if (need_header) then - write(6, '(2(2x,a),3x,a,10x,a,14x,a)') & - 'COL', 'LEV', 'C#', 'Q', 'EXPECTED' - need_header = .false. - end if - write(6, '(3i5,2(3x,es15.7))') col, lev, cind, & - phys_state%q(col, lev, cind), avg - compare_data = .false. - end if - end do - end do + do lev = 1, pver + offsize = ((cind - 1) * (ncols * pver)) + ((lev - 1) * ncols) + do col = 1, ncols + avg = real(offsize + col + (cincrements(cind) * num_time_steps), & + kind=kind_phys) + total_test = total_test + avg + if (abs((phys_state%q(col, lev, cind) - avg) / avg) > & + tolerance) then + if (need_header) then + write(6, '(2(2x,a),3x,a,10x,a,14x,a)') & + 'COL', 'LEV', 'C#', 'Q', 'EXPECTED' + need_header = .false. + end if + write(6, '(3i5,2(3x,es15.7))') col, lev, cind, & + phys_state%q(col, lev, cind), avg + compare_data = .false. + end if + end do + end do end do - + if (abs((total_test - total_ref) / total_ref) > tolerance) then + write(6, '(a,e12.4)') 'TOTAL REFERENCE: ', total_ref + write(6, '(a,e12.4)') 'TOTAL TEST: ', total_test + write(6, '(2(a,e12.4))') 'REL.DIFF > TOLERANCE:', & + abs((total_test - total_ref) / total_ref), ' >', tolerance + compare_data = .false. + else + write(0, '(a,e12.4)') 'TOTAL REFERENCE: ', total_ref + write(0, '(a,e12.4)') 'TOTAL TEST: ', total_test + write(0, '(2(a,e12.4))') 'REL.DIFF < TOLERANCE:', & + abs((total_test - total_ref) / total_ref), ' <', tolerance + end if end function compare_data end module test_host_mod