From 2992b2ec45d0cdf1ef8ed6512d5565d1989e02aa Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 13 Apr 2026 08:12:10 -0600 Subject: [PATCH 1/6] Update .codee-format: 'LogicalNot: NoTrailing --> Both' --- .codee-format | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.codee-format b/.codee-format index 3ca99f97..bf2b136d 100644 --- a/.codee-format +++ b/.codee-format @@ -88,7 +88,7 @@ SpacesAroundOperators: Relational: Both RelationalLegacy: Both LogicalBinary: Both - LogicalNot: NoTrailing + LogicalNot: Both UnaryPlusMinus: NoTrailing Comma: OnlyTrailing Concat: Both From 4eef8c388f9193206bdfaa0253d9fdcdb63bb073 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 14 Apr 2026 16:08:17 -0600 Subject: [PATCH 2/6] Codee format all files --- doc/HelloWorld/hello_scheme.F90 | 92 +- doc/HelloWorld/hello_world_host.F90 | 45 +- doc/HelloWorld/hello_world_mod.F90 | 78 +- doc/HelloWorld/temp_adjust.F90 | 84 +- logging/logging.F90 | 320 +-- src/ccpp_constituent_prop_mod.F90 | 22 +- src/ccpp_hash_table.F90 | 6 +- src/ccpp_scheme_utils.F90 | 5 +- stub/data.F90 | 16 +- stub/stub.F90 | 48 +- .../apply_constituent_tendencies.F90 | 50 +- test/advection_test/cld_ice.F90 | 220 +- test/advection_test/cld_liq.F90 | 182 +- test/advection_test/const_indices.F90 | 173 +- test/advection_test/dlc_liq.F90 | 58 +- .../test_advection_host_integration.F90 | 137 +- test/advection_test/test_host.F90 | 2166 +++++++++-------- test/advection_test/test_host_data.F90 | 98 +- test/advection_test/test_host_mod.F90 | 323 +-- test/capgen_test/adjust/temp_kinds.F90 | 8 +- .../source_dir1/environ_conditions.F90 | 102 +- test/capgen_test/source_dir2/temp_set.F90 | 149 +- test/capgen_test/temp_adjust.F90 | 5 +- .../test_capgen_host_integration.F90 | 5 +- test/capgen_test/test_host.F90 | 11 +- test/capgen_test/test_host_mod.F90 | 5 +- test/ddthost_test/environ_conditions.F90 | 82 +- test/ddthost_test/host_ccpp_ddt.F90 | 22 +- test/ddthost_test/make_ddt.F90 | 241 +- test/ddthost_test/setup_coeffs.F90 | 6 +- test/ddthost_test/temp_set.F90 | 106 +- .../test_ddt_host_integration.F90 | 139 +- test/ddthost_test/test_host.F90 | 488 ++-- test/ddthost_test/test_host_data.F90 | 34 +- test/ddthost_test/test_host_mod.F90 | 181 +- test/hash_table_tests/test_hash.F90 | 401 +-- test/nested_suite_test/ccpp_kinds.F90 | 10 +- test/nested_suite_test/effr_calc.F90 | 154 +- test/nested_suite_test/effr_diag.F90 | 94 +- test/nested_suite_test/effr_post.F90 | 102 +- test/nested_suite_test/effr_pre.F90 | 98 +- test/nested_suite_test/effrs_calc.F90 | 34 +- test/nested_suite_test/module_rad_ddt.F90 | 10 +- test/nested_suite_test/rad_lw.F90 | 18 +- test/nested_suite_test/rad_sw.F90 | 18 +- test/nested_suite_test/test_host.F90 | 466 ++-- test/nested_suite_test/test_host_data.F90 | 117 +- test/nested_suite_test/test_host_mod.F90 | 182 +- .../test_nested_suite_integration.F90 | 157 +- .../sample_files/test_fortran_to_metadata.F90 | 22 +- .../sample_host_files/data1_mod.F90 | 12 +- test/unit_tests/sample_host_files/ddt1.F90 | 20 +- test/unit_tests/sample_host_files/ddt2.F90 | 32 +- .../sample_host_files/ddt2_extra_var.F90 | 46 +- .../sample_host_files/ddt_data1_mod.F90 | 42 +- .../sample_host_files/mismatch_hdim_mod.F90 | 12 +- .../sample_scheme_files/invalid_dummy_arg.F90 | 42 +- .../invalid_subr_stmnt.F90 | 20 +- .../sample_scheme_files/mismatch_hdim.F90 | 36 +- .../sample_scheme_files/mismatch_intent.F90 | 58 +- .../sample_scheme_files/missing_arg_table.F90 | 58 +- .../missing_fort_header.F90 | 58 +- .../sample_scheme_files/reorder.F90 | 58 +- .../sample_scheme_files/temp_adjust.F90 | 82 +- test/utils/test_utils.F90 | 150 +- test/var_compatibility_test/effr_calc.F90 | 154 +- test/var_compatibility_test/effr_diag.F90 | 94 +- test/var_compatibility_test/effr_post.F90 | 102 +- test/var_compatibility_test/effr_pre.F90 | 98 +- test/var_compatibility_test/effrs_calc.F90 | 34 +- .../var_compatibility_test/module_rad_ddt.F90 | 10 +- test/var_compatibility_test/rad_lw.F90 | 18 +- test/var_compatibility_test/rad_sw.F90 | 18 +- test/var_compatibility_test/test_host.F90 | 466 ++-- .../var_compatibility_test/test_host_data.F90 | 117 +- test/var_compatibility_test/test_host_mod.F90 | 182 +- .../test_var_compatibility_integration.F90 | 151 +- .../test_blocked_data/blocked_data_scheme.F90 | 212 +- test_prebuild/test_blocked_data/data.F90 | 54 +- test_prebuild/test_blocked_data/main.F90 | 217 +- .../test_chunked_data/chunked_data_scheme.F90 | 212 +- test_prebuild/test_chunked_data/data.F90 | 58 +- test_prebuild/test_chunked_data/main.F90 | 212 +- test_prebuild/test_opt_arg/ccpp_kinds.F90 | 12 +- test_prebuild/test_opt_arg/data.F90 | 28 +- test_prebuild/test_opt_arg/main.F90 | 238 +- test_prebuild/test_opt_arg/opt_arg_scheme.F90 | 152 +- test_prebuild/test_unit_conv/ccpp_kinds.F90 | 12 +- test_prebuild/test_unit_conv/data.F90 | 32 +- test_prebuild/test_unit_conv/main.F90 | 178 +- .../test_unit_conv/unit_conv_scheme_1.F90 | 109 +- .../test_unit_conv/unit_conv_scheme_2.F90 | 108 +- 92 files changed, 5845 insertions(+), 5749 deletions(-) diff --git a/doc/HelloWorld/hello_scheme.F90 b/doc/HelloWorld/hello_scheme.F90 index 28019deb..b97c3472 100644 --- a/doc/HelloWorld/hello_scheme.F90 +++ b/doc/HelloWorld/hello_scheme.F90 @@ -1,64 +1,64 @@ !Hello demonstration parameterization ! -MODULE hello_scheme +module hello_scheme - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: hello_scheme_init - PUBLIC :: hello_scheme_run - PUBLIC :: hello_scheme_finalize + public :: hello_scheme_init + public :: hello_scheme_run + public :: hello_scheme_finalize -CONTAINS +contains -!> \section arg_table_hello_scheme_run Argument Table -!! \htmlinclude arg_table_hello_scheme_run.html -!! - SUBROUTINE hello_scheme_run(ncol, lev, ilev, timestep, temp_level, & - temp_layer, errmsg, errflg) -!---------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------- + !> \section arg_table_hello_scheme_run Argument Table + !! \htmlinclude arg_table_hello_scheme_run.html + !! + subroutine hello_scheme_run(ncol, lev, ilev, timestep, temp_level, & + temp_layer, errmsg, errflg) + !---------------------------------------------------------------- + implicit none + !---------------------------------------------------------------- - integer, intent(in) :: ncol, lev, ilev - REAL(kind_phys), intent(inout) :: temp_level(:, :) - real(kind_phys), intent(in) :: timestep - REAL(kind_phys), INTENT(out) :: temp_layer(:, :) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg -!---------------------------------------------------------------- + integer, intent(in) :: ncol, lev, ilev + real(kind=kind_phys), intent(inout) :: temp_level(:, :) + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(out) :: temp_layer(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- - integer :: col_index - integer :: lev_index + integer :: col_index + integer :: lev_index errmsg = '' errflg = 0 if (ilev /= (lev + 1)) then - errflg = 1 - errmsg = 'Invalid value for ilev, must be lev+1' - return + errflg = 1 + errmsg = 'Invalid value for ilev, must be lev+1' + return end if do col_index = 1, ncol - do lev_index = 1, lev - temp_layer(col_index, lev_index) = (temp_level(col_index, lev_index) & - + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys - end do + do lev_index = 1, lev + temp_layer(col_index, lev_index) = (temp_level(col_index, lev_index) & + + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys + end do end do - END SUBROUTINE hello_scheme_run + end subroutine hello_scheme_run -!> \section arg_table_hello_scheme_init Argument Table -!! \htmlinclude arg_table_hello_scheme_init.html -!! - subroutine hello_scheme_init (errmsg, errflg) + !> \section arg_table_hello_scheme_init Argument Table + !! \htmlinclude arg_table_hello_scheme_init.html + !! + subroutine hello_scheme_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 @@ -67,13 +67,13 @@ subroutine hello_scheme_init (errmsg, errflg) end subroutine hello_scheme_init -!> \section arg_table_hello_scheme_finalize Argument Table -!! \htmlinclude arg_table_hello_scheme_finalize.html -!! - subroutine hello_scheme_finalize (errmsg, errflg) + !> \section arg_table_hello_scheme_finalize Argument Table + !! \htmlinclude arg_table_hello_scheme_finalize.html + !! + subroutine hello_scheme_finalize(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 @@ -82,4 +82,4 @@ subroutine hello_scheme_finalize (errmsg, errflg) end subroutine hello_scheme_finalize -END MODULE hello_scheme +end module hello_scheme diff --git a/doc/HelloWorld/hello_world_host.F90 b/doc/HelloWorld/hello_world_host.F90 index 2c4066de..2e2c3ee2 100644 --- a/doc/HelloWorld/hello_world_host.F90 +++ b/doc/HelloWorld/hello_world_host.F90 @@ -7,50 +7,51 @@ module hello_world_host public hello_world_sub -CONTAINS +contains !> \section arg_table_hello_world_sub Argument Table !! \htmlinclude arg_table_hello_world_sub.html !! subroutine hello_world_sub() - use hello_world_mod, only: ncols - use HelloWorld_ccpp_cap, only: HelloWorld_ccpp_physics_initialize - use HelloWorld_ccpp_cap, only: HelloWorld_ccpp_physics_timestep_initial - use HelloWorld_ccpp_cap, only: HelloWorld_ccpp_physics_run - use HelloWorld_ccpp_cap, only: HelloWorld_ccpp_physics_timestep_final - use HelloWorld_ccpp_cap, only: HelloWorld_ccpp_physics_finalize - use HelloWorld_ccpp_cap, only: ccpp_physics_suite_list - use HelloWorld_ccpp_cap, only: ccpp_physics_suite_part_list - use hello_world_mod, only: init_temp, compare_temp - - integer :: col_start, col_end - integer :: index + use hello_world_mod, only: ncols + use helloworld_ccpp_cap, only: helloworld_ccpp_physics_initialize + use helloworld_ccpp_cap, only: helloworld_ccpp_physics_timestep_initial + use helloworld_ccpp_cap, only: helloworld_ccpp_physics_run + use helloworld_ccpp_cap, only: helloworld_ccpp_physics_timestep_final + use helloworld_ccpp_cap, only: helloworld_ccpp_physics_finalize + use helloworld_ccpp_cap, only: ccpp_physics_suite_list + use helloworld_ccpp_cap, only: ccpp_physics_suite_part_list + use hello_world_mod, only: init_temp, & + compare_temp + + integer :: col_start, col_end + integer :: index character(len=128), allocatable :: part_names(:) - character(len=512) :: errmsg - integer :: errflg + character(len=512) :: errmsg + integer :: errflg ! Initialize our 'data' call init_temp() ! Use the suite information to setup the run - call HelloWorld_ccpp_physics_initialize('hello_world_suite', errmsg, errflg) + call helloworld_ccpp_physics_initialize('hello_world_suite', errmsg, errflg) if (errflg /= 0) then write(6, *) trim(errmsg) stop end if ! Initialize the timestep - call HelloWorld_ccpp_physics_timestep_initial('hello_world_suite', errmsg, errflg) + call helloworld_ccpp_physics_timestep_initial('hello_world_suite', errmsg, errflg) if (errflg /= 0) then write(6, *) trim(errmsg) stop end if do col_start = 1, ncols, 5 - col_end = MIN(col_start + 4, ncols) + col_end = min(col_start + 4, ncols) - call HelloWorld_ccpp_physics_run('hello_world_suite', 'physics', col_start, col_end, errmsg, errflg) + call helloworld_ccpp_physics_run('hello_world_suite', 'physics', col_start, col_end, errmsg, errflg) if (errflg /= 0) then write(6, *) trim(errmsg) call ccpp_physics_suite_part_list('hello_world_suite', part_names, errmsg, errflg) @@ -62,12 +63,12 @@ subroutine hello_world_sub() end if end do - call HelloWorld_ccpp_physics_timestep_final('hello_world_suite', errmsg, errflg) + call helloworld_ccpp_physics_timestep_final('hello_world_suite', errmsg, errflg) - call HelloWorld_ccpp_physics_finalize('hello_world_suite', errmsg, errflg) + call helloworld_ccpp_physics_finalize('hello_world_suite', errmsg, errflg) if (errflg /= 0) then write(6, *) trim(errmsg) - write(6,'(a)') 'An error occurred in ccpp_timestep_final, Exiting...' + write(6, '(a)') 'An error occurred in ccpp_timestep_final, Exiting...' stop end if diff --git a/doc/HelloWorld/hello_world_mod.F90 b/doc/HelloWorld/hello_world_mod.F90 index 44b689dd..42db1c5b 100644 --- a/doc/HelloWorld/hello_world_mod.F90 +++ b/doc/HelloWorld/hello_world_mod.F90 @@ -1,59 +1,59 @@ module hello_world_mod - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - public + implicit none + public - integer :: ntimes_loop - !> \section arg_table_hello_world_mod Argument Table - !! \htmlinclude arg_table_hello_world_host.html - !! - integer, parameter :: ncols = 10 - integer, parameter :: pver = 5 - integer, parameter :: pverp = 6 - real(kind_phys) :: temp_midpoints(ncols, pver) - real(kind_phys) :: temp_interfaces(ncols, pverp) - real(kind_phys) :: dt + integer :: ntimes_loop + !> \section arg_table_hello_world_mod Argument Table + !! \htmlinclude arg_table_hello_world_host.html + !! + integer, parameter :: ncols = 10 + integer, parameter :: pver = 5 + integer, parameter :: pverp = 6 + real(kind=kind_phys) :: temp_midpoints(ncols, pver) + real(kind=kind_phys) :: temp_interfaces(ncols, pverp) + real(kind=kind_phys) :: dt - public :: init_temp - public :: compare_temp + public :: init_temp + public :: compare_temp contains - subroutine init_temp() + subroutine init_temp() - integer :: col - integer :: lev + integer :: col + integer :: lev - temp_midpoints = 0.0_kind_phys - do lev = 1, pverp - do col = 1, ncols - temp_interfaces(col, lev) = real(((lev - 1) * ncols) + col, kind=kind_phys) - end do + temp_midpoints = 0.0_kind_phys + do lev = 1, pverp + do col = 1, ncols + temp_interfaces(col, lev) = real(((lev - 1) * ncols) + col, kind=kind_phys) end do + end do - end subroutine init_temp + end subroutine init_temp - logical function compare_temp() + logical function compare_temp() - integer :: col - integer :: lev - real(kind_phys) :: avg + integer :: col + integer :: lev + real(kind=kind_phys) :: avg - compare_temp = .true. + compare_temp = .true. - do lev = 1, pver - do col = 1, ncols - avg = (temp_interfaces(col,lev) + temp_interfaces(col,lev+1)) - avg = 1.0_kind_phys + (avg / 2.0_kind_phys) - if (temp_midpoints(col, lev) /= avg) then - write(6, *) col, lev, temp_midpoints(col, lev), avg - compare_temp = .false. - end if - end do + do lev = 1, pver + do col = 1, ncols + avg = (temp_interfaces(col, lev) + temp_interfaces(col, lev + 1)) + avg = 1.0_kind_phys + (avg / 2.0_kind_phys) + if (temp_midpoints(col, lev) /= avg) then + write(6, *) col, lev, temp_midpoints(col, lev), avg + compare_temp = .false. + end if end do + end do - end function compare_temp + end function compare_temp end module hello_world_mod diff --git a/doc/HelloWorld/temp_adjust.F90 b/doc/HelloWorld/temp_adjust.F90 index 4b6f6186..df8bc5b2 100644 --- a/doc/HelloWorld/temp_adjust.F90 +++ b/doc/HelloWorld/temp_adjust.F90 @@ -1,57 +1,57 @@ !Hello demonstration parameterization ! -MODULE temp_adjust +module temp_adjust - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: temp_adjust_init - PUBLIC :: temp_adjust_run - PUBLIC :: temp_adjust_finalize + public :: temp_adjust_init + public :: temp_adjust_run + public :: temp_adjust_finalize -CONTAINS +contains -!> \section arg_table_temp_adjust_run Argument Table -!! \htmlinclude arg_table_temp_adjust_run.html -!! - SUBROUTINE temp_adjust_run(nbox, lev, temp_layer, & - timestep, errmsg, errflg) -!---------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------- + !> \section arg_table_temp_adjust_run Argument Table + !! \htmlinclude arg_table_temp_adjust_run.html + !! + subroutine temp_adjust_run(nbox, lev, temp_layer, & + timestep, errmsg, errflg) + !---------------------------------------------------------------- + implicit none + !---------------------------------------------------------------- - integer, intent(in) :: nbox, lev - REAL(kind_phys), intent(inout) :: temp_layer(:, :) - real(kind_phys), intent(in) :: timestep - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg -!---------------------------------------------------------------- + integer, intent(in) :: nbox, lev + real(kind=kind_phys), intent(inout) :: temp_layer(:, :) + real(kind=kind_phys), intent(in) :: timestep + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- - integer :: box_index - integer :: lev_index + integer :: box_index + integer :: lev_index errmsg = '' errflg = 0 do box_index = 1, nbox - do lev_index = 1, lev - temp_layer(box_index, lev_index) = temp_layer(box_index, lev_index) & - + 1.0_kind_phys - end do + do lev_index = 1, lev + temp_layer(box_index, lev_index) = temp_layer(box_index, lev_index) & + + 1.0_kind_phys + end do end do - 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) + !> \section arg_table_temp_adjust_init Argument Table + !! \htmlinclude arg_table_temp_adjust_init.html + !! + 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 @@ -60,13 +60,13 @@ subroutine temp_adjust_init (errmsg, errflg) end subroutine temp_adjust_init -!> \section arg_table_temp_adjust_finalize Argument Table -!! \htmlinclude arg_table_temp_adjust_finalize.html -!! - subroutine temp_adjust_finalize (errmsg, errflg) + !> \section arg_table_temp_adjust_finalize Argument Table + !! \htmlinclude arg_table_temp_adjust_finalize.html + !! + subroutine temp_adjust_finalize(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 @@ -75,4 +75,4 @@ subroutine temp_adjust_finalize (errmsg, errflg) end subroutine temp_adjust_finalize -END MODULE temp_adjust +end module temp_adjust diff --git a/logging/logging.F90 b/logging/logging.F90 index 59e82786..9567bd5e 100644 --- a/logging/logging.F90 +++ b/logging/logging.F90 @@ -1,58 +1,58 @@ module marbl_logging -! ============ -! Module Usage -! ============ -! -! Assume a variable named StatusLog (as appears in the marbl_interface_class) -! -! ----------------------------------------------- -! Use the following routines to write log entries -! ----------------------------------------------- -! -! (1) StatusLog%log_noerror -- this stores a log message in StatusLog that does -! not contain a fatal error -! (2) StatusLog%log_header -- this stores a log message in StatusLog that is -! meant to be read as a section header; e.g. StatusLog%log_header('HEADER',...) -! writes the following (including blank lines) -! -! ------ -! HEADER -! ------ -! -! (3) StatusLog%log_error -- this stores a log message in StatusLog that DOES -! contain a fatal error. It does this by setting StatusLog%labort_marbl = -! .true.; when a call from the GCM to MARBL returns, it is important for the -! GCM to check the value of StatusLog%labort_marbl and abort the run if an -! error has been reported. -! (4) StatusLog%log_error_trace -- this stores a log message in StatusLog -! detailing what subroutine was just called and where it was called from. It -! is meant to provide more information when trying to trace the path through -! the code that resulted in an error. -! -! ----------------------------------------------- -! Pseudo-code for writing StatusLog in the driver -! ----------------------------------------------- -! -! type(marbl_status_log_entry_type), pointer :: LogEntry -! -! ! Set pointer to first entry of the log -! LogEntry => StatusLog%FullLog -! -! do while (associated(LogEntry)) -! ! If running in parallel, you may want to check if you are the master -! ! task or if LogEntry%lalltasks = .true. -! write(stdout,*) trim(LogEntry%LogMessage) -! LogEntry => LogEntry%next -! end do -! -! ! Erase contents of log now that they have been written out -! call StatusLog%erase() -! -! if (StatusLog%labort_marbl) then -! [GCM abort call: "error found in MARBL"] -! end if -! + ! ============ + ! Module Usage + ! ============ + ! + ! Assume a variable named StatusLog (as appears in the marbl_interface_class) + ! + ! ----------------------------------------------- + ! Use the following routines to write log entries + ! ----------------------------------------------- + ! + ! (1) StatusLog%log_noerror -- this stores a log message in StatusLog that does + ! not contain a fatal error + ! (2) StatusLog%log_header -- this stores a log message in StatusLog that is + ! meant to be read as a section header; e.g. StatusLog%log_header('HEADER',...) + ! writes the following (including blank lines) + ! + ! ------ + ! HEADER + ! ------ + ! + ! (3) StatusLog%log_error -- this stores a log message in StatusLog that DOES + ! contain a fatal error. It does this by setting StatusLog%labort_marbl = + ! .true.; when a call from the GCM to MARBL returns, it is important for the + ! GCM to check the value of StatusLog%labort_marbl and abort the run if an + ! error has been reported. + ! (4) StatusLog%log_error_trace -- this stores a log message in StatusLog + ! detailing what subroutine was just called and where it was called from. It + ! is meant to provide more information when trying to trace the path through + ! the code that resulted in an error. + ! + ! ----------------------------------------------- + ! Pseudo-code for writing StatusLog in the driver + ! ----------------------------------------------- + ! + ! type(marbl_status_log_entry_type), pointer :: LogEntry + ! + ! ! Set pointer to first entry of the log + ! LogEntry => StatusLog%FullLog + ! + ! do while (associated(LogEntry)) + ! ! If running in parallel, you may want to check if you are the master + ! ! task or if LogEntry%lalltasks = .true. + ! write(stdout,*) trim(LogEntry%LogMessage) + ! LogEntry => LogEntry%next + ! end do + ! + ! ! Erase contents of log now that they have been written out + ! call StatusLog%erase() + ! + ! if (StatusLog%labort_marbl) then + ! [GCM abort call: "error found in MARBL"] + ! end if + ! use marbl_kinds_mod, only : char_len @@ -60,16 +60,16 @@ module marbl_logging private save - integer, parameter, private :: marbl_log_len = 2*char_len + integer, parameter, private :: marbl_log_len = 2 * char_len !**************************************************************************** type, public :: marbl_status_log_entry_type - integer :: ElementInd = -1 ! ElementInd < 0 implies no location data - logical :: lonly_master_writes ! True => message should be written to stdout - ! master task; False => all tasks - character(len=marbl_log_len) :: LogMessage ! Message text - character(len=char_len) :: CodeLocation ! Information on where log was written + integer :: elementind = -1 ! ElementInd < 0 implies no location data + logical :: lonly_master_writes ! True => message should be written to stdout + ! master task; False => all tasks + character(len=marbl_log_len) :: logmessage ! Message text + character(len=char_len) :: codelocation ! Information on where log was written type(marbl_status_log_entry_type), pointer :: next end type marbl_status_log_entry_type @@ -89,12 +89,12 @@ module marbl_logging ! code in this file. type, private :: marbl_log_output_options_type logical :: labort_on_warning ! True => elevate Warnings to Errors - logical :: lLogVerbose ! Debugging output should be given Verbose label - logical :: lLogNamelist ! Write namelists to log? - logical :: lLogGeneral ! General diagnostic output - logical :: lLogWarning ! Warnings (can be elevated to errors via labort_on_warning) - logical :: lLogError ! Errors (will toggle labort_marbl whether log - ! is written or not) + logical :: llogverbose ! Debugging output should be given Verbose label + logical :: llognamelist ! Write namelists to log? + logical :: lloggeneral ! General diagnostic output + logical :: llogwarning ! Warnings (can be elevated to errors via labort_on_warning) + logical :: llogerror ! Errors (will toggle labort_marbl whether log + ! is written or not) contains procedure :: construct => marbl_output_options_constructor end type marbl_log_output_options_type @@ -103,17 +103,17 @@ module marbl_logging type, public :: marbl_log_type logical, private :: lconstructed = .false. ! True => constructor was already called - logical, public :: labort_marbl = .false. ! True => driver should abort GCM - logical, public :: lwarning = .false. ! True => warnings are present - type(marbl_log_output_options_type) :: OutputOptions - type(marbl_status_log_entry_type), pointer :: FullLog - type(marbl_status_log_entry_type), pointer :: LastEntry + logical, public :: labort_marbl = .false. ! True => driver should abort GCM + logical, public :: lwarning = .false. ! True => warnings are present + type(marbl_log_output_options_type) :: outputoptions + type(marbl_status_log_entry_type), pointer :: fulllog + type(marbl_status_log_entry_type), pointer :: lastentry contains procedure, public :: construct => marbl_log_constructor - procedure, public :: log_header => marbl_log_header - procedure, public :: log_error => marbl_log_error - procedure, public :: log_warning => marbl_log_warning - procedure, public :: log_noerror => marbl_log_noerror + procedure, public :: log_header => marbl_log_header + procedure, public :: log_error => marbl_log_error + procedure, public :: log_warning => marbl_log_warning + procedure, public :: log_noerror => marbl_log_noerror procedure, public :: log_error_trace => marbl_log_error_trace procedure, public :: log_warning_trace => marbl_log_warning_trace procedure, public :: erase => marbl_log_erase @@ -126,12 +126,12 @@ module marbl_logging !**************************************************************************** - subroutine marbl_output_options_constructor(this, labort_on_warning, LogVerbose, LogNamelist, & - LogGeneral, LogWarning, LogError) + subroutine marbl_output_options_constructor(this, labort_on_warning, logverbose, lognamelist, & + loggeneral, logwarning, logerror) class(marbl_log_output_options_type), intent(inout) :: this - logical, intent(in), optional :: labort_on_warning, LogVerbose, LogNamelist - logical, intent(in), optional :: LogGeneral, LogWarning, LogError + logical, intent(in), optional :: labort_on_warning, logverbose, lognamelist + logical, intent(in), optional :: loggeneral, logwarning, logerror if (present(labort_on_warning)) then this%labort_on_warning = labort_on_warning @@ -139,34 +139,34 @@ subroutine marbl_output_options_constructor(this, labort_on_warning, LogVerbose, this%labort_on_warning = .false. end if - if (present(LogVerbose)) then - this%lLogVerbose = LogVerbose + if (present(logverbose)) then + this%llogverbose = logverbose else - this%lLogVerbose = .false. + this%llogverbose = .false. end if - if (present(LogNamelist)) then - this%lLogNamelist = LogNamelist + if (present(lognamelist)) then + this%llognamelist = lognamelist else - this%lLogNamelist = .true. + this%llognamelist = .true. end if - if (present(LogGeneral)) then - this%lLogGeneral = LogGeneral + if (present(loggeneral)) then + this%lloggeneral = loggeneral else - this%lLogGeneral = .true. + this%lloggeneral = .true. end if - if (present(LogWarning)) then - this%lLogWarning = LogWarning + if (present(logwarning)) then + this%llogwarning = logwarning else - this%lLogWarning = .true. + this%llogwarning = .true. end if - if (present(LogError)) then - this%lLogError = LogError + if (present(logerror)) then + this%llogerror = logerror else - this%lLogError = .true. + this%llogerror = .true. end if end subroutine marbl_output_options_constructor @@ -179,162 +179,162 @@ subroutine marbl_log_constructor(this) if (this%lconstructed) return this%lconstructed = .true. - nullify(this%FullLog) - nullify(this%LastEntry) - call this%OutputOptions%construct() + nullify(this%fulllog) + nullify(this%lastentry) + call this%outputoptions%construct() end subroutine marbl_log_constructor !**************************************************************************** - subroutine marbl_log_header(this, HeaderMsg, CodeLoc) + subroutine marbl_log_header(this, headermsg, codeloc) class(marbl_log_type), intent(inout) :: this ! StatusMsg is the message to be printed in the log; it does not need to ! contain the name of the module or subroutine producing the log message ! CodeLoc is the name of the subroutine that is calling StatusLog%log_noerror - character(len=*), intent(in) :: HeaderMsg, CodeLoc + character(len=*), intent(in) :: headermsg, codeloc - character(len=len_trim(HeaderMsg)) :: dashes + character(len=len_trim(headermsg)) :: dashes integer :: n - do n=1, len(dashes) + do n = 1, len(dashes) dashes(n:n) = '-' end do - call this%log_noerror('', CodeLoc) - call this%log_noerror(dashes, CodeLoc) - call this%log_noerror(HeaderMsg, CodeLoc) - call this%log_noerror(dashes, CodeLoc) - call this%log_noerror('', CodeLoc) + call this%log_noerror('', codeloc) + call this%log_noerror(dashes, codeloc) + call this%log_noerror(headermsg, codeloc) + call this%log_noerror(dashes, codeloc) + call this%log_noerror('', codeloc) end subroutine marbl_log_header !**************************************************************************** - subroutine marbl_log_error(this, ErrorMsg, CodeLoc, ElemInd) + subroutine marbl_log_error(this, errormsg, codeloc, elemind) class(marbl_log_type), intent(inout) :: this ! ErrorMsg is the error message to be printed in the log; it does not need ! to contain the name of the module or subroutine triggering the error ! CodeLoc is the name of the subroutine that is calling StatusLog%log_error - character(len=*), intent(in) :: ErrorMsg, CodeLoc - integer, optional, intent(in) :: ElemInd + character(len=*), intent(in) :: errormsg, codeloc + integer, optional, intent(in) :: elemind - character(len=marbl_log_len) :: ErrorMsg_loc ! Message text + character(len=marbl_log_len) :: errormsg_loc ! Message text this%labort_marbl = .true. ! Only allocate memory and add entry if we want to log full namelist! - if (.not.this%OutputOptions%lLogError) then + if ( .not. this%outputoptions%llogerror) then return end if - write(ErrorMsg_loc, "(4A)") "MARBL ERROR (", trim(CodeLoc), "): ", & - trim(ErrorMsg) + write(errormsg_loc, "(4A)") "MARBL ERROR (", trim(codeloc), "): ", & + trim(errormsg) - call this%append_to_log(ErrorMsg_loc, CodeLoc, ElemInd, lonly_master_writes=.false.) + call this%append_to_log(errormsg_loc, codeloc, elemind, lonly_master_writes=.false.) end subroutine marbl_log_error !**************************************************************************** - subroutine marbl_log_warning(this, WarningMsg, CodeLoc, ElemInd) + subroutine marbl_log_warning(this, warningmsg, codeloc, elemind) class(marbl_log_type), intent(inout) :: this ! WarningMsg is the message to be printed in the log; it does not need to ! contain the name of the module or subroutine producing the log message ! CodeLoc is the name of the subroutine that is calling StatusLog%log_warning - character(len=*), intent(in) :: WarningMsg, CodeLoc - integer, optional, intent(in) :: ElemInd + character(len=*), intent(in) :: warningmsg, codeloc + integer, optional, intent(in) :: elemind - character(len=marbl_log_len) :: WarningMsg_loc ! Message text + character(len=marbl_log_len) :: warningmsg_loc ! Message text this%lwarning = .true. ! Only allocate memory and add entry if we want to log full namelist! - if (.not.this%OutputOptions%lLogWarning) then + if ( .not. this%outputoptions%llogwarning) then return end if - write(WarningMsg_loc, "(4A)") "MARBL WARNING (", trim(CodeLoc), "): ", & - trim(WarningMsg) + write(warningmsg_loc, "(4A)") "MARBL WARNING (", trim(codeloc), "): ", & + trim(warningmsg) - call this%append_to_log(WarningMsg_loc, CodeLoc, ElemInd, lonly_master_writes=.false.) + call this%append_to_log(warningmsg_loc, codeloc, elemind, lonly_master_writes=.false.) end subroutine marbl_log_warning !**************************************************************************** - subroutine marbl_log_noerror(this, StatusMsg, CodeLoc, ElemInd, lonly_master_writes) + subroutine marbl_log_noerror(this, statusmsg, codeloc, elemind, lonly_master_writes) class(marbl_log_type), intent(inout) :: this ! StatusMsg is the message to be printed in the log; it does not need to ! contain the name of the module or subroutine producing the log message ! CodeLoc is the name of the subroutine that is calling StatusLog%log_noerror - character(len=*), intent(in) :: StatusMsg, CodeLoc - integer, optional, intent(in) :: ElemInd + character(len=*), intent(in) :: statusmsg, codeloc + integer, optional, intent(in) :: elemind ! If lonly_master_writes is .false., then this is a message that should be ! printed out regardless of which task produced it. By default, MARBL assumes ! that only the master task needs to print a message - logical, optional, intent(in) :: lonly_master_writes + logical, optional, intent(in) :: lonly_master_writes ! Only allocate memory and add entry if we want to log full namelist! - if (.not.this%OutputOptions%lLogGeneral) then + if ( .not. this%outputoptions%lloggeneral) then return end if - call this%append_to_log(StatusMsg, CodeLoc, ElemInd, lonly_master_writes) + call this%append_to_log(statusmsg, codeloc, elemind, lonly_master_writes) end subroutine marbl_log_noerror !**************************************************************************** - subroutine append_to_log(this, StatusMsg, CodeLoc, ElemInd, lonly_master_writes) + subroutine append_to_log(this, statusmsg, codeloc, elemind, lonly_master_writes) class(marbl_log_type), intent(inout) :: this ! StatusMsg is the message to be printed in the log; it does not need to ! contain the name of the module or subroutine producing the log message ! CodeLoc is the name of the subroutine that is calling StatusLog%log_noerror - character(len=*), intent(in) :: StatusMsg, CodeLoc - integer, optional, intent(in) :: ElemInd + character(len=*), intent(in) :: statusmsg, codeloc + integer, optional, intent(in) :: elemind ! If lonly_master_writes is .false., then this is a message that should be ! printed out regardless of which task produced it. By default, MARBL assumes ! that only the master task needs to print a message - logical, optional, intent(in) :: lonly_master_writes + logical, optional, intent(in) :: lonly_master_writes type(marbl_status_log_entry_type), pointer :: new_entry allocate(new_entry) nullify(new_entry%next) - if (present(ElemInd)) then - new_entry%ElementInd = ElemInd + if (present(elemind)) then + new_entry%elementind = elemind else - new_entry%ElementInd = -1 + new_entry%elementind = -1 end if - new_entry%LogMessage = trim(StatusMsg) - new_entry%CodeLocation = trim(CodeLoc) + new_entry%logmessage = trim(statusmsg) + new_entry%codelocation = trim(codeloc) if (present(lonly_master_writes)) then new_entry%lonly_master_writes = lonly_master_writes else new_entry%lonly_master_writes = .true. end if - if (associated(this%FullLog)) then + if (associated(this%fulllog)) then ! Append new entry to last entry in the log - this%LastEntry%next => new_entry + this%lastentry%next => new_entry else - this%FullLog => new_entry + this%fulllog => new_entry end if ! Update LastEntry attribute of linked list - this%LastEntry => new_entry + this%lastentry => new_entry end subroutine append_to_log !**************************************************************************** - subroutine marbl_log_error_trace(this, RoutineName, CodeLoc, ElemInd) + subroutine marbl_log_error_trace(this, routinename, codeloc, elemind) - ! This routine should only be called if another subroutine has returned and - ! StatusLog%labort_marbl = .true. + ! This routine should only be called if another subroutine has returned and + ! StatusLog%labort_marbl = .true. class(marbl_log_type), intent(inout) :: this ! RoutineName is the name of the subroutine that returned with @@ -347,21 +347,21 @@ subroutine marbl_log_error_trace(this, RoutineName, CodeLoc, ElemInd) ! ! When the log is printed, this will provide a traceback through the sequence ! of calls that led to the original error message. - character(len=*), intent(in) :: RoutineName, CodeLoc - integer, optional, intent(in) :: ElemInd + character(len=*), intent(in) :: routinename, codeloc + integer, optional, intent(in) :: elemind character(len=char_len) :: log_message - write(log_message, "(2A)") "Error reported from ", trim(RoutineName) - call this%log_error(log_message, CodeLoc, ElemInd) + write(log_message, "(2A)") "Error reported from ", trim(routinename) + call this%log_error(log_message, codeloc, elemind) end subroutine marbl_log_error_trace !**************************************************************************** - subroutine marbl_log_warning_trace(this, RoutineName, CodeLoc, ElemInd) + subroutine marbl_log_warning_trace(this, routinename, codeloc, elemind) - ! This routine should only be called if another subroutine has returned and - ! StatusLog%lwarning = .true. + ! This routine should only be called if another subroutine has returned and + ! StatusLog%lwarning = .true. class(marbl_log_type), intent(inout) :: this ! RoutineName is the name of the subroutine that returned with @@ -374,12 +374,12 @@ subroutine marbl_log_warning_trace(this, RoutineName, CodeLoc, ElemInd) ! ! When the log is printed, this will provide a traceback through the sequence ! of calls that led to the original warning message. - character(len=*), intent(in) :: RoutineName, CodeLoc - integer, optional, intent(in) :: ElemInd + character(len=*), intent(in) :: routinename, codeloc + integer, optional, intent(in) :: elemind character(len=char_len) :: log_message - write(log_message, "(2A)") "Warning reported from ", trim(RoutineName) - call this%log_warning(log_message, CodeLoc, ElemInd) + write(log_message, "(2A)") "Warning reported from ", trim(routinename) + call this%log_warning(log_message, codeloc, elemind) this%lwarning = .false. end subroutine marbl_log_warning_trace @@ -391,13 +391,13 @@ subroutine marbl_log_erase(this) class(marbl_log_type), intent(inout) :: this type(marbl_status_log_entry_type), pointer :: tmp - do while (associated(this%FullLog)) - tmp => this%FullLog%next - deallocate(this%FullLog) - this%FullLog => tmp + do while (associated(this%fulllog)) + tmp => this%fulllog%next + deallocate(this%fulllog) + this%fulllog => tmp end do - nullify(this%FullLog) - nullify(this%LastEntry) + nullify(this%fulllog) + nullify(this%lastentry) this%lwarning = .false. diff --git a/src/ccpp_constituent_prop_mod.F90 b/src/ccpp_constituent_prop_mod.F90 index d75be966..851d20c4 100644 --- a/src/ccpp_constituent_prop_mod.F90 +++ b/src/ccpp_constituent_prop_mod.F90 @@ -3,8 +3,10 @@ module ccpp_constituent_prop_mod ! ccpp_contituent_prop_mod contains types and procedures for storing ! and retrieving constituent properties - use ccpp_hashable, only: ccpp_hashable_t, ccpp_hashable_char_t - use ccpp_hash_table, only: ccpp_hash_table_t, ccpp_hash_iterator_t + use ccpp_hashable, only: ccpp_hashable_t, & + ccpp_hashable_char_t + use ccpp_hash_table, only: ccpp_hash_table_t, & + ccpp_hash_iterator_t use ccpp_kinds, only: kind_phys implicit none @@ -368,7 +370,7 @@ logical function ccp_is_instantiated(this, errcode, errmsg) ccp_is_instantiated = allocated(this%var_std_name) call initialize_errvars(errcode, errmsg) - if (.not.ccp_is_instantiated) then + if ( .not. ccp_is_instantiated) then call append_errvars(1, "ccpp_constituent_properties_t object is not initialized", & subname, errcode=errcode, errmsg=errmsg) end if @@ -1093,7 +1095,7 @@ logical function ccp_model_const_locked(this, errcode, errmsg, warn_func) ! Use an initialized hash table as double check if (this%hash_table%is_initialized()) then ccp_model_const_locked = this%table_locked .and. this%data_locked - if ((.not.(this%table_locked .and. this%data_locked)) .and. & + if (( .not. (this%table_locked .and. this%data_locked)) .and. & present(errmsg) .and. present(warn_func)) then ! Write a warning as a courtesy to calling function but do not set ! errcode (let caller decide). @@ -1125,7 +1127,7 @@ logical function ccp_model_const_props_locked(this, errcode, errmsg, warn_func) ! Use an initialized hash table as double check if (this%hash_table%is_initialized()) then ccp_model_const_props_locked = this%table_locked - if (.not.this%table_locked .and. & + if ( .not. this%table_locked .and. & present(errmsg) .and. present(warn_func)) then ! Write a warning as a courtesy to calling function but do not set ! errcode (let caller decide). @@ -1158,7 +1160,7 @@ logical function ccp_model_const_data_locked(this, errcode, errmsg, warn_func) ! Use an initialized hash table as double check if (this%hash_table%is_initialized()) then ccp_model_const_data_locked = this%data_locked - if (.not.this%data_locked .and. & + if ( .not. this%data_locked .and. & present(errmsg) .and. present(warn_func)) then ! Write a warning as a courtesy to calling function but do not set ! errcode (let caller decide). @@ -1191,10 +1193,10 @@ logical function ccp_model_const_okay_to_add(this, errcode, errmsg, & ccp_model_const_okay_to_add = this%hash_table%is_initialized() if (ccp_model_const_okay_to_add) then - ccp_model_const_okay_to_add = .not.(this%const_props_locked(errcode=errcode, & + ccp_model_const_okay_to_add = .not. (this%const_props_locked(errcode=errcode, & errmsg=errmsg, warn_func=subname) .or. this%const_data_locked(errcode=errcode, & errmsg=errmsg, warn_func=subname)) - if (.not.ccp_model_const_okay_to_add) then + if ( .not. ccp_model_const_okay_to_add) then call append_errvars(1, & "WARNING: Model constituents are locked", & subname, errcode=errcode, errmsg=errmsg, caller=warn_func) @@ -1440,7 +1442,7 @@ subroutine ccp_model_const_table_lock(this, errcode, errmsg) call this%const_metadata(index_const)%set(cprop) end if ! Make sure this is a layer variable - if (.not.cprop%is_layer_var()) then + if ( .not. cprop%is_layer_var()) then call cprop%vertical_dimension(dimname, & errcode=errcode, errmsg=errmsg) call append_errvars(1, "ERROR: Bad vertical dimension, '" // & @@ -1510,7 +1512,7 @@ subroutine ccp_model_const_data_lock(this, ncols, num_layers, errcode, errmsg) "WARNING: Model constituent data already locked, ignoring", & subname, errcode=errcode, errmsg=errmsg) errcode_local = errcode_local + 1 - else if (.not.this%const_props_locked(errcode=errcode, errmsg=errmsg, & + else if ( .not. this%const_props_locked(errcode=errcode, errmsg=errmsg, & warn_func=subname)) then call append_errvars(1, & "WARNING: Model constituent properties not yet locked, ignoring", & diff --git a/src/ccpp_hash_table.F90 b/src/ccpp_hash_table.F90 index 685c9049..dc9ff2ec 100644 --- a/src/ccpp_hash_table.F90 +++ b/src/ccpp_hash_table.F90 @@ -260,8 +260,8 @@ function hash_table_table_value(this, key, errmsg) result(tbl_val) end if end if - if ((.not.associated(tbl_val)) .and. present(errmsg)) then - if (.not.have_error(errmsg)) then ! Still need to test for empty + if (( .not. associated(tbl_val)) .and. present(errmsg)) then + if ( .not. have_error(errmsg)) then ! Still need to test for empty write(errmsg, *) subname, ": No entry for '", trim(key), "'" end if end if @@ -453,7 +453,7 @@ subroutine hash_iterator_next_entry(this) end if if (has_table_next) then this%table_entry => this%table_entry%next - else if ((.not.has_table_entry) .and. & + else if (( .not. has_table_entry) .and. & associated(this%hash_table%table(this%index)%next)) then this%table_entry => this%hash_table%table(this%index)%next else diff --git a/src/ccpp_scheme_utils.F90 b/src/ccpp_scheme_utils.F90 index f6920e85..913e9040 100644 --- a/src/ccpp_scheme_utils.F90 +++ b/src/ccpp_scheme_utils.F90 @@ -2,7 +2,8 @@ module ccpp_scheme_utils ! Module of utilities available to CCPP schemes - use ccpp_constituent_prop_mod, only: ccpp_model_constituents_t, int_unassigned + use ccpp_constituent_prop_mod, only: ccpp_model_constituents_t, & + int_unassigned implicit none private @@ -62,7 +63,7 @@ subroutine ccpp_initialize_constituent_ptr(const_obj) ! Dummy arguments type(ccpp_model_constituents_t), pointer, intent(in) :: const_obj - if (.not.initialized) then + if ( .not. initialized) then constituent_obj => const_obj initialized = .true. end if diff --git a/stub/data.F90 b/stub/data.F90 index d2a21c15..b65dad75 100644 --- a/stub/data.F90 +++ b/stub/data.F90 @@ -1,17 +1,17 @@ module data -!! \section arg_table_data Argument Table -!! \htmlinclude data.html -!! + !! \section arg_table_data Argument Table + !! \htmlinclude data.html + !! - use ccpp_types, only: ccpp_t + use ccpp_types, only: ccpp_t - implicit none + implicit none - private + private - public ccpp_data + public ccpp_data - type(ccpp_t), save, target :: ccpp_data + type(ccpp_t), save, target :: ccpp_data end module data diff --git a/stub/stub.F90 b/stub/stub.F90 index 0b392daa..009294b6 100644 --- a/stub/stub.F90 +++ b/stub/stub.F90 @@ -4,32 +4,32 @@ module stub - implicit none - private - public :: stub_init, stub_finalize + implicit none + private + public :: stub_init, stub_finalize - contains +contains -!! \section arg_table_stub_init Argument Table -!! \htmlinclude stub_init.html -!! - subroutine stub_init(errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - end subroutine stub_init + !! \section arg_table_stub_init Argument Table + !! \htmlinclude stub_init.html + !! + subroutine stub_init(errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + end subroutine stub_init -!! \section arg_table_stub_finalize Argument Table -!! \htmlinclude stub_finalize.html -!! - subroutine stub_finalize(errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - end subroutine stub_finalize + !! \section arg_table_stub_finalize Argument Table + !! \htmlinclude stub_finalize.html + !! + subroutine stub_finalize(errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + end subroutine stub_finalize end module stub diff --git a/test/advection_test/apply_constituent_tendencies.F90 b/test/advection_test/apply_constituent_tendencies.F90 index 150b1190..63a1881c 100644 --- a/test/advection_test/apply_constituent_tendencies.F90 +++ b/test/advection_test/apply_constituent_tendencies.F90 @@ -7,33 +7,33 @@ module apply_constituent_tendencies public :: apply_constituent_tendencies_run -CONTAINS - - !> \section arg_table_apply_constituent_tendencies_run Argument Table - !!! \htmlinclude apply_constituent_tendencies_run.html - subroutine apply_constituent_tendencies_run(const_tend, const, errcode, errmsg) - ! Dummy arguments - real(kind_phys), intent(inout) :: const_tend(:,:,:) ! constituent tendency array - real(kind_phys), intent(inout) :: const(:,:,:) ! constituent state array - integer, intent(out) :: errcode - character(len=512), intent(out) :: errmsg - - ! Local variables - integer :: klev, jcnst, icol - - errcode = 0 - errmsg = '' - - do icol = 1, size(const_tend, 1) - do klev = 1, size(const_tend, 2) - do jcnst = 1, size(const_tend, 3) - const(icol, klev, jcnst) = const(icol, klev, jcnst) + const_tend(icol, klev, jcnst) - end do - end do +contains + + !> \section arg_table_apply_constituent_tendencies_run Argument Table + !!! \htmlinclude apply_constituent_tendencies_run.html + subroutine apply_constituent_tendencies_run(const_tend, const, errcode, errmsg) + ! Dummy arguments + real(kind=kind_phys), intent(inout) :: const_tend(:, :, :) ! constituent tendency array + real(kind=kind_phys), intent(inout) :: const(:, :, :) ! constituent state array + integer, intent(out) :: errcode + character(len=512), intent(out) :: errmsg + + ! Local variables + integer :: klev, jcnst, icol + + errcode = 0 + errmsg = '' + + do icol = 1, size(const_tend, 1) + do klev = 1, size(const_tend, 2) + do jcnst = 1, size(const_tend, 3) + const(icol, klev, jcnst) = const(icol, klev, jcnst) + const_tend(icol, klev, jcnst) + end do end do + end do - const_tend = 0._kind_phys + const_tend = 0._kind_phys - end subroutine apply_constituent_tendencies_run + end subroutine apply_constituent_tendencies_run end module apply_constituent_tendencies diff --git a/test/advection_test/cld_ice.F90 b/test/advection_test/cld_ice.F90 index 15f5b502..3ace2f91 100644 --- a/test/advection_test/cld_ice.F90 +++ b/test/advection_test/cld_ice.F90 @@ -1,127 +1,127 @@ ! Test parameterization with advected species ! -MODULE cld_ice - - USE ccpp_kinds, ONLY: kind_phys - - IMPLICIT NONE - PRIVATE - - PUBLIC :: cld_ice_register - PUBLIC :: cld_ice_init - PUBLIC :: cld_ice_run - PUBLIC :: cld_ice_final - - real(kind_phys), private :: tcld = HUGE(1.0_kind_phys) - -CONTAINS - - !> \section arg_table_cld_ice_register Argument Table - !! \htmlinclude arg_table_cld_ice_register.html - !! - subroutine cld_ice_register(dyn_const_ice, errmsg, errcode) - use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t - type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const_ice(:) - integer, intent(out) :: errcode - character(len=512), intent(out) :: errmsg - - errmsg = '' - errcode = 0 - allocate(dyn_const_ice(2), stat=errcode) - if (errcode /= 0) then - errmsg = 'Error allocating dyn_const in cld_ice_dynamic_constituents' - return - end if - call dyn_const_ice(1)%instantiate(std_name='dyn_const1', long_name='dyn const1', & - diag_name='DYNCONST1', units='kg kg-1', default_value=0._kind_phys, & - vertical_dim='vertical_layer_dimension', advected=.true., & - min_value=1000._kind_phys, water_species=.true., mixing_ratio_type='wet', & - errcode=errcode, errmsg=errmsg) - call dyn_const_ice(2)%instantiate(std_name='dyn_const2_wrt_moist_air', long_name='dyn const2', & - diag_name='DYNCONST2', units='kg kg-1', default_value=0._kind_phys, & - vertical_dim='vertical_layer_dimension', advected=.true., & - water_species=.false., errcode=errcode, errmsg=errmsg) - - end subroutine cld_ice_register - - !> \section arg_table_cld_ice_run Argument Table - !! \htmlinclude arg_table_cld_ice_run.html - !! - subroutine cld_ice_run(ncol, timestep, temp, qv, ps, cld_ice_array, & - errmsg, errflg) - - integer, intent(in) :: ncol - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(inout) :: temp(:,:) - real(kind_phys), intent(inout) :: qv(:,:) - real(kind_phys), intent(in) :: ps(:) - REAL(kind_phys), intent(inout) :: cld_ice_array(:,:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - - integer :: icol - integer :: ilev - real(kind_phys) :: frz - - errmsg = '' - errflg = 0 - - ! Apply state-of-the-art thermodynamics :) - do icol = 1, ncol - do ilev = 1, size(temp, 2) - if (temp(icol, ilev) < tcld) then - frz = MAX(qv(icol, ilev) - 0.5_kind_phys, 0.0_kind_phys) - cld_ice_array(icol, ilev) = cld_ice_array(icol, ilev) + frz - qv(icol, ilev) = qv(icol, ilev) - frz - if (frz > 0.0_kind_phys) then - temp(icol, ilev) = temp(icol, ilev) + 1.0_kind_phys - end if - end if - end do +module cld_ice + + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: cld_ice_register + public :: cld_ice_init + public :: cld_ice_run + public :: cld_ice_final + + real(kind=kind_phys), private :: tcld = huge(1.0_kind_phys) + +contains + + !> \section arg_table_cld_ice_register Argument Table + !! \htmlinclude arg_table_cld_ice_register.html + !! + subroutine cld_ice_register(dyn_const_ice, errmsg, errcode) + use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t + type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const_ice(:) + integer, intent(out) :: errcode + character(len=512), intent(out) :: errmsg + + errmsg = '' + errcode = 0 + allocate(dyn_const_ice(2), stat=errcode) + if (errcode /= 0) then + errmsg = 'Error allocating dyn_const in cld_ice_dynamic_constituents' + return + end if + call dyn_const_ice(1)%instantiate(std_name='dyn_const1', long_name='dyn const1', & + diag_name='DYNCONST1', units='kg kg-1', default_value=0._kind_phys, & + vertical_dim='vertical_layer_dimension', advected=.true., & + min_value=1000._kind_phys, water_species=.true., mixing_ratio_type='wet', & + errcode=errcode, errmsg=errmsg) + call dyn_const_ice(2)%instantiate(std_name='dyn_const2_wrt_moist_air', long_name='dyn const2', & + diag_name='DYNCONST2', units='kg kg-1', default_value=0._kind_phys, & + vertical_dim='vertical_layer_dimension', advected=.true., & + water_species=.false., errcode=errcode, errmsg=errmsg) + + end subroutine cld_ice_register + + !> \section arg_table_cld_ice_run Argument Table + !! \htmlinclude arg_table_cld_ice_run.html + !! + subroutine cld_ice_run(ncol, timestep, temp, qv, ps, cld_ice_array, & + errmsg, errflg) + + integer, intent(in) :: ncol + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(inout) :: temp(:, :) + real(kind=kind_phys), intent(inout) :: qv(:, :) + real(kind=kind_phys), intent(in) :: ps(:) + real(kind=kind_phys), intent(inout) :: cld_ice_array(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + + integer :: icol + integer :: ilev + real(kind=kind_phys) :: frz + + errmsg = '' + errflg = 0 + + ! Apply state-of-the-art thermodynamics :) + do icol = 1, ncol + do ilev = 1, size(temp, 2) + if (temp(icol, ilev) < tcld) then + frz = max(qv(icol, ilev) - 0.5_kind_phys, 0.0_kind_phys) + cld_ice_array(icol, ilev) = cld_ice_array(icol, ilev) + frz + qv(icol, ilev) = qv(icol, ilev) - frz + if (frz > 0.0_kind_phys) then + temp(icol, ilev) = temp(icol, ilev) + 1.0_kind_phys + end if + end if end do + end do - END SUBROUTINE cld_ice_run + end subroutine cld_ice_run - !> \section arg_table_cld_ice_init Argument Table - !! \htmlinclude arg_table_cld_ice_init.html - !! - subroutine cld_ice_init(tfreeze, cld_ice_array, errmsg, errflg) + !> \section arg_table_cld_ice_init Argument Table + !! \htmlinclude arg_table_cld_ice_init.html + !! + subroutine cld_ice_init(tfreeze, cld_ice_array, errmsg, errflg) - real(kind_phys), intent(in) :: tfreeze - real(kind_phys), intent(inout) :: cld_ice_array(:,:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(in) :: tfreeze + real(kind=kind_phys), intent(inout) :: cld_ice_array(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - errmsg = '' - errflg = 0 - cld_ice_array = 0.0_kind_phys - tcld = tfreeze - 20.0_kind_phys + errmsg = '' + errflg = 0 + cld_ice_array = 0.0_kind_phys + tcld = tfreeze - 20.0_kind_phys - end subroutine cld_ice_init + end subroutine cld_ice_init - !> \section arg_table_cld_ice_final Argument Table - !! \htmlinclude arg_table_cld_ice_final.html - !! + !> \section arg_table_cld_ice_final Argument Table + !! \htmlinclude arg_table_cld_ice_final.html + !! - !> @{ - !! This routine does nothing, but it tests if blank - !! lines and doxygen comments between metadata hooks - !! and the subroutine are parsed correctly. - !! @{ + !> @{ + !! This routine does nothing, but it tests if blank + !! lines and doxygen comments between metadata hooks + !! and the subroutine are parsed correctly. + !! @{ - subroutine cld_ice_final(errmsg, errflg) + subroutine cld_ice_final(errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 - end subroutine cld_ice_final + end subroutine cld_ice_final - !! @} - !! @} + !! @} + !! @} -END MODULE cld_ice +end module cld_ice diff --git a/test/advection_test/cld_liq.F90 b/test/advection_test/cld_liq.F90 index 83a6f961..cb02cf11 100644 --- a/test/advection_test/cld_liq.F90 +++ b/test/advection_test/cld_liq.F90 @@ -1,102 +1,102 @@ ! Test parameterization with advected species ! -MODULE cld_liq - - USE ccpp_kinds, ONLY: kind_phys - use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t - - IMPLICIT NONE - PRIVATE - - PUBLIC :: cld_liq_register - PUBLIC :: cld_liq_init - PUBLIC :: cld_liq_run - -CONTAINS - - !> \section arg_table_cld_liq_register Argument Table - !! \htmlinclude arg_table_cld_liq_register.html - !! - subroutine cld_liq_register(dyn_const, errmsg, errflg) - type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - - errmsg = '' - errflg = 0 - allocate(dyn_const(1), stat=errflg) - if (errflg /= 0) then - errmsg = 'Error allocating dyn_const in cld_liq_register' - return - end if - call dyn_const(1)%instantiate(std_name="dyn_const3_wrt_moist_air_and_condensed_water", long_name='dyn const3', & - diag_name='DYNCONST3', units='kg kg-1', default_value=1._kind_phys, & - vertical_dim='vertical_layer_dimension', advected=.true., & - water_species=.true., mixing_ratio_type='dry', & - errcode=errflg, errmsg=errmsg) - - end subroutine cld_liq_register - - !> \section arg_table_cld_liq_run Argument Table - !! \htmlinclude arg_table_cld_liq_run.html - !! - subroutine cld_liq_run(ncol, timestep, tcld, temp, qv, ps, & - cld_liq_tend, errmsg, errflg) - - integer, intent(in) :: ncol - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(in) :: tcld - real(kind_phys), intent(inout) :: temp(:,:) - real(kind_phys), intent(inout) :: qv(:,:) - real(kind_phys), intent(in) :: ps(:) - REAL(kind_phys), intent(inout) :: cld_liq_tend(:,:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - - integer :: icol - integer :: ilev - real(kind_phys) :: cond - - errmsg = '' - errflg = 0 - - ! Apply state-of-the-art thermodynamics :) - do icol = 1, ncol - do ilev = 1, size(temp, 2) - if ( (qv(icol, ilev) > 0.0_kind_phys) .and. & - (temp(icol, ilev) <= tcld)) then - cond = MIN(qv(icol, ilev), 0.1_kind_phys) - cld_liq_tend(icol, ilev) = cond - qv(icol, ilev) = qv(icol, ilev) - cond - if (cond > 0.0_kind_phys) then - temp(icol, ilev) = temp(icol, ilev) + (cond * 5.0_kind_phys) - end if - end if - end do +module cld_liq + + use ccpp_kinds, only: kind_phys + use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t + + implicit none + private + + public :: cld_liq_register + public :: cld_liq_init + public :: cld_liq_run + +contains + + !> \section arg_table_cld_liq_register Argument Table + !! \htmlinclude arg_table_cld_liq_register.html + !! + subroutine cld_liq_register(dyn_const, errmsg, errflg) + type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + + errmsg = '' + errflg = 0 + allocate(dyn_const(1), stat=errflg) + if (errflg /= 0) then + errmsg = 'Error allocating dyn_const in cld_liq_register' + return + end if + call dyn_const(1)%instantiate(std_name="dyn_const3_wrt_moist_air_and_condensed_water", long_name='dyn const3', & + diag_name='DYNCONST3', units='kg kg-1', default_value=1._kind_phys, & + vertical_dim='vertical_layer_dimension', advected=.true., & + water_species=.true., mixing_ratio_type='dry', & + errcode=errflg, errmsg=errmsg) + + end subroutine cld_liq_register + + !> \section arg_table_cld_liq_run Argument Table + !! \htmlinclude arg_table_cld_liq_run.html + !! + subroutine cld_liq_run(ncol, timestep, tcld, temp, qv, ps, & + cld_liq_tend, errmsg, errflg) + + integer, intent(in) :: ncol + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(in) :: tcld + real(kind=kind_phys), intent(inout) :: temp(:, :) + real(kind=kind_phys), intent(inout) :: qv(:, :) + real(kind=kind_phys), intent(in) :: ps(:) + real(kind=kind_phys), intent(inout) :: cld_liq_tend(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + + integer :: icol + integer :: ilev + real(kind=kind_phys) :: cond + + errmsg = '' + errflg = 0 + + ! Apply state-of-the-art thermodynamics :) + do icol = 1, ncol + do ilev = 1, size(temp, 2) + if ((qv(icol, ilev) > 0.0_kind_phys) .and. & + (temp(icol, ilev) <= tcld)) then + cond = min(qv(icol, ilev), 0.1_kind_phys) + cld_liq_tend(icol, ilev) = cond + qv(icol, ilev) = qv(icol, ilev) - cond + if (cond > 0.0_kind_phys) then + temp(icol, ilev) = temp(icol, ilev) + (cond * 5.0_kind_phys) + end if + end if end do + end do - END SUBROUTINE cld_liq_run + end subroutine cld_liq_run - !> \section arg_table_cld_liq_init Argument Table - !! \htmlinclude arg_table_cld_liq_init.html - !! - subroutine cld_liq_init(tfreeze, cld_liq_array, tcld, errmsg, errflg) + !> \section arg_table_cld_liq_init Argument Table + !! \htmlinclude arg_table_cld_liq_init.html + !! + subroutine cld_liq_init(tfreeze, cld_liq_array, tcld, errmsg, errflg) - real(kind_phys), intent(in) :: tfreeze - real(kind_phys), intent(out) :: cld_liq_array(:,:) - real(kind_phys), intent(out) :: tcld - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(in) :: tfreeze + real(kind=kind_phys), intent(out) :: cld_liq_array(:, :) + real(kind=kind_phys), intent(out) :: tcld + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - ! This routine currently does nothing + ! This routine currently does nothing - errmsg = '' - errflg = 0 - cld_liq_array = 0.0_kind_phys - tcld = tfreeze - 20.0_kind_phys + errmsg = '' + errflg = 0 + cld_liq_array = 0.0_kind_phys + tcld = tfreeze - 20.0_kind_phys - end subroutine cld_liq_init + end subroutine cld_liq_init -END MODULE cld_liq +end module cld_liq diff --git a/test/advection_test/const_indices.F90 b/test/advection_test/const_indices.F90 index 0d9cf2e7..b9595982 100644 --- a/test/advection_test/const_indices.F90 +++ b/test/advection_test/const_indices.F90 @@ -1,94 +1,95 @@ ! Test collection of constituent indices ! -MODULE const_indices - - USE ccpp_kinds, ONLY: kind_phys - - IMPLICIT NONE - PRIVATE - - PUBLIC :: const_indices_init - PUBLIC :: const_indices_run - -CONTAINS - - !> \section arg_table_const_indices_run Argument Table - !! \htmlinclude arg_table_const_indices_run.html - !! - subroutine const_indices_run(const_std_name, num_consts, test_stdname_array, & - const_index, const_inds, errmsg, errflg) - use ccpp_constituent_prop_mod, only: int_unassigned - use ccpp_scheme_utils, only: ccpp_constituent_index - use ccpp_scheme_utils, only: ccpp_constituent_indices - - character(len=*), intent(in) :: const_std_name - integer, intent(in) :: num_consts - character(len=*), intent(in) :: test_stdname_array(:) - integer, intent(out) :: const_index - integer, intent(out) :: const_inds(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - - integer :: indx - integer :: test_indx - - errmsg = '' - errflg = 0 - - ! Find the constituent index for - call ccpp_constituent_index(const_std_name, const_index, errflg, errmsg) - if (errflg == 0) then - call ccpp_constituent_indices(test_stdname_array, const_inds, errflg, errmsg) - end if - ! Check that a non-registered constituent is detectable but - ! does not cause an error - if (errflg == 0) then - call ccpp_constituent_index('unobtainium', test_indx, errflg, errmsg) - if (test_indx /= int_unassigned) then - if (errflg == 0) then - ! Do not add an error if one is already reported - errflg = 2 - write(errmsg, '(2a,i0,a,i0)') "ccpp_constituent_index called for ", & - "'unobtainium' returned an index of ", test_indx, ", not ", & - int_unassigned - end if - end if +module const_indices + + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: const_indices_init + public :: const_indices_run + +contains + + !> \section arg_table_const_indices_run Argument Table + !! \htmlinclude arg_table_const_indices_run.html + !! + subroutine const_indices_run(const_std_name, num_consts, test_stdname_array, & + const_index, const_inds, errmsg, errflg) + use ccpp_constituent_prop_mod, only: int_unassigned + use ccpp_scheme_utils, only: ccpp_constituent_index + use ccpp_scheme_utils, only: ccpp_constituent_indices + + character(len=*), intent(in) :: const_std_name + integer, intent(in) :: num_consts + character(len=*), intent(in) :: test_stdname_array(:) + integer, intent(out) :: const_index + integer, intent(out) :: const_inds(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + + integer :: indx + integer :: test_indx + + errmsg = '' + errflg = 0 + + ! Find the constituent index for + call ccpp_constituent_index(const_std_name, const_index, errflg, errmsg) + if (errflg == 0) then + call ccpp_constituent_indices(test_stdname_array, const_inds, errflg, errmsg) + end if + ! Check that a non-registered constituent is detectable but + ! does not cause an error + if (errflg == 0) then + call ccpp_constituent_index('unobtainium', test_indx, errflg, errmsg) + if (test_indx /= int_unassigned) then + if (errflg == 0) then + ! Do not add an error if one is already reported + errflg = 2 + write(errmsg, '(2a,i0,a,i0)') "ccpp_constituent_index called for ", & + "'unobtainium' returned an index of ", test_indx, ", not ", & + int_unassigned + end if end if + end if - end subroutine const_indices_run - - !> \section arg_table_const_indices_init Argument Table - !! \htmlinclude arg_table_const_indices_init.html - !! - subroutine const_indices_init(const_std_name, num_consts, test_stdname_array, & - const_index, const_inds, errmsg, errflg) - use ccpp_scheme_utils, only: ccpp_constituent_index, ccpp_constituent_indices - - character(len=*), intent(in) :: const_std_name - integer, intent(in) :: num_consts - character(len=*), intent(in) :: test_stdname_array(:) - integer, intent(out) :: const_index - integer, intent(out) :: const_inds(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - - integer :: indx - - errmsg = '' - errflg = 0 - - ! Find the constituent index for - call ccpp_constituent_index(const_std_name, const_index, errflg, errmsg) - if (errflg == 0) then - call ccpp_constituent_indices(test_stdname_array, const_inds, errflg, errmsg) - end if + end subroutine const_indices_run + + !> \section arg_table_const_indices_init Argument Table + !! \htmlinclude arg_table_const_indices_init.html + !! + subroutine const_indices_init(const_std_name, num_consts, test_stdname_array, & + const_index, const_inds, errmsg, errflg) + use ccpp_scheme_utils, only: ccpp_constituent_index, & + ccpp_constituent_indices + + character(len=*), intent(in) :: const_std_name + integer, intent(in) :: num_consts + character(len=*), intent(in) :: test_stdname_array(:) + integer, intent(out) :: const_index + integer, intent(out) :: const_inds(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + + integer :: indx + + errmsg = '' + errflg = 0 + + ! Find the constituent index for + call ccpp_constituent_index(const_std_name, const_index, errflg, errmsg) + if (errflg == 0) then + call ccpp_constituent_indices(test_stdname_array, const_inds, errflg, errmsg) + end if - end subroutine const_indices_init + end subroutine const_indices_init - !! @} - !! @} + !! @} + !! @} -END MODULE const_indices +end module const_indices diff --git a/test/advection_test/dlc_liq.F90 b/test/advection_test/dlc_liq.F90 index db456073..20ff4b7b 100644 --- a/test/advection_test/dlc_liq.F90 +++ b/test/advection_test/dlc_liq.F90 @@ -1,41 +1,41 @@ ! Test parameterization with a runtime constituents ! properties object outside of the register phase -MODULE dlc_liq +module dlc_liq - USE ccpp_kinds, ONLY: kind_phys - use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t + use ccpp_kinds, only: kind_phys + use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: dlc_liq_init + public :: dlc_liq_init -CONTAINS +contains - !> \section arg_table_dlc_liq_init Argument Table - !! \htmlinclude arg_table_dlc_liq_init.html - !! - subroutine dlc_liq_init(dyn_const, errmsg, errflg) - type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + !> \section arg_table_dlc_liq_init Argument Table + !! \htmlinclude arg_table_dlc_liq_init.html + !! + subroutine dlc_liq_init(dyn_const, errmsg, errflg) + type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - character(len=256) :: stdname + character(len=256) :: stdname - errmsg = '' - errflg = 0 - allocate(dyn_const(1), stat=errflg) - if (errflg /= 0) then - errmsg = 'Error allocating dyn_const in dlc_liq_init' - return - end if - call dyn_const(1)%instantiate(std_name="dyn_const3", long_name='dyn const3', & - diag_name='DYNCONST3', units='kg kg-1', default_value=1._kind_phys, & - vertical_dim='vertical_layer_dimension', advected=.true., & - errcode=errflg, errmsg=errmsg) - call dyn_const(1)%standard_name(stdname, errcode=errflg, errmsg=errmsg) + errmsg = '' + errflg = 0 + allocate(dyn_const(1), stat=errflg) + if (errflg /= 0) then + errmsg = 'Error allocating dyn_const in dlc_liq_init' + return + end if + call dyn_const(1)%instantiate(std_name="dyn_const3", long_name='dyn const3', & + diag_name='DYNCONST3', units='kg kg-1', default_value=1._kind_phys, & + vertical_dim='vertical_layer_dimension', advected=.true., & + errcode=errflg, errmsg=errmsg) + call dyn_const(1)%standard_name(stdname, errcode=errflg, errmsg=errmsg) - end subroutine dlc_liq_init + end subroutine dlc_liq_init -END MODULE dlc_liq +end module dlc_liq diff --git a/test/advection_test/test_advection_host_integration.F90 b/test/advection_test/test_advection_host_integration.F90 index 728137fa..4dfb2d18 100644 --- a/test/advection_test/test_advection_host_integration.F90 +++ b/test/advection_test/test_advection_host_integration.F90 @@ -1,77 +1,80 @@ 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(1) - character(len=cm), target :: test_invars1(12) - character(len=cm), target :: test_outvars1(13) - character(len=cm), target :: test_reqvars1(18) + character(len=cs), target :: test_parts1(1) + character(len=cm), target :: test_invars1(12) + character(len=cm), target :: test_outvars1(13) + character(len=cm), target :: test_reqvars1(18) - type(suite_info) :: test_suites(1) - logical :: run_okay + type(suite_info) :: test_suites(1) + logical :: run_okay - test_parts1 = (/ 'physics '/) - test_invars1 = (/ & - 'banana_array_dim ', & - 'cloud_ice_dry_mixing_ratio ', & - 'cloud_liquid_dry_mixing_ratio ', & - 'tendency_of_cloud_liquid_dry_mixing_ratio', & - 'surface_air_pressure ', & - 'temperature ', & - 'time_step_for_physics ', & - 'water_temperature_at_freezing ', & - 'ccpp_constituent_tendencies ', & - 'ccpp_constituents ', & - 'number_of_ccpp_constituents ', & - 'water_vapor_specific_humidity ' /) - test_outvars1 = (/ & - 'ccpp_error_message ', & - 'ccpp_error_code ', & - 'temperature ', & - 'water_vapor_specific_humidity ', & - 'cloud_liquid_dry_mixing_ratio ', & - 'ccpp_constituent_tendencies ', & - 'ccpp_constituents ', & - 'dynamic_constituents_for_cld_liq ', & - 'dynamic_constituents_for_cld_ice ', & - 'tendency_of_cloud_liquid_dry_mixing_ratio', & - 'test_banana_constituent_index ', & - 'test_banana_constituent_indices ', & - 'cloud_ice_dry_mixing_ratio ' /) - test_reqvars1 = (/ & - 'banana_array_dim ', & - 'surface_air_pressure ', & - 'temperature ', & - 'time_step_for_physics ', & - 'cloud_liquid_dry_mixing_ratio ', & - 'tendency_of_cloud_liquid_dry_mixing_ratio', & - 'cloud_ice_dry_mixing_ratio ', & - 'dynamic_constituents_for_cld_liq ', & - 'dynamic_constituents_for_cld_ice ', & - 'water_temperature_at_freezing ', & - 'ccpp_constituent_tendencies ', & - 'ccpp_constituents ', & - 'number_of_ccpp_constituents ', & - 'test_banana_constituent_index ', & - 'test_banana_constituent_indices ', & - 'water_vapor_specific_humidity ', & - 'ccpp_error_message ', & - 'ccpp_error_code ' /) + test_parts1 = (/ 'physics '/) + test_invars1 = (/ & + 'banana_array_dim ', & + 'cloud_ice_dry_mixing_ratio ', & + 'cloud_liquid_dry_mixing_ratio ', & + 'tendency_of_cloud_liquid_dry_mixing_ratio', & + 'surface_air_pressure ', & + 'temperature ', & + 'time_step_for_physics ', & + 'water_temperature_at_freezing ', & + 'ccpp_constituent_tendencies ', & + 'ccpp_constituents ', & + 'number_of_ccpp_constituents ', & + 'water_vapor_specific_humidity ' /) + test_outvars1 = (/ & + 'ccpp_error_message ', & + 'ccpp_error_code ', & + 'temperature ', & + 'water_vapor_specific_humidity ', & + 'cloud_liquid_dry_mixing_ratio ', & + 'ccpp_constituent_tendencies ', & + 'ccpp_constituents ', & + 'dynamic_constituents_for_cld_liq ', & + 'dynamic_constituents_for_cld_ice ', & + 'tendency_of_cloud_liquid_dry_mixing_ratio', & + 'test_banana_constituent_index ', & + 'test_banana_constituent_indices ', & + 'cloud_ice_dry_mixing_ratio ' /) + test_reqvars1 = (/ & + 'banana_array_dim ', & + 'surface_air_pressure ', & + 'temperature ', & + 'time_step_for_physics ', & + 'cloud_liquid_dry_mixing_ratio ', & + 'tendency_of_cloud_liquid_dry_mixing_ratio', & + 'cloud_ice_dry_mixing_ratio ', & + 'dynamic_constituents_for_cld_liq ', & + 'dynamic_constituents_for_cld_ice ', & + 'water_temperature_at_freezing ', & + 'ccpp_constituent_tendencies ', & + 'ccpp_constituents ', & + 'number_of_ccpp_constituents ', & + 'test_banana_constituent_index ', & + 'test_banana_constituent_indices ', & + 'water_vapor_specific_humidity ', & + 'ccpp_error_message ', & + 'ccpp_error_code ' /) - ! Setup expected test suite info - test_suites(1)%suite_name = 'cld_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 + ! Setup expected test suite info + test_suites(1)%suite_name = 'cld_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 - 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/advection_test/test_host.F90 b/test/advection_test/test_host.F90 index 30a618e8..3cd46825 100644 --- a/test/advection_test/test_host.F90 +++ b/test/advection_test/test_host.F90 @@ -1,1110 +1,1114 @@ module test_prog - use ccpp_kinds, only: kind_phys - use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t - - implicit none - private - - public test_host - - ! Public data and interfaces - integer, public, parameter :: cs = 16 - integer, public, parameter :: cm = 41 - - !> \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 - - type(ccpp_constituent_properties_t), private, target, allocatable :: host_constituents(:) - - private :: check_suite - private :: advect_constituents ! Move data around - private :: check_errflg - -CONTAINS - - subroutine check_errflg(subname, errflg, errmsg, errflg_final) - ! If errflg is not zero, print an error message - character(len=*), intent(in) :: subname - integer, intent(in) :: errflg - character(len=*), intent(in) :: errmsg - - integer, intent(out) :: errflg_final - - if (errflg /= 0) then - write(6, '(a,i0,4a)') "Error ", errflg, " from ", trim(subname), & - ':', trim(errmsg) - !Notify test script that a failure occurred: - errflg_final = -1 !Notify test script that a failure occured - end if - - end subroutine check_errflg - - 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 - logical :: check - integer :: errflg - character(len=512) :: errmsg - character(len=128), allocatable :: test_list(:) - - check_suite = .true. - ! 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 - - subroutine advect_constituents() - use test_host_mod, only: phys_state, ncnst - use test_host_mod, only: twist_array - - ! Local variables - integer :: q_ind ! Constituent index - - do q_ind = 1, ncnst ! Skip checks, they were done in constituents_in - call twist_array(phys_state%q(:,:,q_ind)) - end do - end subroutine advect_constituents - - !> \section arg_table_test_host Argument Table - !! \htmlinclude arg_table_test_host.html - !! - subroutine test_host(retval, test_suites) - - use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t - use test_host_mod, only: num_time_steps - use test_host_mod, only: init_data, compare_data - use test_host_mod, only: ncols, pver - use test_host_data, only: num_consts, std_name_array, const_std_name - use test_host_data, only: check_constituent_indices - use test_host_ccpp_cap, only: test_host_ccpp_deallocate_dynamic_constituents - use test_host_ccpp_cap, only: test_host_ccpp_register_constituents - use test_host_ccpp_cap, only: test_host_ccpp_is_scheme_constituent - use test_host_ccpp_cap, only: test_host_ccpp_initialize_constituents - use test_host_ccpp_cap, only: test_host_ccpp_number_constituents - use test_host_ccpp_cap, only: test_host_constituents_array - 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_ccpp_cap, only: test_host_const_get_index - use test_host_ccpp_cap, only: test_host_model_const_properties - use test_utils, only: check_list - - type(suite_info), intent(in) :: test_suites(:) - logical, intent(out) :: retval - - logical :: check - integer :: col_start, col_end - integer :: index, sind - integer :: index_liq, index_ice - integer :: index_dyn1, index_dyn2, index_dyn3 - integer :: time_step - integer :: num_suites - integer :: num_advected ! Num advected species - logical :: const_log - logical :: is_constituent - logical :: has_default - integer :: test_scalar_const_index - integer :: test_const_indices(num_consts) - character(len=128), allocatable :: suite_names(:) - character(len=256) :: const_str - character(len=512) :: errmsg - character(len=512) :: expected_error - integer :: errflg - integer :: errflg_final ! Used to notify testing script of test failure - real(kind_phys), pointer :: const_ptr(:,:,:) - real(kind_phys) :: default_value - real(kind_phys) :: check_value - type(ccpp_constituent_prop_ptr_t), pointer :: const_props(:) - character(len=*), parameter :: subname = 'test_host' - - ! Initialized "final" error flag used to report a failure to the larged - ! testing script: - errflg_final = 0 - - ! 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 - - errflg = 0 - errmsg = '' - - ! Check that is_scheme_constituent works as expected - call test_host_ccpp_is_scheme_constituent('specific_humidity', & - is_constituent, errflg, errmsg) - call check_errflg(subname//"_ccpp_is_scheme_constituent", errflg, & - errmsg, errflg_final) - ! specific_humidity should not be an existing constituent - if (is_constituent) then - write(6, *) "ERROR: specific humidity is already a constituent" - errflg_final = -1 ! Notify test script that a failure occurred - end if - call test_host_ccpp_is_scheme_constituent('cloud_ice_dry_mixing_ratio', & - is_constituent, errflg, errmsg) - call check_errflg(subname//"_ccpp_is_scheme_constituent", errflg, & - errmsg, errflg_final) - ! cloud_ice_dry_mixing_ratio should be an existing constituent - if (.not. is_constituent) then - write(6, *) "ERROR: cloud_ice_dry_mixing ratio not found in ", & - "host cap constituent list" - errflg_final = -1 ! Notify test script that a failure occurred - end if - - ! Use the suite information to call the register phase + use ccpp_kinds, only: kind_phys + use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t + + implicit none + private + + public test_host + + ! Public data and interfaces + integer, public, parameter :: cs = 16 + integer, public, parameter :: cm = 41 + + !> \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 + + type(ccpp_constituent_properties_t), private, target, allocatable :: host_constituents(:) + + private :: check_suite + private :: advect_constituents ! Move data around + private :: check_errflg + +contains + + subroutine check_errflg(subname, errflg, errmsg, errflg_final) + ! If errflg is not zero, print an error message + character(len=*), intent(in) :: subname + integer, intent(in) :: errflg + character(len=*), intent(in) :: errmsg + + integer, intent(out) :: errflg_final + + if (errflg /= 0) then + write(6, '(a,i0,4a)') "Error ", errflg, " from ", trim(subname), & + ':', trim(errmsg) + !Notify test script that a failure occurred: + errflg_final = -1 !Notify test script that a failure occured + end if + + end subroutine check_errflg + + 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 + logical :: check + integer :: errflg + character(len=512) :: errmsg + character(len=128), allocatable :: test_list(:) + + check_suite = .true. + ! 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 + + subroutine advect_constituents() + use test_host_mod, only: phys_state, & + ncnst + use test_host_mod, only: twist_array + + ! Local variables + integer :: q_ind ! Constituent index + + do q_ind = 1, ncnst ! Skip checks, they were done in constituents_in + call twist_array(phys_state%q(:, :, q_ind)) + end do + end subroutine advect_constituents + + !> \section arg_table_test_host Argument Table + !! \htmlinclude arg_table_test_host.html + !! + subroutine test_host(retval, test_suites) + + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t + use test_host_mod, only: num_time_steps + use test_host_mod, only: init_data, & + compare_data + use test_host_mod, only: ncols, & + pver + use test_host_data, only: num_consts, & + std_name_array, & + const_std_name + use test_host_data, only: check_constituent_indices + use test_host_ccpp_cap, only: test_host_ccpp_deallocate_dynamic_constituents + use test_host_ccpp_cap, only: test_host_ccpp_register_constituents + use test_host_ccpp_cap, only: test_host_ccpp_is_scheme_constituent + use test_host_ccpp_cap, only: test_host_ccpp_initialize_constituents + use test_host_ccpp_cap, only: test_host_ccpp_number_constituents + use test_host_ccpp_cap, only: test_host_constituents_array + 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_ccpp_cap, only: test_host_const_get_index + use test_host_ccpp_cap, only: test_host_model_const_properties + use test_utils, only: check_list + + type(suite_info), intent(in) :: test_suites(:) + logical, intent(out) :: retval + + logical :: check + integer :: col_start, col_end + integer :: index, sind + integer :: index_liq, index_ice + integer :: index_dyn1, index_dyn2, index_dyn3 + integer :: time_step + integer :: num_suites + integer :: num_advected ! Num advected species + logical :: const_log + logical :: is_constituent + logical :: has_default + integer :: test_scalar_const_index + integer :: test_const_indices(num_consts) + character(len=128), allocatable :: suite_names(:) + character(len=256) :: const_str + character(len=512) :: errmsg + character(len=512) :: expected_error + integer :: errflg + integer :: errflg_final ! Used to notify testing script of test failure + real(kind=kind_phys), pointer :: const_ptr(:, :, :) + real(kind=kind_phys) :: default_value + real(kind=kind_phys) :: check_value + type(ccpp_constituent_prop_ptr_t), pointer :: const_props(:) + character(len=*), parameter :: subname = 'test_host' + + ! Initialized "final" error flag used to report a failure to the larged + ! testing script: + errflg_final = 0 + + ! 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 (errflg == 0) then - 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) - exit - end if - end if - end do - - ! Register the constituents to find out what needs advecting - ! DO A COUPLE OF TESTS FIRST - - ! First confirm the correct error occurs if you try to add an - ! incompatible constituent with the same standard name - expected_error = 'ccp_model_const_add_metadata ERROR: Trying to add ' //& - 'constituent specific_humidity but an incompatible ' // & - 'constituent with this name already exists' - allocate(host_constituents(2)) - call host_constituents(1)%instantiate(std_name="specific_humidity", & - long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & - vertical_dim="vertical_layer_dimension", advected=.true., & - min_value=1000._kind_phys, molar_mass=2000._kind_phys, & - errcode=errflg, errmsg=errmsg) - call host_constituents(2)%instantiate(std_name="specific_humidity", & - long_name="Specific humidity", diag_name='H2O', units="kg kg", & - vertical_dim="vertical_layer_dimension", advected=.true., & - min_value=1000._kind_phys, molar_mass=2000._kind_phys, & - errcode=errflg, errmsg=errmsg) - call check_errflg(subname//'.initialize', errflg, errmsg, errflg_final) - if (errflg == 0) then - call test_host_ccpp_register_constituents(host_constituents, & - errmsg=errmsg, errflg=errflg) - end if - ! Check the error - if (errflg == 0) then - write(6, '(2a)') 'ERROR register_constituents: expected this error: ', & - trim(expected_error) - else - if (trim(errmsg) /= trim(expected_error)) then - write(6, '(4a)') 'ERROR register_constituents: expected this error: ', & - trim(expected_error), ' Got: ', trim(errmsg) - end if - end if - ! Now try again but with a compatible constituent - should be ignored when - ! the constituents object is created - ! Use the suite information to call the register phase - errflg = 0 - call test_host_ccpp_deallocate_dynamic_constituents() - deallocate(host_constituents) - do sind = 1, num_suites - if (errflg == 0) then - 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) - exit - end if - end if + if (trim(test_suites(sind)%suite_name) == & + trim(suite_names(index))) then + exit + end if end do - allocate(host_constituents(2)) - call host_constituents(1)%instantiate(std_name="specific_humidity", & - long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & - vertical_dim="vertical_layer_dimension", advected=.true., & - min_value=1000._kind_phys, molar_mass=2000._kind_phys, & - errcode=errflg, errmsg=errmsg) - call host_constituents(2)%instantiate(std_name="specific_humidity", & - long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & - vertical_dim="vertical_layer_dimension", advected=.true., & - min_value=1000._kind_phys, molar_mass=2000._kind_phys, & - errcode=errflg, errmsg=errmsg) - call check_errflg(subname//'.initialize', errflg, errmsg, errflg_final) - if (errflg == 0) then - call test_host_ccpp_register_constituents(host_constituents, & - errmsg=errmsg, errflg=errflg) - end if - if (errflg /= 0) then - write(6, '(2a)') 'ERROR register_constituents: ', trim(errmsg) - retval = .false. - return - end if - ! Check number of advected constituents - if (errflg == 0) then - call test_host_ccpp_number_constituents(num_advected, errmsg=errmsg, & - errflg=errflg) - call check_errflg(subname//".num_advected", errflg, errmsg, errflg_final) - end if - if (num_advected /= 6) then - write(6, '(a,i0)') "ERROR: num advected constituents = ", num_advected - retval = .false. - return - end if - ! Initialize constituent data - call test_host_ccpp_initialize_constituents(ncols, pver, errflg, errmsg) - - ! Stop tests here if initialization failed (as all other tests will likely - ! fail as well: - if (errflg /= 0) then - retval = .false. - return - end if - - ! Initialize our 'data' - const_ptr => test_host_constituents_array() - - ! Check if the specific humidity index can be found: - call test_host_const_get_index('specific_humidity', index, & - errflg, errmsg) - call check_errflg(subname//".index_specific_humidity", errflg, errmsg, & - errflg_final) - - ! Check if the cloud liquid index can be found: - call test_host_const_get_index('cloud_liquid_dry_mixing_ratio', & - index_liq, errflg, errmsg) - call check_errflg(subname//".index_cld_liq", errflg, errmsg, & - errflg_final) - - ! Check if the cloud ice index can be found: - call test_host_const_get_index('cloud_ice_dry_mixing_ratio', & - index_ice, errflg, errmsg) - call check_errflg(subname//".index_cld_ice", errflg, errmsg, & - errflg_final) - - ! Check if the dynamic constituents indices can be found - call test_host_const_get_index('dyn_const1', index_dyn1, errflg, errmsg) - call check_errflg(subname//".index_dyn_const1", errflg, errmsg, & - errflg_final) - call test_host_const_get_index('dyn_const2_wrt_moist_air', index_dyn2, errflg, errmsg) - call check_errflg(subname//".index_dyn_const2", errflg, errmsg, & - errflg_final) - call test_host_const_get_index('dyn_const3_wrt_moist_air_and_condensed_water', index_dyn3, errflg, errmsg) - call check_errflg(subname//".index_dyn_const3", errflg, errmsg, & - errflg_final) - - ! Load up the test array indices - call test_host_const_get_index(const_std_name, test_scalar_const_index, errflg, errmsg) - call check_errflg(subname//"."//const_std_name, errflg, errmsg, & - errflg_final) - do sind = 1, num_consts - call test_host_const_get_index(std_name_array(sind), & - test_const_indices(sind), errflg, errmsg) - call check_errflg(subname//"."//std_name_array(sind), errflg, errmsg, & - errflg_final) + 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 - - ! Stop tests here if the index checks failed, as all other tests will - ! likely fail as well: - if (errflg_final /= 0) then - retval = .false. - return - end if - - call init_data(const_ptr, index, index_liq, index_ice, index_dyn3) - - ! Check some constituent properties - ! ++++++++++++++++++++++++++++++++++ - - const_props => test_host_model_const_properties() - - ! Standard name: - call const_props(index)%standard_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get standard_name for specific_humidity, index = ", & - index, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'specific_humidity') then - write(6, *) "ERROR: standard name, '", trim(const_str), & - "' should be 'specific_humidity'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check standard name for a dynamic constituent - call const_props(index_dyn2)%standard_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get standard_name for dyn_const2, index = ", & - index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'dyn_const2_wrt_moist_air') then - write(6, *) "ERROR: standard name, '", trim(const_str), & - "' should be 'dyn_const2_wrt_moist_air'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - - ! Long name: - call const_props(index_liq)%long_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get long_name for cld_liq index = ", & - index_liq, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'Cloud liquid dry mixing ratio') then - write(6, *) "ERROR: long name, '", trim(const_str), & - "' should be 'Cloud liquid dry mixing ratio'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check long name for a dynamic constituent - call const_props(index_dyn1)%long_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get long_name for dyn_const1 index = ", & - index_dyn1, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if + end if + !!! Return here if any check failed + if ( .not. retval) then + return + end if + + errflg = 0 + errmsg = '' + + ! Check that is_scheme_constituent works as expected + call test_host_ccpp_is_scheme_constituent('specific_humidity', & + is_constituent, errflg, errmsg) + call check_errflg(subname // "_ccpp_is_scheme_constituent", errflg, & + errmsg, errflg_final) + ! specific_humidity should not be an existing constituent + if (is_constituent) then + write(6, *) "ERROR: specific humidity is already a constituent" + errflg_final = -1 ! Notify test script that a failure occurred + end if + call test_host_ccpp_is_scheme_constituent('cloud_ice_dry_mixing_ratio', & + is_constituent, errflg, errmsg) + call check_errflg(subname // "_ccpp_is_scheme_constituent", errflg, & + errmsg, errflg_final) + ! cloud_ice_dry_mixing_ratio should be an existing constituent + if ( .not. is_constituent) then + write(6, *) "ERROR: cloud_ice_dry_mixing ratio not found in ", & + "host cap constituent list" + errflg_final = -1 ! Notify test script that a failure occurred + end if + + ! Use the suite information to call the register phase + do sind = 1, num_suites if (errflg == 0) then - if (trim(const_str) /= 'dyn const1') then - write(6, *) "ERROR: long name, '", trim(const_str), & - "' should be 'dyn const1'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Diagnostic name: - call const_props(index_liq)%diagnostic_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get diagnostic name for cld_liq index = ", & - index_liq, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'CLDLIQ') then - write(6, *) "ERROR: diagnostic name, '", trim(const_str), & - "' should be 'CLDLIQ'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check default diagnostic name is set correctly - call const_props(index_ice)%diagnostic_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get diagnostic name for cld_ice index = ", & - index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'cld_ice_array') then - write(6, *) "ERROR: diagnostic name, '", trim(const_str), & - "' should be 'cld_ice_array'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check diagnostic name of a dynamic constituent - call const_props(index_dyn2)%diagnostic_name(const_str, errflg, & - errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get diagnostic name for dyn_const2 index = ", & - index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'DYNCONST2') then - write(6, *) "ERROR: diagnostic name, '", trim(const_str), & - "' should be 'DYNCONST2'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Mass mixing ratio: - call const_props(index_ice)%is_mass_mixing_ratio(const_log, errflg, & - errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get mass mixing ratio prop for cld_ice index = ", & - index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (.not. const_log) then - write(6, *) "ERROR: cloud ice is not a mass mixing_ratio" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check mass mixing ratio for a dynamic constituent - call const_props(index_dyn2)%is_mass_mixing_ratio(const_log, errflg, & - errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get mass mixing ratio prop for dyn_const2 index = ", & - index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if + 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) + exit + end if + end if + end do + + ! Register the constituents to find out what needs advecting + ! DO A COUPLE OF TESTS FIRST + + ! First confirm the correct error occurs if you try to add an + ! incompatible constituent with the same standard name + expected_error = 'ccp_model_const_add_metadata ERROR: Trying to add ' //& + 'constituent specific_humidity but an incompatible ' // & + 'constituent with this name already exists' + allocate(host_constituents(2)) + call host_constituents(1)%instantiate(std_name="specific_humidity", & + long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & + vertical_dim="vertical_layer_dimension", advected=.true., & + min_value=1000._kind_phys, molar_mass=2000._kind_phys, & + errcode=errflg, errmsg=errmsg) + call host_constituents(2)%instantiate(std_name="specific_humidity", & + long_name="Specific humidity", diag_name='H2O', units="kg kg", & + vertical_dim="vertical_layer_dimension", advected=.true., & + min_value=1000._kind_phys, molar_mass=2000._kind_phys, & + errcode=errflg, errmsg=errmsg) + call check_errflg(subname // '.initialize', errflg, errmsg, errflg_final) + if (errflg == 0) then + call test_host_ccpp_register_constituents(host_constituents, & + errmsg=errmsg, errflg=errflg) + end if + ! Check the error + if (errflg == 0) then + write(6, '(2a)') 'ERROR register_constituents: expected this error: ', & + trim(expected_error) + else + if (trim(errmsg) /= trim(expected_error)) then + write(6, '(4a)') 'ERROR register_constituents: expected this error: ', & + trim(expected_error), ' Got: ', trim(errmsg) + end if + end if + ! Now try again but with a compatible constituent - should be ignored when + ! the constituents object is created + ! Use the suite information to call the register phase + errflg = 0 + call test_host_ccpp_deallocate_dynamic_constituents() + deallocate(host_constituents) + do sind = 1, num_suites if (errflg == 0) then - if (.not. const_log) then - write(6, *) "ERROR: dyn_const2 is not a mass mixing_ratio" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Dry mixing ratio: - call const_props(index_ice)%is_dry(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get dry prop for cld_ice index = ", index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (.not. const_log) then - write(6, *) "ERROR: cloud ice mass_mixing_ratio is not dry" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check wet mixing ratio for dynamic constituent 1 - call const_props(index_dyn1)%is_dry(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get dry prop for dyn_const1 index = ", index_dyn1, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (const_log) then - write(6, *) "ERROR: dyn_const1 is dry and should be wet" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_dyn1)%is_wet(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get wet prop for dyn_const1 index = ", index_dyn1, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (.not. const_log) then - write(6, *) "ERROR: dyn_const1 is not wet but should be" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check moist mixing ratio for dynamic constituent 2 - call const_props(index_dyn2)%is_dry(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get dry prop for dyn_const2 index = ", index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (const_log) then - write(6, *) "ERROR: dyn_const2 is dry and should be moist" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_dyn2)%is_moist(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get moist prop for dyn_const2 index = ", index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (.not. const_log) then - write(6, *) "ERROR: dyn_const2 is not moist but should be" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check dry mixing ratio for dynamic constituent 3 - call const_props(index_dyn3)%is_dry(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get dry prop for dyn_const3 index = ", index_dyn3, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (.not. const_log) then - write(6, *) "ERROR: dyn_const3 is not dry and should be" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! ------------------- - - ! ------------------- - ! minimum value tests: - ! ------------------- - - ! Check that a constituent's minimum value defaults to zero: - call const_props(index_dyn2)%minimum(check_value, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get minimum value for dyn_const2 index = ", index_dyn2, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (check_value /= 0._kind_phys) then ! Should be zero - write(6, *) "ERROR: 'minimum' should default to zero for all ", & - "constituents unless set by host model or scheme metadata." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Check that a constituent instantiated with a specified minimum value - ! actually contains that minimum value property: + 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) + exit + end if + end if + end do + allocate(host_constituents(2)) + call host_constituents(1)%instantiate(std_name="specific_humidity", & + long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & + vertical_dim="vertical_layer_dimension", advected=.true., & + min_value=1000._kind_phys, molar_mass=2000._kind_phys, & + errcode=errflg, errmsg=errmsg) + call host_constituents(2)%instantiate(std_name="specific_humidity", & + long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & + vertical_dim="vertical_layer_dimension", advected=.true., & + min_value=1000._kind_phys, molar_mass=2000._kind_phys, & + errcode=errflg, errmsg=errmsg) + call check_errflg(subname // '.initialize', errflg, errmsg, errflg_final) + if (errflg == 0) then + call test_host_ccpp_register_constituents(host_constituents, & + errmsg=errmsg, errflg=errflg) + end if + if (errflg /= 0) then + write(6, '(2a)') 'ERROR register_constituents: ', trim(errmsg) + retval = .false. + return + end if + ! Check number of advected constituents + if (errflg == 0) then + call test_host_ccpp_number_constituents(num_advected, errmsg=errmsg, & + errflg=errflg) + call check_errflg(subname // ".num_advected", errflg, errmsg, errflg_final) + end if + if (num_advected /= 6) then + write(6, '(a,i0)') "ERROR: num advected constituents = ", num_advected + retval = .false. + return + end if + ! Initialize constituent data + call test_host_ccpp_initialize_constituents(ncols, pver, errflg, errmsg) + + ! Stop tests here if initialization failed (as all other tests will likely + ! fail as well: + if (errflg /= 0) then + retval = .false. + return + end if + + ! Initialize our 'data' + const_ptr => test_host_constituents_array() + + ! Check if the specific humidity index can be found: + call test_host_const_get_index('specific_humidity', index, & + errflg, errmsg) + call check_errflg(subname // ".index_specific_humidity", errflg, errmsg, & + errflg_final) + + ! Check if the cloud liquid index can be found: + call test_host_const_get_index('cloud_liquid_dry_mixing_ratio', & + index_liq, errflg, errmsg) + call check_errflg(subname // ".index_cld_liq", errflg, errmsg, & + errflg_final) + + ! Check if the cloud ice index can be found: + call test_host_const_get_index('cloud_ice_dry_mixing_ratio', & + index_ice, errflg, errmsg) + call check_errflg(subname // ".index_cld_ice", errflg, errmsg, & + errflg_final) + + ! Check if the dynamic constituents indices can be found + call test_host_const_get_index('dyn_const1', index_dyn1, errflg, errmsg) + call check_errflg(subname // ".index_dyn_const1", errflg, errmsg, & + errflg_final) + call test_host_const_get_index('dyn_const2_wrt_moist_air', index_dyn2, errflg, errmsg) + call check_errflg(subname // ".index_dyn_const2", errflg, errmsg, & + errflg_final) + call test_host_const_get_index('dyn_const3_wrt_moist_air_and_condensed_water', index_dyn3, errflg, errmsg) + call check_errflg(subname // ".index_dyn_const3", errflg, errmsg, & + errflg_final) + + ! Load up the test array indices + call test_host_const_get_index(const_std_name, test_scalar_const_index, errflg, errmsg) + call check_errflg(subname // "." // const_std_name, errflg, errmsg, & + errflg_final) + do sind = 1, num_consts + call test_host_const_get_index(std_name_array(sind), & + test_const_indices(sind), errflg, errmsg) + call check_errflg(subname // "." // std_name_array(sind), errflg, errmsg, & + errflg_final) + end do + + ! Stop tests here if the index checks failed, as all other tests will + ! likely fail as well: + if (errflg_final /= 0) then + retval = .false. + return + end if + + call init_data(const_ptr, index, index_liq, index_ice, index_dyn3) + + ! Check some constituent properties + ! ++++++++++++++++++++++++++++++++++ + + const_props => test_host_model_const_properties() + + ! Standard name: + call const_props(index)%standard_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get standard_name for specific_humidity, index = ", & + index, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'specific_humidity') then + write(6, *) "ERROR: standard name, '", trim(const_str), & + "' should be 'specific_humidity'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check standard name for a dynamic constituent + call const_props(index_dyn2)%standard_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get standard_name for dyn_const2, index = ", & + index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'dyn_const2_wrt_moist_air') then + write(6, *) "ERROR: standard name, '", trim(const_str), & + "' should be 'dyn_const2_wrt_moist_air'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Long name: + call const_props(index_liq)%long_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get long_name for cld_liq index = ", & + index_liq, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'Cloud liquid dry mixing ratio') then + write(6, *) "ERROR: long name, '", trim(const_str), & + "' should be 'Cloud liquid dry mixing ratio'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check long name for a dynamic constituent + call const_props(index_dyn1)%long_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get long_name for dyn_const1 index = ", & + index_dyn1, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'dyn const1') then + write(6, *) "ERROR: long name, '", trim(const_str), & + "' should be 'dyn const1'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Diagnostic name: + call const_props(index_liq)%diagnostic_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get diagnostic name for cld_liq index = ", & + index_liq, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'CLDLIQ') then + write(6, *) "ERROR: diagnostic name, '", trim(const_str), & + "' should be 'CLDLIQ'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check default diagnostic name is set correctly + call const_props(index_ice)%diagnostic_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get diagnostic name for cld_ice index = ", & + index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'cld_ice_array') then + write(6, *) "ERROR: diagnostic name, '", trim(const_str), & + "' should be 'cld_ice_array'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check diagnostic name of a dynamic constituent + call const_props(index_dyn2)%diagnostic_name(const_str, errflg, & + errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get diagnostic name for dyn_const2 index = ", & + index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'DYNCONST2') then + write(6, *) "ERROR: diagnostic name, '", trim(const_str), & + "' should be 'DYNCONST2'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Mass mixing ratio: + call const_props(index_ice)%is_mass_mixing_ratio(const_log, errflg, & + errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get mass mixing ratio prop for cld_ice index = ", & + index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if ( .not. const_log) then + write(6, *) "ERROR: cloud ice is not a mass mixing_ratio" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check mass mixing ratio for a dynamic constituent + call const_props(index_dyn2)%is_mass_mixing_ratio(const_log, errflg, & + errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get mass mixing ratio prop for dyn_const2 index = ", & + index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if ( .not. const_log) then + write(6, *) "ERROR: dyn_const2 is not a mass mixing_ratio" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Dry mixing ratio: + call const_props(index_ice)%is_dry(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get dry prop for cld_ice index = ", index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if ( .not. const_log) then + write(6, *) "ERROR: cloud ice mass_mixing_ratio is not dry" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check wet mixing ratio for dynamic constituent 1 + call const_props(index_dyn1)%is_dry(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get dry prop for dyn_const1 index = ", index_dyn1, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (const_log) then + write(6, *) "ERROR: dyn_const1 is dry and should be wet" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_dyn1)%is_wet(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get wet prop for dyn_const1 index = ", index_dyn1, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if ( .not. const_log) then + write(6, *) "ERROR: dyn_const1 is not wet but should be" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check moist mixing ratio for dynamic constituent 2 + call const_props(index_dyn2)%is_dry(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get dry prop for dyn_const2 index = ", index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (const_log) then + write(6, *) "ERROR: dyn_const2 is dry and should be moist" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_dyn2)%is_moist(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get moist prop for dyn_const2 index = ", index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if ( .not. const_log) then + write(6, *) "ERROR: dyn_const2 is not moist but should be" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check dry mixing ratio for dynamic constituent 3 + call const_props(index_dyn3)%is_dry(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get dry prop for dyn_const3 index = ", index_dyn3, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if ( .not. const_log) then + write(6, *) "ERROR: dyn_const3 is not dry and should be" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! ------------------- + + ! ------------------- + ! minimum value tests: + ! ------------------- + + ! Check that a constituent's minimum value defaults to zero: + call const_props(index_dyn2)%minimum(check_value, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get minimum value for dyn_const2 index = ", index_dyn2, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (check_value /= 0._kind_phys) then ! Should be zero + write(6, *) "ERROR: 'minimum' should default to zero for all ", & + "constituents unless set by host model or scheme metadata." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that a constituent instantiated with a specified minimum value + ! actually contains that minimum value property: + call const_props(index_dyn1)%minimum(check_value, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get minimum value for dyn_const1 index = ", index_dyn1, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (check_value /= 1000._kind_phys) then !Should be 1000 + write(6, *) "ERROR: 'minimum' should give a value of 1000 ", & + "for dyn_const1, as was set during instantiation." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that setting a constituent's minimum value works + ! as expected: + call const_props(index_dyn1)%set_minimum(1._kind_phys, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to set minimum value for dyn_const1 index = ", index_dyn1, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then call const_props(index_dyn1)%minimum(check_value, errflg, errmsg) if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get minimum value for dyn_const1 index = ", index_dyn1, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (check_value /= 1000._kind_phys) then !Should be 1000 - write(6, *) "ERROR: 'minimum' should give a value of 1000 ", & - "for dyn_const1, as was set during instantiation." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Check that setting a constituent's minimum value works - ! as expected: - call const_props(index_dyn1)%set_minimum(1._kind_phys, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to set minimum value for dyn_const1 index = ", index_dyn1, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - call const_props(index_dyn1)%minimum(check_value, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - " trying to get minimum value for dyn_const1 index = ", & - index_dyn1, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - end if - if (errflg == 0) then - if (check_value /= 1._kind_phys) then ! Should now be one - write(6, *) "ERROR: 'set_minimum' did not set constituent", & - " minimum value correctly." - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! ---------------------- - ! molecular weight tests: - ! ---------------------- - - ! Check that a constituent instantiated with a specified molecular - ! weight actually contains that molecular weight property value: - call const_props(index)%molar_mass(check_value, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get molecular weight for specific humidity index = ", & - index, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (check_value /= 2000._kind_phys) then ! Should be 2000 - write(6, *) "ERROR: 'molar_mass' should give a value of 2000 ", & - "for specific humidity, as was set during instantiation." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Check that setting a constituent's molecular weight works - ! as expected: - call const_props(index_ice)%set_molar_mass(1._kind_phys, errflg, & - errmsg) + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + " trying to get minimum value for dyn_const1 index = ", & + index_dyn1, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + end if + if (errflg == 0) then + if (check_value /= 1._kind_phys) then ! Should now be one + write(6, *) "ERROR: 'set_minimum' did not set constituent", & + " minimum value correctly." + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! ---------------------- + ! molecular weight tests: + ! ---------------------- + + ! Check that a constituent instantiated with a specified molecular + ! weight actually contains that molecular weight property value: + call const_props(index)%molar_mass(check_value, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get molecular weight for specific humidity index = ", & + index, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (check_value /= 2000._kind_phys) then ! Should be 2000 + write(6, *) "ERROR: 'molar_mass' should give a value of 2000 ", & + "for specific humidity, as was set during instantiation." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that setting a constituent's molecular weight works + ! as expected: + call const_props(index_ice)%set_molar_mass(1._kind_phys, errflg, & + errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to set molecular weight for cld_ice index = ", index_ice, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + call const_props(index_ice)%molar_mass(check_value, errflg, errmsg) if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to set molecular weight for cld_ice index = ", index_ice, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - call const_props(index_ice)%molar_mass(check_value, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - " trying to get molecular weight for cld_ice index = ", & - index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - end if - if (errflg == 0) then - if (check_value /= 1._kind_phys) then ! Should be equal to one - write(6, *) "ERROR: 'set_molar_mass' did not set constituent", & - " molecular weight value correctly." - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! ------------------- - ! thermo-active tests: - ! ------------------- - - ! Check that being thermodynamically active defaults to False: + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + " trying to get molecular weight for cld_ice index = ", & + index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + end if + if (errflg == 0) then + if (check_value /= 1._kind_phys) then ! Should be equal to one + write(6, *) "ERROR: 'set_molar_mass' did not set constituent", & + " molecular weight value correctly." + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! ------------------- + ! thermo-active tests: + ! ------------------- + + ! Check that being thermodynamically active defaults to False: + call const_props(index_ice)%is_thermo_active(check, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get thermo_active prop for cld_ice index = ", index_ice, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (check) then ! Should be False + write(6, *) "ERROR: 'is_thermo_active' should default to False ", & + "for all constituents unless set by host model." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that setting a constituent to be thermodynamically active works + ! as expected: + call const_props(index_ice)%set_thermo_active(.true., errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to set thermo_active prop for cld_ice index = ", index_ice, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then call const_props(index_ice)%is_thermo_active(check, errflg, errmsg) if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get thermo_active prop for cld_ice index = ", index_ice, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (check) then ! Should be False - write(6, *) "ERROR: 'is_thermo_active' should default to False ", & - "for all constituents unless set by host model." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Check that setting a constituent to be thermodynamically active works - ! as expected: - call const_props(index_ice)%set_thermo_active(.true., errflg, errmsg) + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + " trying to get thermo_active prop for cld_ice index = ", & + index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + end if + if (errflg == 0) then + if ( .not. check) then ! Should now be True + write(6, *) "ERROR: 'set_thermo_active' did not set", & + " thermo_active constituent property correctly." + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! ------------------- + + ! ------------------- + ! water-species tests: + ! ------------------- + + ! Check that being a water species defaults to False: + call const_props(index_liq)%is_water_species(check, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get water_species prop for cld_liq index = ", index_liq, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (check) then ! Should be False + write(6, *) "ERROR: 'is_water_species' should default to False ", & + "for all constituents unless set by host model." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that setting a constituent to be a water species works + ! as expected: + call const_props(index_liq)%set_water_species(.true., errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to set water_species prop for cld_liq index = ", index_liq, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + call const_props(index_liq)%is_water_species(check, errflg, errmsg) if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to set thermo_active prop for cld_ice index = ", index_ice, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - call const_props(index_ice)%is_thermo_active(check, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - " trying to get thermo_active prop for cld_ice index = ", & - index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - end if - if (errflg == 0) then - if (.not. check) then ! Should now be True - write(6, *) "ERROR: 'set_thermo_active' did not set", & - " thermo_active constituent property correctly." - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! ------------------- + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + " trying to get water_species prop for cld_liq index = ", & + index_liq, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + end if + if (errflg == 0) then + if ( .not. check) then ! Should now be True + write(6, *) "ERROR: 'set_water_species' did not set", & + " water_species constituent property correctly." + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that setting a constituent to be a water species via the + ! instantiate call works as expected + call const_props(index_dyn1)%is_water_species(check, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + "trying to get water_species prop for dyn_const1 index = ", & + index_dyn1, trim(errmsg) + end if + if (errflg == 0) then + if ( .not. check) then ! Should now be True + write(6, *) "ERROR: 'water_species=.true. did not set", & + " water_species constituent property correctly" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_dyn2)%is_water_species(check, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + "trying to get water_species prop for dyn_const2 index = ", & + index_dyn2, trim(errmsg) + end if + if (errflg == 0) then + if (check) then ! Should now be False + write(6, *) "ERROR: 'water_species=.false. did not set", & + " water_species constituent property correctly" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! ------------------- + + ! Check that setting a constituent's default value works as expected + call const_props(index_liq)%has_default(has_default, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to check for default for cld_liq index = ", index_liq, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (has_default) then + write(6, *) "ERROR: cloud liquid mass_mixing_ratio should not have default but does" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_ice)%has_default(has_default, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to check for default for cld_ice index = ", index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if ( .not. has_default) then + write(6, *) "ERROR: cloud ice mass_mixing_ratio should have default but doesn't" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_ice)%default_value(default_value, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to grab default for cld_ice index = ", index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (default_value /= 0.0_kind_phys) then + write(6, *) "ERROR: cloud ice mass_mixing_ratio default is ", default_value, & + " but should be 0.0" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! ++++++++++++++++++++++++++++++++++ - ! ------------------- - ! water-species tests: - ! ------------------- + ! Set error flag to the "final" value, because any error + ! above will likely result in a large number of failures + ! below: + errflg = errflg_final - ! Check that being a water species defaults to False: - call const_props(index_liq)%is_water_species(check, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get water_species prop for cld_liq index = ", index_liq, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if + ! Use the suite information to setup the run + do sind = 1, num_suites if (errflg == 0) then - if (check) then ! Should be False - write(6, *) "ERROR: 'is_water_species' should default to False ", & - "for all constituents unless set by host model." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if + 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) + exit + end if + end if + end do + + ! Check indices + call check_constituent_indices(test_scalar_const_index, test_const_indices, & + errmsg, errflg) + call check_errflg(subname // " check suite indices", errflg, errmsg, & + errflg_final) + + ! Loop over time steps + do time_step = 1, num_time_steps + ! Initialize the timestep + do sind = 1, num_suites + if (errflg == 0) then + call test_host_ccpp_physics_timestep_initial( & + test_suites(sind)%suite_name, errmsg, errflg) + if (errflg /= 0) then + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(errmsg) + end if + end if + end do - ! Check that setting a constituent to be a water species works - ! as expected: - call const_props(index_liq)%set_water_species(.true., errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to set water_species prop for cld_liq index = ", index_liq, & + do col_start = 1, ncols, 5 + if (errflg /= 0) then + continue + end if + col_end = min(col_start + 4, ncols) + + do sind = 1, num_suites + do index = 1, size(test_suites(sind)%suite_parts) + 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) + 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 if + end do + end do + end do + ! Check indices + call check_constituent_indices(test_scalar_const_index, test_const_indices, & + errmsg, errflg) + call check_errflg(subname // " check suite indices", errflg, errmsg, & + errflg_final) + + do sind = 1, num_suites + 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) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - call const_props(index_liq)%is_water_species(check, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - " trying to get water_species prop for cld_liq index = ", & - index_liq, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - end if - if (errflg == 0) then - if (.not. check) then ! Should now be True - write(6, *) "ERROR: 'set_water_species' did not set", & - " water_species constituent property correctly." - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if + exit + end if + end do - ! Check that setting a constituent to be a water species via the - ! instantiate call works as expected - call const_props(index_dyn1)%is_water_species(check, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - "trying to get water_species prop for dyn_const1 index = ", & - index_dyn1, trim(errmsg) - end if + ! Run "dycore" if (errflg == 0) then - if (.not. check) then ! Should now be True - write(6,*) "ERROR: 'water_species=.true. did not set", & - " water_species constituent property correctly" - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_dyn2)%is_water_species(check, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - "trying to get water_species prop for dyn_const2 index = ", & - index_dyn2, trim(errmsg) + call advect_constituents() end if - if (errflg == 0) then - if (check) then ! Should now be False - write(6,*) "ERROR: 'water_species=.false. did not set", & - " water_species constituent property correctly" - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! ------------------- + end do ! End time step loop - ! Check that setting a constituent's default value works as expected - call const_props(index_liq)%has_default(has_default, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to check for default for cld_liq index = ", index_liq, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if + do sind = 1, num_suites if (errflg == 0) then - if (has_default) then - write(6, *) "ERROR: cloud liquid mass_mixing_ratio should not have default but does" - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_ice)%has_default(has_default, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to check for default for cld_ice index = ", index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (.not. has_default) then - write(6, *) "ERROR: cloud ice mass_mixing_ratio should have default but doesn't" - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_ice)%default_value(default_value, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to grab default for cld_ice index = ", index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (default_value /= 0.0_kind_phys) then - write(6, *) "ERROR: cloud ice mass_mixing_ratio default is ", default_value, & - " but should be 0.0" - errflg_final = -1 ! Notify test script that a failure occurred - end if + call test_host_ccpp_physics_finalize( & + test_suites(sind)%suite_name, errmsg, errflg) + 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 if + end do + + if (errflg == 0) then + ! Run finished without error, check answers + if (compare_data(num_advected)) then + write(6, *) 'Answers are correct!' + errflg = 0 else - ! Reset error flag to continue testing other properties: - errflg = 0 + write(6, *) 'Answers are not correct!' + errflg = -1 end if - ! ++++++++++++++++++++++++++++++++++ - - ! Set error flag to the "final" value, because any error - ! above will likely result in a large number of failures - ! below: - errflg = errflg_final - - ! Use the suite information to setup the run - do sind = 1, num_suites - if (errflg == 0) then - 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) - exit - end if - end if - end do - - ! Check indices - call check_constituent_indices(test_scalar_const_index, test_const_indices, & - errmsg, errflg) - call check_errflg(subname//" check suite indices", errflg, errmsg, & - errflg_final) - - ! Loop over time steps - do time_step = 1, num_time_steps - ! Initialize the timestep - do sind = 1, num_suites - if (errflg == 0) then - call test_host_ccpp_physics_timestep_initial( & - test_suites(sind)%suite_name, errmsg, errflg) - if (errflg /= 0) then - write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(errmsg) - end if - end if - end do - - do col_start = 1, ncols, 5 - if (errflg /= 0) then - continue - end if - col_end = MIN(col_start + 4, ncols) - - do sind = 1, num_suites - do index = 1, size(test_suites(sind)%suite_parts) - 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) - 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 if - end do - end do - end do - ! Check indices - call check_constituent_indices(test_scalar_const_index, test_const_indices, & - errmsg, errflg) - call check_errflg(subname//" check suite indices", errflg, errmsg, & - errflg_final) - - do sind = 1, num_suites - 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 - - ! Run "dycore" - if (errflg == 0) then - call advect_constituents() - end if - end do ! End time step loop - - do sind = 1, num_suites - if (errflg == 0) then - call test_host_ccpp_physics_finalize( & - test_suites(sind)%suite_name, errmsg, errflg) - 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 if - end do - - if (errflg == 0) then - ! Run finished without error, check answers - if (compare_data(num_advected)) then - write(6, *) 'Answers are correct!' - errflg = 0 - else - write(6, *) 'Answers are not correct!' - errflg = -1 - end if - end if + end if - ! Make sure "final" flag is non-zero if "errflg" is: - if (errflg /= 0) then - errflg_final = -1 ! Notify test script that a failure occured - end if + ! Make sure "final" flag is non-zero if "errflg" is: + if (errflg /= 0) then + errflg_final = -1 ! Notify test script that a failure occured + end if - ! Set return value to False if any errors were found: - retval = errflg_final == 0 + ! Set return value to False if any errors were found: + retval = errflg_final == 0 - end subroutine test_host + end subroutine test_host - end module test_prog +end module test_prog diff --git a/test/advection_test/test_host_data.F90 b/test/advection_test/test_host_data.F90 index bbf0efdc..f360ad79 100644 --- a/test/advection_test/test_host_data.F90 +++ b/test/advection_test/test_host_data.F90 @@ -7,22 +7,22 @@ module test_host_data !> \section arg_table_physics_state Argument Table !! \htmlinclude arg_table_physics_state.html type physics_state - real(kind_phys), allocatable :: ps(:) ! surface pressure - real(kind_phys), allocatable :: temp(:,:) ! temperature - real(kind_phys), dimension(:,:,:), pointer :: q => NULL() ! constituent array + real(kind=kind_phys), allocatable :: ps(:) ! surface pressure + real(kind=kind_phys), allocatable :: temp(:, :) ! temperature + real(kind=kind_phys), dimension(:, :, :), pointer :: q => null() ! constituent array end type physics_state !> \section arg_table_test_host_data Argument Table !! \htmlinclude arg_table_test_host_data.html integer, public, parameter :: num_consts = 3 - character(len=32), public, parameter :: std_name_array(num_consts) = (/ & - 'specific_humidity ', & - 'cloud_liquid_dry_mixing_ratio', & - 'cloud_ice_dry_mixing_ratio ' /) + character(len=32), public, parameter :: std_name_array(num_consts) = (/ & + 'specific_humidity ', & + 'cloud_liquid_dry_mixing_ratio', & + 'cloud_ice_dry_mixing_ratio ' /) character(len=32), public, parameter :: const_std_name = std_name_array(1) - integer :: const_inds(num_consts) = -1 ! test array access from suite - integer :: const_index = -1 ! test scalar access from suite + integer :: const_inds(num_consts) = -1 ! test array access from suite + integer :: const_index = -1 ! test scalar access from suite public :: allocate_physics_state public :: check_constituent_indices @@ -30,63 +30,63 @@ module test_host_data contains subroutine check_constituent_indices(test_index, test_indices, errmsg, errflg) - ! Check constituent indices against what was found by suite - ! indices are passed in rather than looked up to avoid a dependency loop - ! Dummy arguments - integer, intent(in) :: test_index ! scalar const index from host - integer, intent(in) :: test_indices(:) ! array_test_indices from host - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variable - integer :: indx - integer :: emstrt - - errflg = 0 - errmsg = '' - if (test_index /= const_index) then + ! Check constituent indices against what was found by suite + ! indices are passed in rather than looked up to avoid a dependency loop + ! Dummy arguments + integer, intent(in) :: test_index ! scalar const index from host + integer, intent(in) :: test_indices(:) ! array_test_indices from host + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variable + integer :: indx + integer :: emstrt + + errflg = 0 + errmsg = '' + if (test_index /= const_index) then + emstrt = len_trim(errmsg) + 1 + write(errmsg(emstrt:), '(2a,i0,a,i0)') 'const_index_check for ', & + const_std_name, test_index, ' /= ', const_index + errflg = errflg + 1 + end if + do indx = 1, num_consts + if (test_indices(indx) /= const_inds(indx)) then emstrt = len_trim(errmsg) + 1 - write(errmsg(emstrt:), '(2a,i0,a,i0)') 'const_index_check for ', & - const_std_name, test_index, ' /= ', const_index - errflg = errflg + 1 - end if - do indx = 1, num_consts - if (test_indices(indx) /= const_inds(indx)) then - emstrt = len_trim(errmsg) + 1 - if (len_trim(errmsg) > 0) then - write(errmsg(emstrt:), '(", ")') - emstrt = emstrt + 2 - end if - write(errmsg(emstrt:), '(2a,i0,a,i0)') 'const_indices_check for ', & - std_name_array(indx), test_indices(indx), ' /= ', const_inds(indx) - errflg = errflg + 1 + if (len_trim(errmsg) > 0) then + write(errmsg(emstrt:), '(", ")') + emstrt = emstrt + 2 end if - end do + write(errmsg(emstrt:), '(2a,i0,a,i0)') 'const_indices_check for ', & + std_name_array(indx), test_indices(indx), ' /= ', const_inds(indx) + errflg = errflg + 1 + end if + end do - ! Reset for next test - const_index = -1 - const_inds = -1 + ! Reset for next test + const_index = -1 + const_inds = -1 end subroutine check_constituent_indices subroutine allocate_physics_state(cols, levels, constituents, state) - integer, intent(in) :: cols - integer, intent(in) :: levels - real(kind_phys), pointer :: constituents(:,:,:) + integer, intent(in) :: cols + integer, intent(in) :: levels + real(kind=kind_phys), pointer :: constituents(:, :, :) type(physics_state), intent(out) :: state if (allocated(state%ps)) then - deallocate(state%ps) + deallocate(state%ps) end if allocate(state%ps(cols)) state%ps = 0.0_kind_phys if (allocated(state%temp)) then - deallocate(state%temp) + deallocate(state%temp) end if allocate(state%temp(cols, levels)) if (associated(state%q)) then - ! Do not deallocate (we do not own this array) - nullify(state%q) + ! Do not deallocate (we do not own this array) + nullify(state%q) end if ! Point to the advected constituents array state%q => constituents diff --git a/test/advection_test/test_host_mod.F90 b/test/advection_test/test_host_mod.F90 index 50826f17..c5f3bb26 100644 --- a/test/advection_test/test_host_mod.F90 +++ b/test/advection_test/test_host_mod.F90 @@ -1,175 +1,176 @@ module test_host_mod - use ccpp_kinds, only: kind_phys - use test_host_data, only: physics_state, allocate_physics_state - - implicit none - public - - integer, parameter :: num_time_steps = 2 - real(kind_phys), parameter :: tolerance = 1.0e-13_kind_phys - - !> \section arg_table_test_host_mod Argument Table - !! \htmlinclude arg_table_test_host_mod.html - !! - integer, parameter :: ncols = 10 - integer, parameter :: pver = 5 - integer, parameter :: pverP = pver + 1 - integer, protected :: ncnst = -1 - integer, protected :: index_qv = -1 - real(kind_phys) :: dt - real(kind_phys), parameter :: tfreeze = 273.15_kind_phys - type(physics_state) :: phys_state - integer :: num_model_times = -1 - integer, allocatable :: model_times(:) - - public :: init_data - public :: compare_data - public :: twist_array - - real(kind_phys), private, allocatable :: check_vals(:,:,:) - real(kind_phys), private :: check_temp(ncols, pver) - integer, private :: ind_liq = -1 - integer, private :: ind_ice = -1 + use ccpp_kinds, only: kind_phys + use test_host_data, only: physics_state, & + allocate_physics_state + + implicit none + public + + integer, parameter :: num_time_steps = 2 + real(kind=kind_phys), parameter :: tolerance = 1.0e-13_kind_phys + + !> \section arg_table_test_host_mod Argument Table + !! \htmlinclude arg_table_test_host_mod.html + !! + integer, parameter :: ncols = 10 + integer, parameter :: pver = 5 + integer, parameter :: pverp = pver + 1 + integer, protected :: ncnst = -1 + integer, protected :: index_qv = -1 + real(kind=kind_phys) :: dt + real(kind=kind_phys), parameter :: tfreeze = 273.15_kind_phys + type(physics_state) :: phys_state + integer :: num_model_times = -1 + integer, allocatable :: model_times(:) + + public :: init_data + public :: compare_data + public :: twist_array + + real(kind=kind_phys), private, allocatable :: check_vals(:, :, :) + real(kind=kind_phys), private :: check_temp(ncols, pver) + integer, private :: ind_liq = -1 + integer, private :: ind_ice = -1 contains - subroutine init_data(constituent_array, index_qv_use, index_liq, index_ice, index_dyn) - - ! Dummy arguments - real(kind_phys), pointer :: constituent_array(:,:,:) ! From host & suites - integer, intent(in) :: index_qv_use - integer, intent(in) :: index_liq - integer, intent(in) :: index_ice - integer, intent(in) :: index_dyn - - ! Local variables - integer :: col - integer :: lev - integer :: cind - integer :: itime - real(kind_phys) :: qmax - real(kind_phys), parameter :: inc = 0.1_kind_phys - - ! Allocate and initialize state - ! Temperature starts above freezing and decreases to -30C - ! water vapor is initialized in odd columns to different amounts - ncnst = SIZE(constituent_array, 3) - call allocate_physics_state(ncols, pver, constituent_array, phys_state) - index_qv = index_qv_use - ind_liq = index_liq - ind_ice = index_ice - allocate(check_vals(ncols, pver, ncnst)) - check_vals(:,:,:) = 0.0_kind_phys - check_vals(:,:,index_dyn) = 1.0_kind_phys - do lev = 1, pver - phys_state%temp(:, lev) = tfreeze + (10.0_kind_phys * (lev - 3)) - qmax = real(lev, kind_phys) - do col = 1, ncols - if (mod(col, 2) == 1) then - phys_state%q(col, lev, index_qv) = qmax - else - phys_state%q(col, lev, index_qv) = 0.0_kind_phys - end if - end do + subroutine init_data(constituent_array, index_qv_use, index_liq, index_ice, index_dyn) + + ! Dummy arguments + real(kind=kind_phys), pointer :: constituent_array(:, :, :) ! From host & suites + integer, intent(in) :: index_qv_use + integer, intent(in) :: index_liq + integer, intent(in) :: index_ice + integer, intent(in) :: index_dyn + + ! Local variables + integer :: col + integer :: lev + integer :: cind + integer :: itime + real(kind=kind_phys) :: qmax + real(kind=kind_phys), parameter :: inc = 0.1_kind_phys + + ! Allocate and initialize state + ! Temperature starts above freezing and decreases to -30C + ! water vapor is initialized in odd columns to different amounts + ncnst = size(constituent_array, 3) + call allocate_physics_state(ncols, pver, constituent_array, phys_state) + index_qv = index_qv_use + ind_liq = index_liq + ind_ice = index_ice + allocate(check_vals(ncols, pver, ncnst)) + check_vals(:, :, :) = 0.0_kind_phys + check_vals(:, :, index_dyn) = 1.0_kind_phys + do lev = 1, pver + phys_state%temp(:, lev) = tfreeze + (10.0_kind_phys * (lev - 3)) + qmax = real(lev, kind_phys) + do col = 1, ncols + if (mod(col, 2) == 1) then + phys_state%q(col, lev, index_qv) = qmax + else + phys_state%q(col, lev, index_qv) = 0.0_kind_phys + end if end do - check_vals(:,:,index_qv) = phys_state%q(:,:,index_qv) - check_temp(:,:) = phys_state%temp(:,:) - ! Do timestep 1 - do col = 1, ncols, 2 - check_temp(col, 1) = check_temp(col, 1) + 0.5_kind_phys - check_vals(col, 1, index_qv) = check_vals(col, 1, index_qv) - inc - check_vals(col, 1, ind_liq) = check_vals(col, 1, ind_liq) + inc + end do + check_vals(:, :, index_qv) = phys_state%q(:, :, index_qv) + check_temp(:, :) = phys_state%temp(:, :) + ! Do timestep 1 + do col = 1, ncols, 2 + check_temp(col, 1) = check_temp(col, 1) + 0.5_kind_phys + check_vals(col, 1, index_qv) = check_vals(col, 1, index_qv) - inc + check_vals(col, 1, ind_liq) = check_vals(col, 1, ind_liq) + inc + end do + do itime = 1, num_time_steps + do cind = 1, ncnst + call twist_array(check_vals(:, :, cind)) end do - do itime = 1, num_time_steps - do cind = 1, ncnst - call twist_array(check_vals(:,:,cind)) - end do + end do + + end subroutine init_data + + subroutine twist_array(array) + ! Dummy argument + real(kind=kind_phys), intent(inout) :: array(:, :) + + ! Local variables + integer :: icol, ilev ! Field coordinates + integer :: idir ! 'w' sign + integer :: levb, leve ! Starting and ending level indices + real(kind=kind_phys) :: last_val, next_val + + idir = 1 + leve = (pver * mod(ncols, 2)) + mod(ncols - 1, 2) + last_val = array(ncols, leve) + do icol = 1, ncols + levb = ((pver * (1 - idir)) + (1 + idir)) / 2 + leve = ((pver * (1 + idir)) + (1 - idir)) / 2 + do ilev = levb, leve, idir + next_val = array(icol, ilev) + array(icol, ilev) = last_val + last_val = next_val end do - - end subroutine init_data - - subroutine twist_array(array) - ! Dummy argument - real(kind_phys), intent(inout) :: array(:,:) - - ! Local variables - integer :: icol, ilev ! Field coordinates - integer :: idir ! 'w' sign - integer :: levb, leve ! Starting and ending level indices - real(kind_phys) :: last_val, next_val - - idir = 1 - leve = (pver * mod(ncols, 2)) + mod(ncols-1, 2) - last_val = array(ncols, leve) - do icol = 1, ncols - levb = ((pver * (1 - idir)) + (1 + idir)) / 2 - leve = ((pver * (1 + idir)) + (1 - idir)) / 2 - do ilev = levb, leve, idir - next_val = array(icol, ilev) - array(icol, ilev) = last_val - last_val = next_val - end do - idir = -1 * idir - end do - - end subroutine twist_array - - logical function compare_data(ncnst) - - integer, intent(in) :: ncnst - - integer :: col - integer :: lev - integer :: cind - logical :: need_header - real(kind_phys) :: check - real(kind_phys) :: denom - - compare_data = .true. - - need_header = .true. + idir = -1 * idir + end do + + end subroutine twist_array + + logical function compare_data(ncnst) + + integer, intent(in) :: ncnst + + integer :: col + integer :: lev + integer :: cind + logical :: need_header + real(kind=kind_phys) :: check + real(kind=kind_phys) :: denom + + compare_data = .true. + + need_header = .true. + do lev = 1, pver + do col = 1, ncols + check = check_temp(col, lev) + if (abs((phys_state%temp(col, lev) - check) / check) > & + 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, & + phys_state%temp(col, lev), check + compare_data = .false. + end if + end do + end do + ! Check constituents + need_header = .true. + do cind = 1, ncnst do lev = 1, pver - do col = 1, ncols - check = check_temp(col, lev) - if (abs((phys_state%temp(col, lev) - check) / check) > & - 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, & - phys_state%temp(col, lev), check - compare_data = .false. + do col = 1, ncols + check = check_vals(col, lev, cind) + if (check < tolerance) then + denom = 1.0_kind_phys + else + denom = check + end if + if (abs((phys_state%q(col, lev, cind) - check) / denom) > & + 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 - end do - end do - ! Check constituents - need_header = .true. - do cind = 1, ncnst - do lev = 1, pver - do col = 1, ncols - check = check_vals(col, lev, cind) - if (check < tolerance) then - denom = 1.0_kind_phys - else - denom = check - end if - if (abs((phys_state%q(col, lev, cind) - check) / denom) > & - 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), check - compare_data = .false. - end if - end do - end do + write(6, '(3i5,2(3x,es15.7))') col, lev, cind, & + phys_state%q(col, lev, cind), check + compare_data = .false. + end if + end do end do + end do - end function compare_data + end function compare_data end module test_host_mod diff --git a/test/capgen_test/adjust/temp_kinds.F90 b/test/capgen_test/adjust/temp_kinds.F90 index 59e813e5..3fb4cca4 100644 --- a/test/capgen_test/adjust/temp_kinds.F90 +++ b/test/capgen_test/adjust/temp_kinds.F90 @@ -3,10 +3,10 @@ module temp_kinds - implicit none - private + implicit none + private - integer, public, parameter :: temp_r8 = selected_real_kind(12) !8-byte real - integer, public, parameter :: temp_i8 = selected_int_kind (13) !8-byte integer + integer, public, parameter :: temp_r8 = selected_real_kind(12) !8-byte real + integer, public, parameter :: temp_i8 = selected_int_kind(13) !8-byte integer end module temp_kinds diff --git a/test/capgen_test/source_dir1/environ_conditions.F90 b/test/capgen_test/source_dir1/environ_conditions.F90 index 62183012..2d63366e 100644 --- a/test/capgen_test/source_dir1/environ_conditions.F90 +++ b/test/capgen_test/source_dir1/environ_conditions.F90 @@ -1,51 +1,51 @@ -MODULE environ_conditions +module environ_conditions - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: environ_conditions_init - PUBLIC :: environ_conditions_run - PUBLIC :: environ_conditions_finalize + public :: environ_conditions_init + public :: environ_conditions_run + public :: environ_conditions_finalize integer, parameter :: input_model_times = 3 integer, parameter :: input_model_values(input_model_times) = (/ 31, 37, 41 /) -CONTAINS +contains -!> \section arg_table_environ_conditions_run Argument Table -!! \htmlinclude arg_table_environ_conditions_run.html -!! + !> \section arg_table_environ_conditions_run Argument Table + !! \htmlinclude arg_table_environ_conditions_run.html + !! subroutine environ_conditions_run(psurf, errmsg, errflg) ! This routine currently does nothing -- should update values - real(kind_phys), intent(in) :: psurf(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(in) :: psurf(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 - END SUBROUTINE environ_conditions_run + end subroutine environ_conditions_run -!> \section arg_table_environ_conditions_init Argument Table -!! \htmlinclude arg_table_environ_conditions_init.html -!! - subroutine environ_conditions_init (nbox, O3, HNO3, ntimes, model_times, & - errmsg, errflg) + !> \section arg_table_environ_conditions_init Argument Table + !! \htmlinclude arg_table_environ_conditions_init.html + !! + subroutine environ_conditions_init(nbox, o3, hno3, ntimes, model_times, & + errmsg, errflg) - integer, intent(in) :: nbox - real(kind_phys), intent(out) :: O3(:) - real(kind_phys), intent(out) :: HNO3(:) - integer, intent(out) :: ntimes - integer, allocatable, intent(out) :: model_times(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg -!---------------------------------------------------------------- + integer, intent(in) :: nbox + real(kind=kind_phys), intent(out) :: o3(:) + real(kind=kind_phys), intent(out) :: hno3(:) + integer, intent(out) :: ntimes + integer, allocatable, intent(out) :: model_times(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- - integer :: i, j + integer :: i, j errmsg = '' errflg = 0 @@ -53,8 +53,8 @@ subroutine environ_conditions_init (nbox, O3, HNO3, ntimes, model_times, & ! This may be replaced with MusicBox json environmental conditions reader??? do i = 1, nbox - O3(i) = real(i, kind_phys) * 1.e-6_kind_phys - HNO3(i) = real(i, kind_phys) * 1.e-9_kind_phys + o3(i) = real(i, kind_phys) * 1.e-6_kind_phys + hno3(i) = real(i, kind_phys) * 1.e-9_kind_phys end do ntimes = input_model_times @@ -63,34 +63,34 @@ subroutine environ_conditions_init (nbox, O3, HNO3, ntimes, model_times, & end subroutine environ_conditions_init -!> \section arg_table_environ_conditions_finalize Argument Table -!! \htmlinclude arg_table_environ_conditions_finalize.html -!! - subroutine environ_conditions_finalize (ntimes, model_times, errmsg, errflg) + !> \section arg_table_environ_conditions_finalize Argument Table + !! \htmlinclude arg_table_environ_conditions_finalize.html + !! + subroutine environ_conditions_finalize(ntimes, model_times, errmsg, errflg) - integer, intent(in) :: ntimes - integer, intent(in) :: model_times(:) + integer, intent(in) :: ntimes + integer, intent(in) :: model_times(:) character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(out) :: errflg ! This routine checks the size and values of model_times if (ntimes /= input_model_times) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'ntimes mismatch, ', ntimes, ' should be ', & - input_model_times + errflg = 1 + write(errmsg, '(2(a,i0))') 'ntimes mismatch, ', ntimes, ' should be ', & + input_model_times else if (size(model_times) /= input_model_times) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'model_times size mismatch, ', & - size(model_times), ' should be ', input_model_times - else if (ANY(model_times /= input_model_values)) then - errflg = 1 - write(errmsg, *) 'model_times mismatch, ', & - model_times, ' should be ', input_model_values + errflg = 1 + write(errmsg, '(2(a,i0))') 'model_times size mismatch, ', & + size(model_times), ' should be ', input_model_times + else if (any(model_times /= input_model_values)) then + errflg = 1 + write(errmsg, *) 'model_times mismatch, ', & + model_times, ' should be ', input_model_values else - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 end if end subroutine environ_conditions_finalize -END MODULE environ_conditions +end module environ_conditions diff --git a/test/capgen_test/source_dir2/temp_set.F90 b/test/capgen_test/source_dir2/temp_set.F90 index 0a0aa92c..da52cf68 100644 --- a/test/capgen_test/source_dir2/temp_set.F90 +++ b/test/capgen_test/source_dir2/temp_set.F90 @@ -1,83 +1,84 @@ !Test 3D parameterization ! -MODULE temp_set - - USE ccpp_kinds, ONLY: kind_phys, kind_temp - - IMPLICIT NONE - PRIVATE - - PUBLIC :: temp_set_init - PUBLIC :: temp_set_timestep_initialize - PUBLIC :: temp_set_run - PUBLIC :: temp_set_finalize - -CONTAINS - -!> \section arg_table_temp_set_run Argument Table -!! \htmlinclude arg_table_temp_set_run.html -!! - SUBROUTINE temp_set_run(ncol, lev, timestep, temp_level, temp_diag, temp, ps, & - to_promote, promote_pcnst, slev_lbound, soil_levs, var_array, errmsg, errflg) -!---------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------- - - integer, intent(in) :: ncol, lev, slev_lbound - REAL(kind_phys), intent(out) :: temp(:,:) - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(in) :: ps(:) - REAL(kind_phys), INTENT(inout) :: temp_level(:, :) - real(kind_phys), intent(inout) :: temp_diag(:,:) - real(kind_phys), intent(inout) :: soil_levs(slev_lbound:) - real(kind_phys), intent(inout) :: var_array(:,:,:,:) - real(kind_temp), intent(out) :: to_promote(:, :) - real(kind_phys), intent(out) :: promote_pcnst(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg -!---------------------------------------------------------------- - integer :: ilev - - integer :: col_index - integer :: lev_index - real(kind_phys) :: internal_scalar_var +module temp_set + + use ccpp_kinds, only: kind_phys, & + kind_temp + + implicit none + private + + public :: temp_set_init + public :: temp_set_timestep_initialize + public :: temp_set_run + public :: temp_set_finalize + +contains + + !> \section arg_table_temp_set_run Argument Table + !! \htmlinclude arg_table_temp_set_run.html + !! + subroutine temp_set_run(ncol, lev, timestep, temp_level, temp_diag, temp, ps, & + to_promote, promote_pcnst, slev_lbound, soil_levs, var_array, errmsg, errflg) + !---------------------------------------------------------------- + implicit none + !---------------------------------------------------------------- + + integer, intent(in) :: ncol, lev, slev_lbound + real(kind=kind_phys), intent(out) :: temp(:, :) + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(in) :: ps(:) + real(kind=kind_phys), intent(inout) :: temp_level(:, :) + real(kind=kind_phys), intent(inout) :: temp_diag(:, :) + real(kind=kind_phys), intent(inout) :: soil_levs(slev_lbound:) + real(kind=kind_phys), intent(inout) :: var_array(:, :, :, :) + real(kind=kind_temp), intent(out) :: to_promote(:, :) + real(kind=kind_phys), intent(out) :: promote_pcnst(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + integer :: ilev + + integer :: col_index + integer :: lev_index + real(kind=kind_phys) :: internal_scalar_var errmsg = '' errflg = 0 ilev = size(temp_level, 2) if (ilev /= (lev + 1)) then - errflg = 1 - errmsg = 'Invalid value for ilev, must be lev+1' - return + errflg = 1 + errmsg = 'Invalid value for ilev, must be lev+1' + return end if do col_index = 1, ncol - do lev_index = 1, lev - temp(col_index, lev_index) = (temp_level(col_index, lev_index) & - + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys - end do + do lev_index = 1, lev + temp(col_index, lev_index) = (temp_level(col_index, lev_index) & + + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys + end do end do - var_array(:,:,:,:) = 1._kind_phys + var_array(:, :, :, :) = 1._kind_phys ! internal_scalar_var = soil_levs(slev_lbound) internal_scalar_var = soil_levs(0) - END SUBROUTINE temp_set_run + end subroutine temp_set_run -!> \section arg_table_temp_set_init Argument Table -!! \htmlinclude arg_table_temp_set_init.html -!! + !> \section arg_table_temp_set_init Argument Table + !! \htmlinclude arg_table_temp_set_init.html + !! subroutine temp_set_init(temp_inc_in, fudge, temp_inc_set, errmsg, errflg) - real(kind_phys), intent(in) :: temp_inc_in - real(kind_phys), intent(in) :: fudge - real(kind_phys), intent(out) :: temp_inc_set - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(in) :: temp_inc_in + real(kind=kind_phys), intent(in) :: fudge + real(kind=kind_phys), intent(out) :: temp_inc_set + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg temp_inc_set = temp_inc_in @@ -86,17 +87,17 @@ subroutine temp_set_init(temp_inc_in, fudge, temp_inc_set, errmsg, errflg) end subroutine temp_set_init -!> \section arg_table_temp_set_timestep_initialize Argument Table -!! \htmlinclude arg_table_temp_set_timestep_initialize.html -!! - subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & - errmsg, errflg) + !> \section arg_table_temp_set_timestep_initialize Argument Table + !! \htmlinclude arg_table_temp_set_timestep_initialize.html + !! + subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & + errmsg, errflg) - integer, intent(in) :: ncol - real(kind_phys), intent(in) :: temp_inc - real(kind_phys), intent(inout) :: temp_level(:,:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + real(kind=kind_phys), intent(in) :: temp_inc + real(kind=kind_phys), intent(inout) :: temp_level(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 @@ -105,13 +106,13 @@ subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & end subroutine temp_set_timestep_initialize -!> \section arg_table_temp_set_finalize Argument Table -!! \htmlinclude arg_table_temp_set_finalize.html -!! + !> \section arg_table_temp_set_finalize Argument Table + !! \htmlinclude arg_table_temp_set_finalize.html + !! subroutine temp_set_finalize(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 @@ -120,4 +121,4 @@ subroutine temp_set_finalize(errmsg, errflg) end subroutine temp_set_finalize -END MODULE temp_set +end module temp_set diff --git a/test/capgen_test/temp_adjust.F90 b/test/capgen_test/temp_adjust.F90 index 35c951e0..e645adfc 100644 --- a/test/capgen_test/temp_adjust.F90 +++ b/test/capgen_test/temp_adjust.F90 @@ -3,7 +3,8 @@ module temp_adjust - use ccpp_kinds, only: kind_phys, kind_temp + use ccpp_kinds, only: kind_phys, & + kind_temp implicit none private @@ -67,7 +68,7 @@ subroutine temp_adjust_run(foo, timestep, interstitial_var, temp_prev, temp_laye return end if - if (.not.module_level_config) then + if ( .not. module_level_config) then ! do nothing return end if diff --git a/test/capgen_test/test_capgen_host_integration.F90 b/test/capgen_test/test_capgen_host_integration.F90 index eb11f2f8..4b1bd1d4 100644 --- a/test/capgen_test/test_capgen_host_integration.F90 +++ b/test/capgen_test/test_capgen_host_integration.F90 @@ -1,5 +1,8 @@ program test - use test_prog, only: test_host, suite_info, cm, cs + use test_prog, only: test_host, & + suite_info, & + cm, & + cs implicit none diff --git a/test/capgen_test/test_host.F90 b/test/capgen_test/test_host.F90 index 6e39c787..c79d91ff 100644 --- a/test/capgen_test/test_host.F90 +++ b/test/capgen_test/test_host.F90 @@ -106,7 +106,8 @@ subroutine test_host(retval, test_suites) #ifdef _OPENMP use omp_lib #endif - use test_host_mod, only: ncols, num_time_steps + 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 @@ -114,7 +115,9 @@ subroutine test_host(retval, test_suites) 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_host_mod, only: init_data, & + compare_data, & + check_model_times use test_utils, only: check_list type(suite_info), intent(in) :: test_suites(:) @@ -156,7 +159,7 @@ subroutine test_host(retval, test_suites) end do end if !!! Return here if any check failed - if (.not.retval) then + if ( .not. retval) then return end if @@ -284,7 +287,7 @@ subroutine test_host(retval, test_suites) if (errflg == 0) then ! Run finished without error, check answers - if (.not.check_model_times()) then + if ( .not. check_model_times()) then write(6, *) 'Model times error!' errflg = -1 else if (compare_data()) then diff --git a/test/capgen_test/test_host_mod.F90 b/test/capgen_test/test_host_mod.F90 index aecc5f15..b479d9a5 100644 --- a/test/capgen_test/test_host_mod.F90 +++ b/test/capgen_test/test_host_mod.F90 @@ -1,7 +1,8 @@ module test_host_mod use ccpp_kinds, only: kind_phys - use test_host_data, only: physics_state, allocate_physics_state + use test_host_data, only: physics_state, & + allocate_physics_state implicit none public @@ -79,7 +80,7 @@ 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 + 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 diff --git a/test/ddthost_test/environ_conditions.F90 b/test/ddthost_test/environ_conditions.F90 index b6816117..2d63366e 100644 --- a/test/ddthost_test/environ_conditions.F90 +++ b/test/ddthost_test/environ_conditions.F90 @@ -14,38 +14,38 @@ module environ_conditions contains -!> \section arg_table_environ_conditions_run Argument Table -!! \htmlinclude arg_table_environ_conditions_run.html -!! + !> \section arg_table_environ_conditions_run Argument Table + !! \htmlinclude arg_table_environ_conditions_run.html + !! subroutine environ_conditions_run(psurf, errmsg, errflg) ! This routine currently does nothing -- should update values - real(kind_phys), intent(in) :: psurf(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(in) :: psurf(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 end subroutine environ_conditions_run -!> \section arg_table_environ_conditions_init Argument Table -!! \htmlinclude arg_table_environ_conditions_init.html -!! - subroutine environ_conditions_init (nbox, O3, HNO3, ntimes, model_times, & - errmsg, errflg) - - integer, intent(in) :: nbox - real(kind_phys), intent(out) :: O3(:) - real(kind_phys), intent(out) :: HNO3(:) - integer, intent(out) :: ntimes - integer, allocatable, intent(out) :: model_times(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg -!---------------------------------------------------------------- + !> \section arg_table_environ_conditions_init Argument Table + !! \htmlinclude arg_table_environ_conditions_init.html + !! + subroutine environ_conditions_init(nbox, o3, hno3, ntimes, model_times, & + errmsg, errflg) + + integer, intent(in) :: nbox + real(kind=kind_phys), intent(out) :: o3(:) + real(kind=kind_phys), intent(out) :: hno3(:) + integer, intent(out) :: ntimes + integer, allocatable, intent(out) :: model_times(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- - integer :: i, j + integer :: i, j errmsg = '' errflg = 0 @@ -53,8 +53,8 @@ subroutine environ_conditions_init (nbox, O3, HNO3, ntimes, model_times, & ! This may be replaced with MusicBox json environmental conditions reader??? do i = 1, nbox - O3(i) = real(i, kind_phys) * 1.e-6_kind_phys - HNO3(i) = real(i, kind_phys) * 1.e-9_kind_phys + o3(i) = real(i, kind_phys) * 1.e-6_kind_phys + hno3(i) = real(i, kind_phys) * 1.e-9_kind_phys end do ntimes = input_model_times @@ -63,32 +63,32 @@ subroutine environ_conditions_init (nbox, O3, HNO3, ntimes, model_times, & end subroutine environ_conditions_init -!> \section arg_table_environ_conditions_finalize Argument Table -!! \htmlinclude arg_table_environ_conditions_finalize.html -!! - subroutine environ_conditions_finalize (ntimes, model_times, errmsg, errflg) + !> \section arg_table_environ_conditions_finalize Argument Table + !! \htmlinclude arg_table_environ_conditions_finalize.html + !! + subroutine environ_conditions_finalize(ntimes, model_times, errmsg, errflg) - integer, intent(in) :: ntimes - integer, intent(in) :: model_times(:) + integer, intent(in) :: ntimes + integer, intent(in) :: model_times(:) character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(out) :: errflg ! This routine checks the size and values of model_times if (ntimes /= input_model_times) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'ntimes mismatch, ', ntimes, ' should be ', & - input_model_times + errflg = 1 + write(errmsg, '(2(a,i0))') 'ntimes mismatch, ', ntimes, ' should be ', & + input_model_times else if (size(model_times) /= input_model_times) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'model_times size mismatch, ', & - size(model_times), ' should be ', input_model_times + errflg = 1 + write(errmsg, '(2(a,i0))') 'model_times size mismatch, ', & + size(model_times), ' should be ', input_model_times else if (any(model_times /= input_model_values)) then - errflg = 1 - write(errmsg, *) 'model_times mismatch, ', & - model_times, ' should be ', input_model_values + errflg = 1 + write(errmsg, *) 'model_times mismatch, ', & + model_times, ' should be ', input_model_values else - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 end if end subroutine environ_conditions_finalize diff --git a/test/ddthost_test/host_ccpp_ddt.F90 b/test/ddthost_test/host_ccpp_ddt.F90 index 157f795f..b60c81af 100644 --- a/test/ddthost_test/host_ccpp_ddt.F90 +++ b/test/ddthost_test/host_ccpp_ddt.F90 @@ -1,16 +1,16 @@ module host_ccpp_ddt - implicit none - private + implicit none + private - !> \section arg_table_ccpp_info_t Argument Table - !! \htmlinclude arg_table_ccpp_info_t.html - !! - type, public :: ccpp_info_t - integer :: col_start ! horizontal_loop_begin - integer :: col_end ! horizontal_loop_end - character(len=512) :: errmsg ! ccpp_error_message - integer :: errflg ! ccpp_error_code - end type ccpp_info_t + !> \section arg_table_ccpp_info_t Argument Table + !! \htmlinclude arg_table_ccpp_info_t.html + !! + type, public :: ccpp_info_t + integer :: col_start ! horizontal_loop_begin + integer :: col_end ! horizontal_loop_end + character(len=512) :: errmsg ! ccpp_error_message + integer :: errflg ! ccpp_error_code + end type ccpp_info_t end module host_ccpp_ddt diff --git a/test/ddthost_test/make_ddt.F90 b/test/ddthost_test/make_ddt.F90 index c9d0832b..a0de4177 100644 --- a/test/ddthost_test/make_ddt.F90 +++ b/test/ddthost_test/make_ddt.F90 @@ -3,132 +3,131 @@ module make_ddt - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: make_ddt_init - public :: make_ddt_run - public :: make_ddt_timestep_final - public :: vmr_type - - !> \section arg_table_vmr_type Argument Table - !! \htmlinclude arg_table_vmr_type.html - !! - type vmr_type - integer :: nvmr - real(kind_phys), allocatable :: vmr_array(:,:) - end type vmr_type + public :: make_ddt_init + public :: make_ddt_run + public :: make_ddt_timestep_final + public :: vmr_type + !> \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(:, :) + 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 predecessor 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, ccpp_info, vmr, errmsg, errflg) - use host_ccpp_ddt, only: ccpp_info_t - - ! Dummy arguments - integer, intent(in) :: nbox - type(ccpp_info_t), intent(in) :: ccpp_info - 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 + !> \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 predecessor 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, ccpp_info, vmr, errmsg, errflg) + use host_ccpp_ddt, only: ccpp_info_t + + ! Dummy arguments + integer, intent(in) :: nbox + type(ccpp_info_t), intent(in) :: ccpp_info + 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/ddthost_test/setup_coeffs.F90 b/test/ddthost_test/setup_coeffs.F90 index 27918695..09c7fcc1 100644 --- a/test/ddthost_test/setup_coeffs.F90 +++ b/test/ddthost_test/setup_coeffs.F90 @@ -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/ddthost_test/temp_set.F90 b/test/ddthost_test/temp_set.F90 index 27233e92..ce1c32ed 100644 --- a/test/ddthost_test/temp_set.F90 +++ b/test/ddthost_test/temp_set.F90 @@ -15,59 +15,59 @@ module temp_set contains -!> \section arg_table_temp_set_run Argument Table -!! \htmlinclude arg_table_temp_set_run.html -!! - subroutine temp_set_run(ncol, lev, timestep, temp_level, temp, ps, & - to_promote, promote_pcnst, errmsg, errflg) -!---------------------------------------------------------------- - implicit none -!---------------------------------------------------------------- - - integer, intent(in) :: ncol, lev - real(kind_phys), intent(out) :: temp(:,:) - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(in) :: ps(:) - real(kind_phys), intent(inout) :: temp_level(:, :) - real(kind_phys), intent(out) :: to_promote(:, :) - real(kind_phys), intent(out) :: promote_pcnst(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg -!---------------------------------------------------------------- - integer :: ilev - - integer :: col_index - integer :: lev_index + !> \section arg_table_temp_set_run Argument Table + !! \htmlinclude arg_table_temp_set_run.html + !! + subroutine temp_set_run(ncol, lev, timestep, temp_level, temp, ps, & + to_promote, promote_pcnst, errmsg, errflg) + !---------------------------------------------------------------- + implicit none + !---------------------------------------------------------------- + + integer, intent(in) :: ncol, lev + real(kind=kind_phys), intent(out) :: temp(:, :) + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(in) :: ps(:) + real(kind=kind_phys), intent(inout) :: temp_level(:, :) + real(kind=kind_phys), intent(out) :: to_promote(:, :) + real(kind=kind_phys), intent(out) :: promote_pcnst(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + integer :: ilev + + integer :: col_index + integer :: lev_index errmsg = '' errflg = 0 ilev = size(temp_level, 2) if (ilev /= (lev + 1)) then - errflg = 1 - errmsg = 'Invalid value for ilev, must be lev+1' - return + errflg = 1 + errmsg = 'Invalid value for ilev, must be lev+1' + return end if do col_index = 1, ncol - do lev_index = 1, lev - temp(col_index, lev_index) = (temp_level(col_index, lev_index) & - + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys - end do + do lev_index = 1, lev + temp(col_index, lev_index) = (temp_level(col_index, lev_index) & + + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys + end do end do end subroutine temp_set_run -!> \section arg_table_temp_set_init Argument Table -!! \htmlinclude arg_table_temp_set_init.html -!! + !> \section arg_table_temp_set_init Argument Table + !! \htmlinclude arg_table_temp_set_init.html + !! subroutine temp_set_init(temp_inc_in, fudge, temp_inc_set, errmsg, errflg) - real(kind_phys), intent(in) :: temp_inc_in - real(kind_phys), intent(in) :: fudge - real(kind_phys), intent(out) :: temp_inc_set - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(in) :: temp_inc_in + real(kind=kind_phys), intent(in) :: fudge + real(kind=kind_phys), intent(out) :: temp_inc_set + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg temp_inc_set = temp_inc_in @@ -76,17 +76,17 @@ subroutine temp_set_init(temp_inc_in, fudge, temp_inc_set, errmsg, errflg) end subroutine temp_set_init -!> \section arg_table_temp_set_timestep_initialize Argument Table -!! \htmlinclude arg_table_temp_set_timestep_initialize.html -!! - subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & - errmsg, errflg) + !> \section arg_table_temp_set_timestep_initialize Argument Table + !! \htmlinclude arg_table_temp_set_timestep_initialize.html + !! + subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & + errmsg, errflg) - integer, intent(in) :: ncol - real(kind_phys), intent(in) :: temp_inc - real(kind_phys), intent(inout) :: temp_level(:,:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + real(kind=kind_phys), intent(in) :: temp_inc + real(kind=kind_phys), intent(inout) :: temp_level(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 @@ -95,13 +95,13 @@ subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & end subroutine temp_set_timestep_initialize -!> \section arg_table_temp_set_finalize Argument Table -!! \htmlinclude arg_table_temp_set_finalize.html -!! + !> \section arg_table_temp_set_finalize Argument Table + !! \htmlinclude arg_table_temp_set_finalize.html + !! subroutine temp_set_finalize(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 diff --git a/test/ddthost_test/test_ddt_host_integration.F90 b/test/ddthost_test/test_ddt_host_integration.F90 index 23a0e53c..3f383f0e 100644 --- a/test/ddthost_test/test_ddt_host_integration.F90 +++ b/test/ddthost_test/test_ddt_host_integration.F90 @@ -1,79 +1,82 @@ 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(7) = (/ & - 'potential_temperature ', & - 'potential_temperature_at_interface ', & - 'coefficients_for_interpolation ', & - 'surface_air_pressure ', & - 'water_vapor_specific_humidity ', & - 'potential_temperature_increment ', & - 'time_step_for_physics ' /) - character(len=cm), target :: test_outvars1(7) = (/ & - 'potential_temperature ', & - 'potential_temperature_at_interface ', & - 'coefficients_for_interpolation ', & - 'surface_air_pressure ', & - 'water_vapor_specific_humidity ', & - 'ccpp_error_code ', & - 'ccpp_error_message ' /) - character(len=cm), target :: test_reqvars1(9) = (/ & - 'potential_temperature ', & - 'potential_temperature_at_interface ', & - 'coefficients_for_interpolation ', & - 'surface_air_pressure ', & - 'water_vapor_specific_humidity ', & - 'potential_temperature_increment ', & - 'time_step_for_physics ', & - 'ccpp_error_code ', & - 'ccpp_error_message ' /) + character(len=cs), target :: test_parts1(2) = (/ 'physics1 ', & + 'physics2 ' /) + character(len=cs), target :: test_parts2(1) = (/ 'data_prep ' /) + character(len=cm), target :: test_invars1(7) = (/ & + 'potential_temperature ', & + 'potential_temperature_at_interface ', & + 'coefficients_for_interpolation ', & + 'surface_air_pressure ', & + 'water_vapor_specific_humidity ', & + 'potential_temperature_increment ', & + 'time_step_for_physics ' /) + character(len=cm), target :: test_outvars1(7) = (/ & + 'potential_temperature ', & + 'potential_temperature_at_interface ', & + 'coefficients_for_interpolation ', & + 'surface_air_pressure ', & + 'water_vapor_specific_humidity ', & + 'ccpp_error_code ', & + 'ccpp_error_message ' /) + character(len=cm), target :: test_reqvars1(9) = (/ & + 'potential_temperature ', & + 'potential_temperature_at_interface ', & + 'coefficients_for_interpolation ', & + 'surface_air_pressure ', & + 'water_vapor_specific_humidity ', & + 'potential_temperature_increment ', & + 'time_step_for_physics ', & + 'ccpp_error_code ', & + 'ccpp_error_message ' /) - character(len=cm), target :: test_invars2(4) = (/ & - 'model_times ', & - 'number_of_model_times ', & - 'surface_air_pressure ', & - 'host_standard_ccpp_type ' /) + character(len=cm), target :: test_invars2(4) = (/ & + 'model_times ', & + 'number_of_model_times ', & + 'surface_air_pressure ', & + 'host_standard_ccpp_type ' /) - 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(6) = (/ & - 'model_times ', & - 'number_of_model_times ', & - 'surface_air_pressure ', & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'host_standard_ccpp_type ' /) - type(suite_info) :: test_suites(2) - logical :: run_okay + character(len=cm), target :: test_reqvars2(6) = (/ & + 'model_times ', & + 'number_of_model_times ', & + 'surface_air_pressure ', & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'host_standard_ccpp_type ' /) + 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/ddthost_test/test_host.F90 b/test/ddthost_test/test_host.F90 index c8213e20..097567ac 100644 --- a/test/ddthost_test/test_host.F90 +++ b/test/ddthost_test/test_host.F90 @@ -1,271 +1,273 @@ 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 - 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) + use host_ccpp_ddt, only: ccpp_info_t + use test_host_mod, only: ncols, & + num_time_steps + 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 host_ccpp_ddt, only: ccpp_info_t - use test_host_mod, only: ncols, num_time_steps - 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 + integer :: index, sind + integer :: time_step + integer :: num_suites + character(len=128), allocatable :: suite_names(:) + type(ccpp_info_t) :: ccpp_info - logical :: check - integer :: col_start - integer :: index, sind - integer :: time_step - integer :: num_suites - character(len=128), allocatable :: suite_names(:) - type(ccpp_info_t) :: ccpp_info + ! 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 setup the run + do sind = 1, num_suites + call test_host_ccpp_physics_initialize(test_suites(sind)%suite_name, & + ccpp_info) + if (ccpp_info%errflg /= 0) then + write(6, '(4a)') 'ERROR in initialize of ', & + trim(test_suites(sind)%suite_name), ': ', trim(ccpp_info%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 (ccpp_info%errflg /= 0) then + exit + end if + if (ccpp_info%errflg == 0) then + call test_host_ccpp_physics_timestep_initial( & + test_suites(sind)%suite_name, ccpp_info) + end if + if (ccpp_info%errflg /= 0) then + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(ccpp_info%errmsg) + exit + end if + if (ccpp_info%errflg /= 0) then + exit + 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, & - ccpp_info) + do col_start = 1, ncols, 5 + if (ccpp_info%errflg /= 0) then + exit + end if + ccpp_info%col_start = col_start + ccpp_info%col_end = min(col_start + 4, ncols) + + do sind = 1, num_suites if (ccpp_info%errflg /= 0) then - write(6, '(4a)') 'ERROR in initialize of ', & - trim(test_suites(sind)%suite_name), ': ', trim(ccpp_info%errmsg) + exit end if - end do - ! Loop over time steps - do time_step = 1, num_time_steps - ! Initialize the timestep - do sind = 1, num_suites - if (ccpp_info%errflg /= 0) then - exit - end if - if (ccpp_info%errflg == 0) then - call test_host_ccpp_physics_timestep_initial( & - test_suites(sind)%suite_name, ccpp_info) - end if - if (ccpp_info%errflg /= 0) then - write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(ccpp_info%errmsg) - exit - end if - if (ccpp_info%errflg /= 0) then - exit - end if + do index = 1, size(test_suites(sind)%suite_parts) + if (ccpp_info%errflg /= 0) then + exit + end if + if (ccpp_info%errflg == 0) then + call test_host_ccpp_physics_run( & + test_suites(sind)%suite_name, & + test_suites(sind)%suite_parts(index), & + ccpp_info) + end if + if (ccpp_info%errflg /= 0) then + write(6, '(5a)') trim(test_suites(sind)%suite_name), & + '/', trim(test_suites(sind)%suite_parts(index)), & + ': ', trim(ccpp_info%errmsg) + exit + end if end do + end do + end do - do col_start = 1, ncols, 5 - if (ccpp_info%errflg /= 0) then - exit - end if - ccpp_info%col_start = col_start - ccpp_info%col_end = MIN(col_start + 4, ncols) + do sind = 1, num_suites + if (ccpp_info%errflg /= 0) then + exit + end if + if (ccpp_info%errflg == 0) then + call test_host_ccpp_physics_timestep_final( & + test_suites(sind)%suite_name, ccpp_info) + end if + if (ccpp_info%errflg /= 0) then + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(ccpp_info%errmsg) + exit + end if + end do + end do ! End time step loop - do sind = 1, num_suites - if (ccpp_info%errflg /= 0) then - exit - end if - do index = 1, size(test_suites(sind)%suite_parts) - if (ccpp_info%errflg /= 0) then - exit - end if - if (ccpp_info%errflg == 0) then - call test_host_ccpp_physics_run( & - test_suites(sind)%suite_name, & - test_suites(sind)%suite_parts(index), & - ccpp_info) - end if - if (ccpp_info%errflg /= 0) then - write(6, '(5a)') trim(test_suites(sind)%suite_name), & - '/', trim(test_suites(sind)%suite_parts(index)), & - ': ', trim(ccpp_info%errmsg) - exit - end if - end do - end do - end do + do sind = 1, num_suites + if (ccpp_info%errflg /= 0) then + exit + end if + if (ccpp_info%errflg == 0) then + call test_host_ccpp_physics_finalize( & + test_suites(sind)%suite_name, ccpp_info) + end if + if (ccpp_info%errflg /= 0) then + write(6, '(3a)') test_suites(sind)%suite_parts(index), ': ', & + trim(ccpp_info%errmsg) + write(6, '(2a)') 'An error occurred in ccpp_timestep_final, ', & + 'Exiting...' + exit + end if + end do - do sind = 1, num_suites - if (ccpp_info%errflg /= 0) then - exit - end if - if (ccpp_info%errflg == 0) then - call test_host_ccpp_physics_timestep_final( & - test_suites(sind)%suite_name, ccpp_info) - end if - if (ccpp_info%errflg /= 0) then - write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(ccpp_info%errmsg) - exit - end if - end do - end do ! End time step loop - - do sind = 1, num_suites - if (ccpp_info%errflg /= 0) then - exit - end if - if (ccpp_info%errflg == 0) then - call test_host_ccpp_physics_finalize( & - test_suites(sind)%suite_name,ccpp_info) - end if - if (ccpp_info%errflg /= 0) then - write(6, '(3a)') test_suites(sind)%suite_parts(index), ': ', & - trim(ccpp_info%errmsg) - write(6,'(2a)') 'An error occurred in ccpp_timestep_final, ', & - 'Exiting...' - exit - end if - end do - - if (ccpp_info%errflg == 0) then - ! Run finished without error, check answers - if (.not. check_model_times()) then - write(6, *) 'Model times error!' - ccpp_info%errflg = -1 - else if (compare_data()) then - write(6, *) 'Answers are correct!' - ccpp_info%errflg = 0 - else - write(6, *) 'Answers are not correct!' - ccpp_info%errflg = -1 - end if - end if + if (ccpp_info%errflg == 0) then + ! Run finished without error, check answers + if ( .not. check_model_times()) then + write(6, *) 'Model times error!' + ccpp_info%errflg = -1 + else if (compare_data()) then + write(6, *) 'Answers are correct!' + ccpp_info%errflg = 0 + else + write(6, *) 'Answers are not correct!' + ccpp_info%errflg = -1 + end if + end if - retval = ccpp_info%errflg == 0 + retval = ccpp_info%errflg == 0 - end subroutine test_host + end subroutine test_host - end module test_prog +end module test_prog diff --git a/test/ddthost_test/test_host_data.F90 b/test/ddthost_test/test_host_data.F90 index 7a651fca..88812719 100644 --- a/test/ddthost_test/test_host_data.F90 +++ b/test/ddthost_test/test_host_data.F90 @@ -5,15 +5,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 - 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 + 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 allocate_physics_state @@ -21,29 +21,29 @@ module test_host_data contains subroutine allocate_physics_state(cols, levels, constituents, state) - integer, intent(in) :: cols - integer, intent(in) :: levels - integer, intent(in) :: constituents + integer, intent(in) :: cols + integer, intent(in) :: levels + integer, intent(in) :: constituents 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)) diff --git a/test/ddthost_test/test_host_mod.F90 b/test/ddthost_test/test_host_mod.F90 index 43be333a..1387a0c4 100644 --- a/test/ddthost_test/test_host_mod.F90 +++ b/test/ddthost_test/test_host_mod.F90 @@ -1,39 +1,40 @@ 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 :: DiagDimStart = 2 - integer, parameter :: index_qv = 1 - real(kind_phys), allocatable :: temp_midpoints(:,:) - real(kind_phys) :: temp_interfaces(ncols, pverP) - real(kind_phys) :: coeffs(ncols) - 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 :: diagdimstart = 2 + integer, parameter :: index_qv = 1 + real(kind=kind_phys), allocatable :: temp_midpoints(:, :) + real(kind=kind_phys) :: temp_interfaces(ncols, pverp) + real(kind=kind_phys) :: coeffs(ncols) + 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 @@ -47,22 +48,22 @@ 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 + 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, 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 @@ -71,68 +72,68 @@ 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 /) compare_data = .true. 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) + 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) + 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 end function compare_data diff --git a/test/hash_table_tests/test_hash.F90 b/test/hash_table_tests/test_hash.F90 index 35536cdd..56686ce4 100644 --- a/test/hash_table_tests/test_hash.F90 +++ b/test/hash_table_tests/test_hash.F90 @@ -1,215 +1,218 @@ module test_hash_utils - use ccpp_hashable, only: ccpp_hashable_char_t - - implicit none - private - - public :: test_table - - integer, parameter, public :: max_terrs = 16 - - type, public :: hash_object_t - type(ccpp_hashable_char_t), pointer :: item => NULL() - end type hash_object_t - - private add_error - -CONTAINS - - subroutine add_error(msg, num_errs, errors) - ! Dummy arguments - character(len=*), intent(in) :: msg - integer, intent(inout) :: num_errs - character(len=*), intent(inout) :: errors(:) - - if (num_errs < max_terrs) then - num_errs = num_errs + 1 - write(errors(num_errs), *) trim(msg) + use ccpp_hashable, only: ccpp_hashable_char_t + + implicit none + private + + public :: test_table + + integer, parameter, public :: max_terrs = 16 + + type, public :: hash_object_t + type(ccpp_hashable_char_t), pointer :: item => null() + end type hash_object_t + + private add_error + +contains + + subroutine add_error(msg, num_errs, errors) + ! Dummy arguments + character(len=*), intent(in) :: msg + integer, intent(inout) :: num_errs + character(len=*), intent(inout) :: errors(:) + + if (num_errs < max_terrs) then + num_errs = num_errs + 1 + write(errors(num_errs), *) trim(msg) + end if + + end subroutine add_error + + subroutine test_table(hash_table, table_size, num_tests, num_errs, errors) + use ccpp_hash_table, only: ccpp_hash_table_t, & + ccpp_hash_iterator_t + use ccpp_hashable, only: ccpp_hashable_t, & + new_hashable_char + + ! Dummy arguments + type(ccpp_hash_table_t), target, intent(inout) :: hash_table + integer, intent(in) :: table_size + integer, intent(out) :: num_tests + integer, intent(out) :: num_errs + character(len=*), intent(inout) :: errors(:) + ! Local variables + integer, parameter :: num_test_entries = 4 + integer, parameter :: key_len = 10 + character(len=key_len) :: hash_names(num_test_entries) = (/ & + 'foo ', 'bar ', 'foobar ', 'big daddy ' /) + logical :: hash_found(num_test_entries) + + type(hash_object_t) :: hash_chars(num_test_entries) + class(ccpp_hashable_t), pointer :: test_ptr => null() + type(ccpp_hash_iterator_t) :: hash_iter + character(len=key_len) :: test_key + character(len=len(errors(1))) :: errmsg + integer :: index + + write(6, '(a,i0)') "Testing hash table, size = ", table_size + num_tests = 0 + num_errs = 0 + ! Make sure hash table is *not* initialized + if (hash_table%is_initialized()) then + call add_error("Error: hash table initialized too early", & + num_errs, errors) + end if + num_tests = num_tests + 1 + ! Initialize hash table + call hash_table%initialize(table_size) + ! Make sure hash table is *is* initialized + if ( .not. hash_table%is_initialized()) then + call add_error("Error: hash table *not* initialized", num_errs, errors) + end if + num_tests = num_tests + 1 + do index = 1, num_test_entries + call new_hashable_char(hash_names(index), hash_chars(index)%item) + call hash_table%add_hash_key(hash_chars(index)%item, & + errmsg=errors(num_errs + 1)) + if (len_trim(errors(num_errs + 1)) > 0) then + num_errs = num_errs + 1 end if - - end subroutine add_error - - subroutine test_table(hash_table, table_size, num_tests, num_errs, errors) - use ccpp_hash_table, only: ccpp_hash_table_t, ccpp_hash_iterator_t - use ccpp_hashable, only: ccpp_hashable_t, new_hashable_char - - ! Dummy arguments - type(ccpp_hash_table_t), target, intent(inout) :: hash_table - integer, intent(in) :: table_size - integer, intent(out) :: num_tests - integer, intent(out) :: num_errs - character(len=*), intent(inout) :: errors(:) - ! Local variables - integer, parameter :: num_test_entries = 4 - integer, parameter :: key_len = 10 - character(len=key_len) :: hash_names(num_test_entries) = (/ & - 'foo ', 'bar ', 'foobar ', 'big daddy ' /) - logical :: hash_found(num_test_entries) - - type(hash_object_t) :: hash_chars(num_test_entries) - class(ccpp_hashable_t), pointer :: test_ptr => NULL() - type(ccpp_hash_iterator_t) :: hash_iter - character(len=key_len) :: test_key - character(len=len(errors(1))) :: errmsg - integer :: index - - write(6, '(a,i0)') "Testing hash table, size = ", table_size - num_tests = 0 - num_errs = 0 - ! Make sure hash table is *not* initialized - if (hash_table%is_initialized()) then - call add_error("Error: hash table initialized too early", & - num_errs, errors) + if (num_errs > max_terrs) then + exit end if + end do + + if (num_errs == 0) then + ! We have populated the table, let's do some tests + ! First, make sure we can find existing entries + do index = 1, num_test_entries + test_ptr => hash_table%table_value(hash_names(index), & + errmsg=errors(num_errs + 1)) + if (len_trim(errors(num_errs + 1)) > 0) then + num_errs = num_errs + 1 + else if (trim(test_ptr%key()) /= trim(hash_names(index))) then + num_errs = num_errs + 1 + write(errmsg, *) "ERROR: Found '", trim(test_ptr%key()), & + "', expected '", trim(hash_names(index)), "'" + call add_error(trim(errmsg), num_errs, errors) + end if + if (num_errs > max_terrs) then + exit + end if + end do num_tests = num_tests + 1 - ! Initialize hash table - call hash_table%initialize(table_size) - ! Make sure hash table is *is* initialized - if (.not. hash_table%is_initialized()) then - call add_error("Error: hash table *not* initialized", num_errs, errors) + ! Next, make sure we do not find a non-existent entry + test_ptr => hash_table%table_value(trim(hash_names(1)) // '_oops', & + errmsg=errors(num_errs + 1)) + if (len_trim(errors(num_errs + 1)) == 0) then + write(errmsg, *) "ERROR: Found an entry for '", & + trim(hash_names(1)) // '_oops', "'" + call add_error(trim(errmsg), num_errs, errors) end if num_tests = num_tests + 1 - do index = 1, num_test_entries - call new_hashable_char(hash_names(index), hash_chars(index)%item) - call hash_table%add_hash_key(hash_chars(index)%item, & - errmsg=errors(num_errs + 1)) - if (len_trim(errors(num_errs + 1)) > 0) then - num_errs = num_errs + 1 - end if - if (num_errs > max_terrs) then - exit - end if - end do - - if (num_errs == 0) then - ! We have populated the table, let's do some tests - ! First, make sure we can find existing entries - do index = 1, num_test_entries - test_ptr => hash_table%table_value(hash_names(index), & - errmsg=errors(num_errs + 1)) - if (len_trim(errors(num_errs + 1)) > 0) then - num_errs = num_errs + 1 - else if (trim(test_ptr%key()) /= trim(hash_names(index))) then - num_errs = num_errs + 1 - write(errmsg, *) "ERROR: Found '", trim(test_ptr%key()), & - "', expected '", trim(hash_names(index)), "'" - call add_error(trim(errmsg), num_errs, errors) - end if - if (num_errs > max_terrs) then - exit - end if - end do - num_tests = num_tests + 1 - ! Next, make sure we do not find a non-existent entry - test_ptr => hash_table%table_value(trim(hash_names(1))//'_oops', & - errmsg=errors(num_errs + 1)) - if (len_trim(errors(num_errs + 1)) == 0) then - write(errmsg, *) "ERROR: Found an entry for '", & - trim(hash_names(1))//'_oops', "'" - call add_error(trim(errmsg), num_errs, errors) - end if - num_tests = num_tests + 1 - ! Make sure we get an error if we try to add a duplicate key - call hash_table%add_hash_key(hash_chars(2)%item, & - errmsg=errors(num_errs + 1)) - if (len_trim(errors(num_errs + 1)) == 0) then - num_errs = num_errs + 1 - write(errors(num_errs), *) & - "ERROR: Allowed duplicate entry for '", & - hash_chars(2)%item%key(), "'" - end if - num_tests = num_tests + 1 - ! Check that the total number of table entries is correct - if (hash_table%num_values() /= num_test_entries) then - write(errmsg, '(2(a,i0))') "ERROR: Wrong table value count, ", & - hash_table%num_values(), ', should be ', num_test_entries - call add_error(errmsg, num_errs, errors) - end if - num_tests = num_tests + 1 - ! Test iteration through hash table - hash_found(:) = .false. - call hash_iter%initialize(hash_table) - num_tests = num_tests + 1 - do - if (hash_iter%valid()) then - test_key = hash_iter%key() - index = 1 - do - if (trim(test_key) == trim(hash_names(index))) then - hash_found(index) = .true. - exit - else if (index >= num_test_entries) then - write(errmsg, '(3a)') & - "ERROR: Unexpected table entry, '", & - trim(test_key), "'" - call add_error(errmsg, num_errs, errors) - end if - index = index + 1 - end do - call hash_iter%next() - else - exit - end if - end do - call hash_iter%finalize() - if (ANY(.not. hash_found)) then - write(errmsg, '(a,i0,a)') "ERROR: ", & - COUNT(.not. hash_found), " test keys not found in table." - call add_error(errmsg, num_errs, errors) - end if + ! Make sure we get an error if we try to add a duplicate key + call hash_table%add_hash_key(hash_chars(2)%item, & + errmsg=errors(num_errs + 1)) + if (len_trim(errors(num_errs + 1)) == 0) then + num_errs = num_errs + 1 + write(errors(num_errs), *) & + "ERROR: Allowed duplicate entry for '", & + hash_chars(2)%item%key(), "'" end if - ! Finally, clear the hash table (should deallocate everything) - call hash_table%clear() - ! Make sure hash table is *not* initialized - if (hash_table%is_initialized()) then - call add_error("Error: hash table initialized after clear", & - num_errs, errors) + num_tests = num_tests + 1 + ! Check that the total number of table entries is correct + if (hash_table%num_values() /= num_test_entries) then + write(errmsg, '(2(a,i0))') "ERROR: Wrong table value count, ", & + hash_table%num_values(), ', should be ', num_test_entries + call add_error(errmsg, num_errs, errors) end if num_tests = num_tests + 1 - ! Cleanup - do index = 1, num_test_entries - deallocate(hash_chars(index)%item) + ! Test iteration through hash table + hash_found(:) = .false. + call hash_iter%initialize(hash_table) + num_tests = num_tests + 1 + do + if (hash_iter%valid()) then + test_key = hash_iter%key() + index = 1 + do + if (trim(test_key) == trim(hash_names(index))) then + hash_found(index) = .true. + exit + else if (index >= num_test_entries) then + write(errmsg, '(3a)') & + "ERROR: Unexpected table entry, '", & + trim(test_key), "'" + call add_error(errmsg, num_errs, errors) + end if + index = index + 1 + end do + call hash_iter%next() + else + exit + end if end do - - end subroutine test_table + call hash_iter%finalize() + if (any( .not. hash_found)) then + write(errmsg, '(a,i0,a)') "ERROR: ", & + count( .not. hash_found), " test keys not found in table." + call add_error(errmsg, num_errs, errors) + end if + end if + ! Finally, clear the hash table (should deallocate everything) + call hash_table%clear() + ! Make sure hash table is *not* initialized + if (hash_table%is_initialized()) then + call add_error("Error: hash table initialized after clear", & + num_errs, errors) + end if + num_tests = num_tests + 1 + ! Cleanup + do index = 1, num_test_entries + deallocate(hash_chars(index)%item) + end do + + end subroutine test_table end module test_hash_utils program test_hash - use ccpp_hash_table, only: ccpp_hash_table_t - use test_hash_utils, only: test_table, max_terrs - - integer, parameter :: num_table_sizes = 5 - integer, parameter :: max_errs = max_terrs * num_table_sizes - integer, parameter :: err_size = 128 - integer, parameter :: test_sizes(num_table_sizes) = (/ & - 0, 1, 2, 4, 20 /) - - type(ccpp_hash_table_t), target :: hash_table - integer :: index - integer :: errcnt = 0 - integer :: num_tests = 0 - integer :: total_errcnt = 0 - integer :: total_tests = 0 - character(len=err_size) :: errors(max_errs) - - errors = '' - do index = 1, num_table_sizes - call test_table(hash_table, test_sizes(index), num_tests, errcnt, & - errors(total_errcnt+1:)) - total_tests = total_tests + num_tests - total_errcnt = total_errcnt + errcnt - end do - - if (total_errcnt > 0) then - write(6, '(a,i0,a)') 'FAIL, ', total_errcnt, ' errors found' - do index = 1, total_errcnt - write(6, *) trim(errors(index)) - end do - STOP 1 - else - write(6, '(a,i0,a)') "All ", total_tests, " hash table tests passed!" - STOP 0 - end if + use ccpp_hash_table, only: ccpp_hash_table_t + use test_hash_utils, only: test_table, & + max_terrs + + integer, parameter :: num_table_sizes = 5 + integer, parameter :: max_errs = max_terrs * num_table_sizes + integer, parameter :: err_size = 128 + integer, parameter :: test_sizes(num_table_sizes) = (/ & + 0, 1, 2, 4, 20 /) + + type(ccpp_hash_table_t), target :: hash_table + integer :: index + integer :: errcnt = 0 + integer :: num_tests = 0 + integer :: total_errcnt = 0 + integer :: total_tests = 0 + character(len=err_size) :: errors(max_errs) + + errors = '' + do index = 1, num_table_sizes + call test_table(hash_table, test_sizes(index), num_tests, errcnt, & + errors(total_errcnt + 1:)) + total_tests = total_tests + num_tests + total_errcnt = total_errcnt + errcnt + end do + + if (total_errcnt > 0) then + write(6, '(a,i0,a)') 'FAIL, ', total_errcnt, ' errors found' + do index = 1, total_errcnt + write(6, *) trim(errors(index)) + end do + stop 1 + else + write(6, '(a,i0,a)') "All ", total_tests, " hash table tests passed!" + stop 0 + end if end program test_hash diff --git a/test/nested_suite_test/ccpp_kinds.F90 b/test/nested_suite_test/ccpp_kinds.F90 index b2923935..2eed03c9 100644 --- a/test/nested_suite_test/ccpp_kinds.F90 +++ b/test/nested_suite_test/ccpp_kinds.F90 @@ -10,18 +10,18 @@ ! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - !> !! @brief Auto-generated kinds for CCPP !! ! module ccpp_kinds - use ISO_FORTRAN_ENV, only: kind_phys => REAL64 + use iso_fortran_env, only: & + kind_phys => real64 - implicit none - private + implicit none + private - public :: kind_phys + public :: kind_phys end module ccpp_kinds diff --git a/test/nested_suite_test/effr_calc.F90 b/test/nested_suite_test/effr_calc.F90 index 0b626c16..b8fc43ed 100644 --- a/test/nested_suite_test/effr_calc.F90 +++ b/test/nested_suite_test/effr_calc.F90 @@ -3,82 +3,82 @@ module effr_calc - use ccpp_kinds, only: kind_phys - - implicit none - private - - public :: effr_calc_run, effr_calc_init - - contains - !> \section arg_table_effr_calc_init Argument Table - !! \htmlinclude arg_table_effr_calc_init.html - !! - subroutine effr_calc_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order .ne. 2) then - errflg = 1 - errmsg = 'ERROR: effr_calc_init() needs to be called second' - return - else - scheme_order = scheme_order + 1 - endif - - end subroutine effr_calc_init - - !> \section arg_table_effr_calc_run Argument Table - !! \htmlinclude arg_table_effr_calc_run.html - !! - subroutine effr_calc_run(ncol, nlev, effrr_in, effrg_in, ncg_in, nci_out, & - effrl_inout, effri_out, effrs_inout, ncl_out, & - has_graupel, scalar_var, tke_inout, tke2_inout, & - errmsg, errflg) - - integer, intent(in) :: ncol - integer, intent(in) :: nlev - real(kind_phys), intent(in) :: effrr_in(:,:) - real(kind_phys), intent(in),optional :: effrg_in(:,:) - real(kind_phys), intent(in),optional :: ncg_in(:,:) - real(kind_phys), intent(out),optional :: nci_out(:,:) - real(kind_phys), intent(inout) :: effrl_inout(:,:) - real(kind_phys), intent(out),optional :: effri_out(:,:) - real(8),intent(inout) :: effrs_inout(:,:) - logical, intent(in) :: has_graupel - real(kind_phys), intent(inout) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - real(kind_phys), intent(out),optional :: ncl_out(:,:) - real(kind_phys), intent(inout) :: tke_inout - real(kind_phys), intent(inout) :: tke2_inout - - !---------------------------------------------------------------- - - real(kind_phys), parameter :: re_qc_min = 2.5 ! microns - real(kind_phys), parameter :: re_qc_max = 50. ! microns - real(kind_phys), parameter :: re_qi_avg = 75. ! microns - real(kind_phys) :: effrr_local(ncol,nlev) - real(kind_phys) :: effrg_local(ncol,nlev) - real(kind_phys) :: ncg_in_local(ncol,nlev) - real(kind_phys) :: nci_out_local(ncol,nlev) - - errmsg = '' - errflg = 0 - - effrr_local = effrr_in - if (present(effrg_in)) effrg_local = effrg_in - if (present(ncg_in)) ncg_in_local = ncg_in - if (present(nci_out)) nci_out_local = nci_out - effrl_inout = min(max(effrl_inout,re_qc_min),re_qc_max) - if (present(effri_out)) effri_out = re_qi_avg - effrs_inout = effrs_inout + (10.0 / 6.0) ! in micrometer - scalar_var = 2.0 ! in km - - end subroutine effr_calc_run + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: effr_calc_run, effr_calc_init + +contains + !> \section arg_table_effr_calc_init Argument Table + !! \htmlinclude arg_table_effr_calc_init.html + !! + subroutine effr_calc_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order /= 2) then + errflg = 1 + errmsg = 'ERROR: effr_calc_init() needs to be called second' + return + else + scheme_order = scheme_order + 1 + end if + + end subroutine effr_calc_init + + !> \section arg_table_effr_calc_run Argument Table + !! \htmlinclude arg_table_effr_calc_run.html + !! + subroutine effr_calc_run(ncol, nlev, effrr_in, effrg_in, ncg_in, nci_out, & + effrl_inout, effri_out, effrs_inout, ncl_out, & + has_graupel, scalar_var, tke_inout, tke2_inout, & + errmsg, errflg) + + integer, intent(in) :: ncol + integer, intent(in) :: nlev + real(kind=kind_phys), intent(in) :: effrr_in(:, :) + real(kind=kind_phys), intent(in), optional :: effrg_in(:, :) + real(kind=kind_phys), intent(in), optional :: ncg_in(:, :) + real(kind=kind_phys), intent(out), optional :: nci_out(:, :) + real(kind=kind_phys), intent(inout) :: effrl_inout(:, :) + real(kind=kind_phys), intent(out), optional :: effri_out(:, :) + real(kind=8), intent(inout) :: effrs_inout(:, :) + logical, intent(in) :: has_graupel + real(kind=kind_phys), intent(inout) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind=kind_phys), intent(out), optional :: ncl_out(:, :) + real(kind=kind_phys), intent(inout) :: tke_inout + real(kind=kind_phys), intent(inout) :: tke2_inout + + !---------------------------------------------------------------- + + real(kind=kind_phys), parameter :: re_qc_min = 2.5 ! microns + real(kind=kind_phys), parameter :: re_qc_max = 50. ! microns + real(kind=kind_phys), parameter :: re_qi_avg = 75. ! microns + real(kind=kind_phys) :: effrr_local(ncol, nlev) + real(kind=kind_phys) :: effrg_local(ncol, nlev) + real(kind=kind_phys) :: ncg_in_local(ncol, nlev) + real(kind=kind_phys) :: nci_out_local(ncol, nlev) + + errmsg = '' + errflg = 0 + + effrr_local = effrr_in + if (present(effrg_in)) effrg_local = effrg_in + if (present(ncg_in)) ncg_in_local = ncg_in + if (present(nci_out)) nci_out_local = nci_out + effrl_inout = min(max(effrl_inout, re_qc_min), re_qc_max) + if (present(effri_out)) effri_out = re_qi_avg + effrs_inout = effrs_inout + (10.0 / 6.0) ! in micrometer + scalar_var = 2.0 ! in km + + end subroutine effr_calc_run end module effr_calc diff --git a/test/nested_suite_test/effr_diag.F90 b/test/nested_suite_test/effr_diag.F90 index 409ff2f9..75da29c7 100644 --- a/test/nested_suite_test/effr_diag.F90 +++ b/test/nested_suite_test/effr_diag.F90 @@ -3,12 +3,12 @@ module effr_diag - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_diag_run, effr_diag_init + public :: effr_diag_run, effr_diag_init contains @@ -16,53 +16,53 @@ module effr_diag !! \htmlinclude arg_table_effr_diag_init.html !! subroutine effr_diag_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + errmsg = '' errflg = 0 - if (scheme_order .ne. 4) then - errflg = 1 - errmsg = 'ERROR: effr_diag_init() needs to be called fourth' - return - else - scheme_order = scheme_order + 1 - endif + if (scheme_order /= 4) then + errflg = 1 + errmsg = 'ERROR: effr_diag_init() needs to be called fourth' + return + else + scheme_order = scheme_order + 1 + end if end subroutine effr_diag_init - !> \section arg_table_effr_diag_run Argument Table - !! \htmlinclude arg_table_effr_diag_run.html - !! - subroutine effr_diag_run( effrr_in, scalar_var, errmsg, errflg) - - real(kind_phys), intent(in) :: effrr_in(:,:) - integer, intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - call cmp_effr_diag(effrr_in, effrr_min, effrr_max) - - if (scalar_var .ne. 380) then - errmsg = 'ERROR: effr_diag_run(): scalar_var should be 380' - errflg = 1 - endif - end subroutine effr_diag_run - - subroutine cmp_effr_diag(effr, effr_min, effr_max) - real(kind_phys), intent(in) :: effr(:,:) - real(kind_phys), intent(out) :: effr_min, effr_max - - ! Do some diagnostic calcualtions... - effr_min = minval(effr) - effr_max = maxval(effr) - - end subroutine cmp_effr_diag + !> \section arg_table_effr_diag_run Argument Table + !! \htmlinclude arg_table_effr_diag_run.html + !! + subroutine effr_diag_run(effrr_in, scalar_var, errmsg, errflg) + + real(kind=kind_phys), intent(in) :: effrr_in(:, :) + integer, intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind=kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + call cmp_effr_diag(effrr_in, effrr_min, effrr_max) + + if (scalar_var /= 380) then + errmsg = 'ERROR: effr_diag_run(): scalar_var should be 380' + errflg = 1 + end if + end subroutine effr_diag_run + + subroutine cmp_effr_diag(effr, effr_min, effr_max) + real(kind=kind_phys), intent(in) :: effr(:, :) + real(kind=kind_phys), intent(out) :: effr_min, effr_max + + ! Do some diagnostic calcualtions... + effr_min = minval(effr) + effr_max = maxval(effr) + + end subroutine cmp_effr_diag end module effr_diag diff --git a/test/nested_suite_test/effr_post.F90 b/test/nested_suite_test/effr_post.F90 index d42a574c..01357350 100644 --- a/test/nested_suite_test/effr_post.F90 +++ b/test/nested_suite_test/effr_post.F90 @@ -3,59 +3,59 @@ module effr_post - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_post_run, effr_post_init + public :: effr_post_run, effr_post_init contains - !> \section arg_table_effr_post_init Argument Table - !! \htmlinclude arg_table_effr_post_init.html - !! - subroutine effr_post_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order .ne. 3) then - errflg = 1 - errmsg = 'ERROR: effr_post_init() needs to be called third' - return - else - scheme_order = scheme_order + 1 - endif - - end subroutine effr_post_init - - !> \section arg_table_effr_post_run Argument Table - !! \htmlinclude arg_table_effr_post_run.html - !! - subroutine effr_post_run( effrr_inout, scalar_var, errmsg, errflg) - - real(kind_phys), intent(inout) :: effrr_inout(:,:) - real(kind_phys), intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - ! Do some post-processing on effrr... - effrr_inout(:,:) = effrr_inout(:,:)*1._kind_phys - - if (scalar_var .ne. 1013.0) then - errmsg = 'ERROR: effr_post_run(): scalar_var should be 1013.0' - errflg = 1 - endif - - end subroutine effr_post_run - - end module effr_post + !> \section arg_table_effr_post_init Argument Table + !! \htmlinclude arg_table_effr_post_init.html + !! + subroutine effr_post_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order /= 3) then + errflg = 1 + errmsg = 'ERROR: effr_post_init() needs to be called third' + return + else + scheme_order = scheme_order + 1 + end if + + end subroutine effr_post_init + + !> \section arg_table_effr_post_run Argument Table + !! \htmlinclude arg_table_effr_post_run.html + !! + subroutine effr_post_run(effrr_inout, scalar_var, errmsg, errflg) + + real(kind=kind_phys), intent(inout) :: effrr_inout(:, :) + real(kind=kind_phys), intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind=kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + ! Do some post-processing on effrr... + effrr_inout(:, :) = effrr_inout(:, :) * 1._kind_phys + + if (scalar_var /= 1013.0) then + errmsg = 'ERROR: effr_post_run(): scalar_var should be 1013.0' + errflg = 1 + end if + + end subroutine effr_post_run + +end module effr_post diff --git a/test/nested_suite_test/effr_pre.F90 b/test/nested_suite_test/effr_pre.F90 index 17a3b187..a2fe2f5c 100644 --- a/test/nested_suite_test/effr_pre.F90 +++ b/test/nested_suite_test/effr_pre.F90 @@ -3,58 +3,58 @@ module mod_effr_pre - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_pre_run, effr_pre_init + public :: effr_pre_run, effr_pre_init contains - !> \section arg_table_effr_pre_init Argument Table - !! \htmlinclude arg_table_effr_pre_init.html - !! - subroutine effr_pre_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order .ne. 1) then - errflg = 1 - errmsg = 'ERROR: effr_pre_init() needs to be called first' - return - else - scheme_order = scheme_order + 1 - endif - - end subroutine effr_pre_init - - !> \section arg_table_effr_pre_run Argument Table - !! \htmlinclude arg_table_effr_pre_run.html - !! - subroutine effr_pre_run( effrr_inout, scalar_var, errmsg, errflg) - - real(kind_phys), intent(inout) :: effrr_inout(:,:) - real(kind_phys), intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - ! Do some pre-processing on effrr... - effrr_inout(:,:) = effrr_inout(:,:)*1._kind_phys - - if (scalar_var .ne. 273.15) then - errmsg = 'ERROR: effr_pre_run(): scalar_var should be 273.15' - errflg = 1 - endif - - end subroutine effr_pre_run + !> \section arg_table_effr_pre_init Argument Table + !! \htmlinclude arg_table_effr_pre_init.html + !! + subroutine effr_pre_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order /= 1) then + errflg = 1 + errmsg = 'ERROR: effr_pre_init() needs to be called first' + return + else + scheme_order = scheme_order + 1 + end if + + end subroutine effr_pre_init + + !> \section arg_table_effr_pre_run Argument Table + !! \htmlinclude arg_table_effr_pre_run.html + !! + subroutine effr_pre_run(effrr_inout, scalar_var, errmsg, errflg) + + real(kind=kind_phys), intent(inout) :: effrr_inout(:, :) + real(kind=kind_phys), intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind=kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + ! Do some pre-processing on effrr... + effrr_inout(:, :) = effrr_inout(:, :) * 1._kind_phys + + if (scalar_var /= 273.15) then + errmsg = 'ERROR: effr_pre_run(): scalar_var should be 273.15' + errflg = 1 + end if + + end subroutine effr_pre_run end module mod_effr_pre diff --git a/test/nested_suite_test/effrs_calc.F90 b/test/nested_suite_test/effrs_calc.F90 index e9266905..3aa8d196 100644 --- a/test/nested_suite_test/effrs_calc.F90 +++ b/test/nested_suite_test/effrs_calc.F90 @@ -3,30 +3,30 @@ module effrs_calc - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effrs_calc_run + public :: effrs_calc_run - contains - !> \section arg_table_effrs_calc_run Argument Table - !! \htmlinclude arg_table_effrs_calc_run.html - !! - subroutine effrs_calc_run(effrs_inout, errmsg, errflg) +contains + !> \section arg_table_effrs_calc_run Argument Table + !! \htmlinclude arg_table_effrs_calc_run.html + !! + subroutine effrs_calc_run(effrs_inout, errmsg, errflg) - real(kind_phys), intent(inout) :: effrs_inout(:,:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(inout) :: effrs_inout(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - !---------------------------------------------------------------- + !---------------------------------------------------------------- - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 - effrs_inout = effrs_inout + (10.E-6_kind_phys / 3._kind_phys) ! in meters + effrs_inout = effrs_inout + (10.E-6_kind_phys / 3._kind_phys) ! in meters - end subroutine effrs_calc_run + end subroutine effrs_calc_run end module effrs_calc diff --git a/test/nested_suite_test/module_rad_ddt.F90 b/test/nested_suite_test/module_rad_ddt.F90 index 21a1a0ec..6e992250 100644 --- a/test/nested_suite_test/module_rad_ddt.F90 +++ b/test/nested_suite_test/module_rad_ddt.F90 @@ -1,5 +1,5 @@ module mod_rad_ddt - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys implicit none public ty_rad_lw, ty_rad_sw @@ -8,16 +8,16 @@ module mod_rad_ddt !! \htmlinclude arg_table_ty_rad_lw.html !! type ty_rad_lw - real(kind_phys) :: sfc_up_lw - real(kind_phys) :: sfc_down_lw + real(kind=kind_phys) :: sfc_up_lw + real(kind=kind_phys) :: sfc_down_lw end type ty_rad_lw !> \section arg_table_ty_rad_sw Argument Table !! \htmlinclude arg_table_ty_rad_sw.html !! type ty_rad_sw - real(kind_phys), pointer :: sfc_up_sw(:) => null() - real(kind_phys), pointer :: sfc_down_sw(:) => null() + real(kind=kind_phys), pointer :: sfc_up_sw(:) => null() + real(kind=kind_phys), pointer :: sfc_down_sw(:) => null() end type ty_rad_sw end module mod_rad_ddt diff --git a/test/nested_suite_test/rad_lw.F90 b/test/nested_suite_test/rad_lw.F90 index 5859f8bf..ded4861f 100644 --- a/test/nested_suite_test/rad_lw.F90 +++ b/test/nested_suite_test/rad_lw.F90 @@ -12,12 +12,12 @@ module rad_lw !> \section arg_table_rad_lw_run Argument Table !! \htmlinclude arg_table_rad_lw_run.html !! - subroutine rad_lw_run(ncol, fluxLW, errmsg, errflg) + subroutine rad_lw_run(ncol, fluxlw, errmsg, errflg) - integer, intent(in) :: ncol - type(ty_rad_lw), intent(inout) :: fluxLW(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + type(ty_rad_lw), intent(inout) :: fluxlw(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg ! Locals integer :: icol @@ -25,10 +25,10 @@ subroutine rad_lw_run(ncol, fluxLW, errmsg, errflg) errmsg = '' errflg = 0 - do icol=1,ncol - fluxLW(icol)%sfc_up_lw = 300._kind_phys - fluxLW(icol)%sfc_down_lw = 50._kind_phys - enddo + do icol = 1, ncol + fluxlw(icol)%sfc_up_lw = 300._kind_phys + fluxlw(icol)%sfc_down_lw = 50._kind_phys + end do end subroutine rad_lw_run diff --git a/test/nested_suite_test/rad_sw.F90 b/test/nested_suite_test/rad_sw.F90 index ddf35224..64756217 100644 --- a/test/nested_suite_test/rad_sw.F90 +++ b/test/nested_suite_test/rad_sw.F90 @@ -13,11 +13,11 @@ module rad_sw !! subroutine rad_sw_run(ncol, sfc_up_sw, sfc_down_sw, errmsg, errflg) - integer, intent(in) :: ncol - real(kind_phys), intent(inout) :: sfc_up_sw(:) - real(kind_phys), intent(inout) :: sfc_down_sw(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + real(kind=kind_phys), intent(inout) :: sfc_up_sw(:) + real(kind=kind_phys), intent(inout) :: sfc_down_sw(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg ! Locals integer :: icol @@ -25,10 +25,10 @@ subroutine rad_sw_run(ncol, sfc_up_sw, sfc_down_sw, errmsg, errflg) errmsg = '' errflg = 0 - do icol=1,ncol - sfc_up_sw(icol) = 100._kind_phys - sfc_down_sw(icol) = 400._kind_phys - enddo + do icol = 1, ncol + sfc_up_sw(icol) = 100._kind_phys + sfc_down_sw(icol) = 400._kind_phys + end do end subroutine rad_sw_run diff --git a/test/nested_suite_test/test_host.F90 b/test/nested_suite_test/test_host.F90 index f3a389e8..5d165305 100644 --- a/test/nested_suite_test/test_host.F90 +++ b/test/nested_suite_test/test_host.F90 @@ -1,264 +1,264 @@ 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 = 32 - integer, public, parameter :: cm = 60 + ! Public data and interfaces + integer, public, parameter :: cs = 32 + integer, public, parameter :: cm = 60 - !> \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) + use test_host_mod, only: ncols + 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 + use test_utils, only: check_list - use test_host_mod, only: ncols - 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 - 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 :: index, sind + 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 :: 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 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 - ! 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 - - ! 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 + ! 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 - 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 - 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 col_start = 1, ncols, 5 + if (errflg /= 0) then + exit + end if + col_end = min(col_start + 4, ncols) - do sind = 1, num_suites + 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 + exit end if if (errflg == 0) then - call test_host_ccpp_physics_timestep_final( & - test_suites(sind)%suite_name, errmsg, errflg) + 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, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(errmsg) - exit + 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 + 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 - if (errflg == 0) then - ! Run finished without error, check answers - if (compare_data()) then - write(6, *) 'Answers are correct!' - errflg = 0 - else - write(6, *) 'Answers are not correct!' - errflg = -1 - end if - end if + 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 (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/nested_suite_test/test_host_data.F90 b/test/nested_suite_test/test_host_data.F90 index c46bbfff..5389590f 100644 --- a/test/nested_suite_test/test_host_data.F90 +++ b/test/nested_suite_test/test_host_data.F90 @@ -1,32 +1,33 @@ module test_host_data - use ccpp_kinds, only: kind_phys - use mod_rad_ddt, only: ty_rad_lw, ty_rad_sw + use ccpp_kinds, only: kind_phys + use mod_rad_ddt, only: ty_rad_lw, & + ty_rad_sw - implicit none - private + implicit none + private !> \section arg_table_physics_state Argument Table !! \htmlinclude arg_table_physics_state.html type physics_state - real(kind_phys), dimension(:,:), allocatable :: & - effrr, & ! effective radius of cloud rain - effrl, & ! effective radius of cloud liquid water - effri, & ! effective radius of cloud ice - effrg, & ! effective radius of cloud graupel - ncg, & ! number concentration of cloud graupel - nci ! number concentration of cloud ice - real(kind_phys) :: scalar_var - type(ty_rad_lw), dimension(:), allocatable :: & - fluxLW ! Longwave radiation fluxes - type(ty_rad_sw) :: & - fluxSW ! Shortwave radiation fluxes - real(kind_phys) :: scalar_varA - real(kind_phys) :: scalar_varB - real(kind_phys) :: tke, tke2 - integer :: scalar_varC - integer :: scheme_order - integer :: num_subcycles + real(kind=kind_phys), dimension(:, :), allocatable :: & + effrr, & ! effective radius of cloud rain + effrl, & ! effective radius of cloud liquid water + effri, & ! effective radius of cloud ice + effrg, & ! effective radius of cloud graupel + ncg, & ! number concentration of cloud graupel + nci ! number concentration of cloud ice + real(kind=kind_phys) :: scalar_var + type(ty_rad_lw), dimension(:), allocatable :: & + fluxlw ! Longwave radiation fluxes + type(ty_rad_sw) :: & + fluxsw ! Shortwave radiation fluxes + real(kind=kind_phys) :: scalar_vara + real(kind=kind_phys) :: scalar_varb + real(kind=kind_phys) :: tke, tke2 + integer :: scalar_varc + integer :: scheme_order + integer :: num_subcycles end type physics_state public :: physics_state @@ -35,62 +36,62 @@ module test_host_data contains subroutine allocate_physics_state(cols, levels, state, has_graupel, has_ice) - integer, intent(in) :: cols - integer, intent(in) :: levels + integer, intent(in) :: cols + integer, intent(in) :: levels type(physics_state), intent(out) :: state - logical, intent(in) :: has_graupel - logical, intent(in) :: has_ice + logical, intent(in) :: has_graupel + logical, intent(in) :: has_ice if (allocated(state%effrr)) then - deallocate(state%effrr) + deallocate(state%effrr) end if allocate(state%effrr(cols, levels)) if (allocated(state%effrl)) then - deallocate(state%effrl) + deallocate(state%effrl) end if allocate(state%effrl(cols, levels)) if (has_ice) then - if (allocated(state%effri)) then - deallocate(state%effri) - end if - allocate(state%effri(cols, levels)) - endif + if (allocated(state%effri)) then + deallocate(state%effri) + end if + allocate(state%effri(cols, levels)) + end if if (has_graupel) then - if (allocated(state%effrg)) then - deallocate(state%effrg) - end if - allocate(state%effrg(cols, levels)) - - if (allocated(state%ncg)) then - deallocate(state%ncg) - end if - allocate(state%ncg(cols, levels)) - endif + if (allocated(state%effrg)) then + deallocate(state%effrg) + end if + allocate(state%effrg(cols, levels)) + + if (allocated(state%ncg)) then + deallocate(state%ncg) + end if + allocate(state%ncg(cols, levels)) + end if if (has_ice) then - if (allocated(state%nci)) then - deallocate(state%nci) - end if - allocate(state%nci(cols, levels)) - endif - - if (allocated(state%fluxLW)) then - deallocate(state%fluxLW) + if (allocated(state%nci)) then + deallocate(state%nci) + end if + allocate(state%nci(cols, levels)) + end if + + if (allocated(state%fluxlw)) then + deallocate(state%fluxlw) end if - allocate(state%fluxLW(cols)) + allocate(state%fluxlw(cols)) - if (associated(state%fluxSW%sfc_up_sw)) then - nullify(state%fluxSW%sfc_up_sw) + if (associated(state%fluxsw%sfc_up_sw)) then + nullify(state%fluxsw%sfc_up_sw) end if - allocate(state%fluxSW%sfc_up_sw(cols)) + allocate(state%fluxsw%sfc_up_sw(cols)) - if (associated(state%fluxSW%sfc_down_sw)) then - nullify(state%fluxSW%sfc_down_sw) + if (associated(state%fluxsw%sfc_down_sw)) then + nullify(state%fluxsw%sfc_down_sw) end if - allocate(state%fluxSW%sfc_down_sw(cols)) + allocate(state%fluxsw%sfc_down_sw(cols)) ! Initialize scheme counter. state%scheme_order = 1 diff --git a/test/nested_suite_test/test_host_mod.F90 b/test/nested_suite_test/test_host_mod.F90 index 09d1fdb5..33e4a858 100644 --- a/test/nested_suite_test/test_host_mod.F90 +++ b/test/nested_suite_test/test_host_mod.F90 @@ -1,23 +1,24 @@ 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 = 12 - integer, parameter :: pver = 4 - type(physics_state) :: phys_state - real(kind_phys) :: effrs(ncols, pver) - logical, parameter :: has_ice = .true. - logical, parameter :: has_graupel = .true. - - public :: init_data - public :: compare_data + 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 = 12 + integer, parameter :: pver = 4 + type(physics_state) :: phys_state + real(kind=kind_phys) :: effrs(ncols, pver) + logical, parameter :: has_ice = .true. + logical, parameter :: has_graupel = .true. + + public :: init_data + public :: compare_data contains @@ -27,19 +28,19 @@ subroutine init_data() call allocate_physics_state(ncols, pver, phys_state, has_graupel, has_ice) phys_state%effrr = 1.0E-3 ! 1000 microns, in meter phys_state%effrl = 1.0E-4 ! 100 microns, in meter - phys_state%scalar_var = 1.0 ! in m - phys_state%scalar_varA = 273.15 ! in K - phys_state%scalar_varB = 1013.0 ! in mb - phys_state%scalar_varC = 380 ! in ppmv - effrs = 5.0E-4 ! 500 microns, in meter + phys_state%scalar_var = 1.0 ! in m + phys_state%scalar_vara = 273.15 ! in K + phys_state%scalar_varb = 1013.0 ! in mb + phys_state%scalar_varc = 380 ! in ppmv + effrs = 5.0E-4 ! 500 microns, in meter if (has_graupel) then - phys_state%effrg = 2.5E-4 ! 250 microns, in meter - phys_state%ncg = 40 - endif + phys_state%effrg = 2.5E-4 ! 250 microns, in meter + phys_state%ncg = 40 + end if if (has_ice) then - phys_state%effri = 5.0E-5 ! 50 microns, in meter - phys_state%nci = 80 - endif + phys_state%effri = 5.0E-5 ! 50 microns, in meter + phys_state%nci = 80 + end if phys_state%tke = 10.0 !J kg-1 phys_state%tke2 = 42.0 !J kg-1 @@ -47,80 +48,85 @@ end subroutine init_data logical function compare_data() - real(kind_phys), parameter :: effrr_expected = 1.0E-3 ! 1000 microns, in meter - real(kind_phys), parameter :: effrl_expected = 5.0E-5 ! 50 microns, in meter - real(kind_phys), parameter :: effri_expected = 7.5E-5 ! 75 microns, in meter - real(kind_phys), parameter :: effrs_expected = 5.3E-4 ! 530 microns, in meter - real(kind_phys), parameter :: scalar_expected = 2.0E3 ! 2 km, in meter - real(kind_phys), parameter :: tke_expected = 10.0 ! 10 J kg-1 - real(kind_phys), parameter :: tolerance = 1.0E-6 ! used as scaling factor for expected value - real(kind_phys), parameter :: sfc_up_sw_expected = 100. ! W/m2 - real(kind_phys), parameter :: sfc_down_sw_expected = 400. ! W/m2 - real(kind_phys), parameter :: sfc_up_lw_expected = 300. ! W/m2 - real(kind_phys), parameter :: sfc_down_lw_expected = 50. ! W/m2 + real(kind=kind_phys), parameter :: effrr_expected = 1.0E-3 ! 1000 microns, in meter + real(kind=kind_phys), parameter :: effrl_expected = 5.0E-5 ! 50 microns, in meter + real(kind=kind_phys), parameter :: effri_expected = 7.5E-5 ! 75 microns, in meter + real(kind=kind_phys), parameter :: effrs_expected = 5.3E-4 ! 530 microns, in meter + real(kind=kind_phys), parameter :: scalar_expected = 2.0E3 ! 2 km, in meter + real(kind=kind_phys), parameter :: tke_expected = 10.0 ! 10 J kg-1 + real(kind=kind_phys), parameter :: tolerance = 1.0E-6 ! used as scaling factor for expected value + real(kind=kind_phys), parameter :: sfc_up_sw_expected = 100. ! W/m2 + real(kind=kind_phys), parameter :: sfc_down_sw_expected = 400. ! W/m2 + real(kind=kind_phys), parameter :: sfc_up_lw_expected = 300. ! W/m2 + real(kind=kind_phys), parameter :: sfc_down_lw_expected = 50. ! W/m2 compare_data = .true. - if (maxval(abs(phys_state%effrr - effrr_expected)) > tolerance*effrr_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrr from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effrr - effrr_expected)), ' > ', tolerance*effrr_expected - compare_data = .false. + if (maxval(abs(phys_state%effrr - effrr_expected)) > tolerance * effrr_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrr from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effrr - effrr_expected)), ' > ', tolerance * effrr_expected + compare_data = .false. + end if + + if (maxval(abs(phys_state%effrl - effrl_expected)) > tolerance * effrl_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrl from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effrl - effrl_expected)), ' > ', tolerance * effrl_expected + compare_data = .false. + end if + + if (maxval(abs(phys_state%effri - effri_expected)) > tolerance * effri_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effri from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effri - effri_expected)), ' > ', tolerance * effri_expected + compare_data = .false. + end if + + if (maxval(abs(effrs - effrs_expected)) > tolerance * effrs_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of effrs from expected value exceeds tolerance: ', & + maxval(abs(effrs - effrs_expected)), ' > ', tolerance * effrs_expected + compare_data = .false. + end if + + if (abs(phys_state%scalar_var - scalar_expected) > tolerance * scalar_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of scalar_var from expected value exceeds tolerance: ', & + abs(phys_state%scalar_var - scalar_expected), ' > ', tolerance * scalar_expected + compare_data = .false. end if - if (maxval(abs(phys_state%effrl - effrl_expected)) > tolerance*effrl_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrl from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effrl - effrl_expected)), ' > ', tolerance*effrl_expected - compare_data = .false. + if (abs(phys_state%tke - tke_expected) > tolerance * tke_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of tke from expected value exceeds tolerance: ', & + abs(phys_state%tke - tke_expected), ' > ', tolerance * tke_expected + compare_data = .false. end if - if (maxval(abs(phys_state%effri - effri_expected)) > tolerance*effri_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effri from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effri - effri_expected)), ' > ', tolerance*effri_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxsw%sfc_up_sw - sfc_up_sw_expected)) > tolerance * sfc_up_sw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_up_sw from expected value exceeds tolerance: ', & + abs(phys_state%fluxsw%sfc_up_sw - sfc_up_sw_expected), ' > ', tolerance * sfc_up_sw_expected + compare_data = .false. end if - if (maxval(abs( effrs - effrs_expected)) > tolerance*effrs_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of effrs from expected value exceeds tolerance: ', & - maxval(abs( effrs - effrs_expected)), ' > ', tolerance*effrs_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxsw%sfc_down_sw - sfc_down_sw_expected)) > tolerance * sfc_down_sw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_down_sw from expected value exceeds tolerance: ', & + abs(phys_state%fluxsw%sfc_down_sw - sfc_down_sw_expected), ' > ', tolerance * sfc_down_sw_expected + compare_data = .false. end if - if (abs( phys_state%scalar_var - scalar_expected) > tolerance*scalar_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of scalar_var from expected value exceeds tolerance: ', & - abs( phys_state%scalar_var - scalar_expected), ' > ', tolerance*scalar_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxlw%sfc_up_lw - sfc_up_lw_expected)) > tolerance * sfc_up_lw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_up_lw from expected value exceeds tolerance: ', & + abs(phys_state%fluxlw%sfc_up_lw - sfc_up_lw_expected), ' > ', tolerance * sfc_up_lw_expected + compare_data = .false. end if - if (abs( phys_state%tke - tke_expected) > tolerance*tke_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of tke from expected value exceeds tolerance: ', & - abs( phys_state%tke - tke_expected), ' > ', tolerance*tke_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxlw%sfc_down_lw - sfc_down_lw_expected)) > tolerance * sfc_down_lw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_down_lw from expected value exceeds tolerance: ', & + abs(phys_state%fluxlw%sfc_down_lw - sfc_down_lw_expected), ' > ', tolerance * sfc_down_lw_expected + compare_data = .false. end if - if (maxval(abs( phys_state%fluxSW%sfc_up_sw - sfc_up_sw_expected)) > tolerance*sfc_up_sw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_up_sw from expected value exceeds tolerance: ', & - abs( phys_state%fluxSW%sfc_up_sw - sfc_up_sw_expected), ' > ', tolerance*sfc_up_sw_expected - compare_data = .false. - end if - - if (maxval(abs( phys_state%fluxSW%sfc_down_sw - sfc_down_sw_expected)) > tolerance*sfc_down_sw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_down_sw from expected value exceeds tolerance: ', & - abs( phys_state%fluxSW%sfc_down_sw - sfc_down_sw_expected), ' > ', tolerance*sfc_down_sw_expected - compare_data = .false. - end if - - if (maxval(abs( phys_state%fluxLW%sfc_up_lw - sfc_up_lw_expected)) > tolerance*sfc_up_lw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_up_lw from expected value exceeds tolerance: ', & - abs( phys_state%fluxLW%sfc_up_lw - sfc_up_lw_expected), ' > ', tolerance*sfc_up_lw_expected - compare_data = .false. - end if - - if (maxval(abs( phys_state%fluxLW%sfc_down_lw - sfc_down_lw_expected)) > tolerance*sfc_down_lw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_down_lw from expected value exceeds tolerance: ', & - abs( phys_state%fluxLW%sfc_down_lw - sfc_down_lw_expected), ' > ', tolerance*sfc_down_lw_expected - compare_data = .false. - end if - end function compare_data end module test_host_mod diff --git a/test/nested_suite_test/test_nested_suite_integration.F90 b/test/nested_suite_test/test_nested_suite_integration.F90 index 09dfea10..55fa471d 100644 --- a/test/nested_suite_test/test_nested_suite_integration.F90 +++ b/test/nested_suite_test/test_nested_suite_integration.F90 @@ -1,88 +1,91 @@ program test_nested_suite_integration - 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(3) = (/ & - 'radiation1 ', & - 'rad_lw_group ', & - 'rad_sw_group '/) + character(len=cs), target :: test_parts1(3) = (/ & + 'radiation1 ', & + 'rad_lw_group ', & + 'rad_sw_group '/) - character(len=cm), target :: test_invars1(18) = (/ & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'effective_radius_of_stratiform_cloud_graupel ', & - 'cloud_graupel_number_concentration ', & - 'scalar_variable_for_testing ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'scalar_variable_for_testing_a ', & - 'scalar_variable_for_testing_b ', & - 'scalar_variable_for_testing_c ', & - 'scheme_order_in_suite ', & - 'num_subcycles_for_effr ', & - 'flag_indicating_cloud_microphysics_has_graupel ', & - 'flag_indicating_cloud_microphysics_has_ice ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_invars1(18) = (/ & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'effective_radius_of_stratiform_cloud_graupel ', & + 'cloud_graupel_number_concentration ', & + 'scalar_variable_for_testing ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'scalar_variable_for_testing_a ', & + 'scalar_variable_for_testing_b ', & + 'scalar_variable_for_testing_c ', & + 'scheme_order_in_suite ', & + 'num_subcycles_for_effr ', & + 'flag_indicating_cloud_microphysics_has_graupel ', & + 'flag_indicating_cloud_microphysics_has_ice ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'longwave_radiation_fluxes '/) - character(len=cm), target :: test_outvars1(14) = (/ & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'effective_radius_of_stratiform_cloud_ice_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'cloud_ice_number_concentration ', & - 'scalar_variable_for_testing ', & - 'scheme_order_in_suite ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_outvars1(14) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'effective_radius_of_stratiform_cloud_ice_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'cloud_ice_number_concentration ', & + 'scalar_variable_for_testing ', & + 'scheme_order_in_suite ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'longwave_radiation_fluxes '/) - character(len=cm), target :: test_reqvars1(22) = (/ & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_ice_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'effective_radius_of_stratiform_cloud_graupel ', & - 'cloud_graupel_number_concentration ', & - 'cloud_ice_number_concentration ', & - 'scalar_variable_for_testing ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'scalar_variable_for_testing_a ', & - 'scalar_variable_for_testing_b ', & - 'scalar_variable_for_testing_c ', & - 'scheme_order_in_suite ', & - 'num_subcycles_for_effr ', & - 'flag_indicating_cloud_microphysics_has_graupel ', & - 'flag_indicating_cloud_microphysics_has_ice ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_reqvars1(22) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_ice_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'effective_radius_of_stratiform_cloud_graupel ', & + 'cloud_graupel_number_concentration ', & + 'cloud_ice_number_concentration ', & + 'scalar_variable_for_testing ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'scalar_variable_for_testing_a ', & + 'scalar_variable_for_testing_b ', & + 'scalar_variable_for_testing_c ', & + 'scheme_order_in_suite ', & + 'num_subcycles_for_effr ', & + 'flag_indicating_cloud_microphysics_has_graupel ', & + 'flag_indicating_cloud_microphysics_has_ice ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'longwave_radiation_fluxes '/) - type(suite_info) :: test_suites(1) - logical :: run_okay + type(suite_info) :: test_suites(1) + logical :: run_okay - ! Setup expected test suite info - test_suites(1)%suite_name = 'main_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 + ! Setup expected test suite info + test_suites(1)%suite_name = 'main_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 - 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_nested_suite_integration diff --git a/test/unit_tests/sample_files/test_fortran_to_metadata.F90 b/test/unit_tests/sample_files/test_fortran_to_metadata.F90 index ff4542c4..2d08d1e3 100644 --- a/test/unit_tests/sample_files/test_fortran_to_metadata.F90 +++ b/test/unit_tests/sample_files/test_fortran_to_metadata.F90 @@ -1,28 +1,28 @@ module dme_adjust - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none + implicit none contains -!=============================================================================== -!> \section arg_table_do_stuff_run Argument Table -!! \htmlinclude do_stuff_run.html -!! + !=============================================================================== + !> \section arg_table_do_stuff_run Argument Table + !! \htmlinclude do_stuff_run.html + !! subroutine do_stuff_run(const_props, twilight_zone, errmsg, errflg) ! ! Arguments ! - type(ccpp_constituent_prop_ptr_t), intent(in) :: const_props(:) - type(serling_t), intent(inout) :: twilight_zone + type(ccpp_constituent_prop_ptr_t), intent(in) :: const_props(:) + type(serling_t), intent(inout) :: twilight_zone - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = ' ' errflg = 0 twilight_zone('adjust_set') - end subroutine dme_adjust_run + end subroutine do_stuff_run end module dme_adjust diff --git a/test/unit_tests/sample_host_files/data1_mod.F90 b/test/unit_tests/sample_host_files/data1_mod.F90 index b85db315..031d8fbf 100644 --- a/test/unit_tests/sample_host_files/data1_mod.F90 +++ b/test/unit_tests/sample_host_files/data1_mod.F90 @@ -1,11 +1,11 @@ module data1_mod - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - !> \section arg_table_data1_mod Argument Table - !! \htmlinclude arg_table_data1_mod.html - real(kind_phys) :: ps1 - real(kind_phys), allocatable :: xbox(:,:) - real(kind_phys), allocatable :: switch(:,:) + !> \section arg_table_data1_mod Argument Table + !! \htmlinclude arg_table_data1_mod.html + real(kind=kind_phys) :: ps1 + real(kind=kind_phys), allocatable :: xbox(:, :) + real(kind=kind_phys), allocatable :: switch(:, :) end module data1_mod diff --git a/test/unit_tests/sample_host_files/ddt1.F90 b/test/unit_tests/sample_host_files/ddt1.F90 index 71b22b4f..1fef089e 100644 --- a/test/unit_tests/sample_host_files/ddt1.F90 +++ b/test/unit_tests/sample_host_files/ddt1.F90 @@ -1,17 +1,17 @@ module ddt1 - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - private - implicit none + private + implicit none - !! \section arg_table_ddt1_t - !! \htmlinclude ddt1_t.html - !! - type, public :: ddt1_t - integer, public :: num_vars = 0 - real(kind_phys), allocatable :: vars(:,:,:) + !! \section arg_table_ddt1_t + !! \htmlinclude ddt1_t.html + !! + type, public :: ddt1_t + integer, public :: num_vars = 0 + real(kind=kind_phys), allocatable :: vars(:, :, :) - end type ddt1_t + end type ddt1_t end module ddt1 diff --git a/test/unit_tests/sample_host_files/ddt2.F90 b/test/unit_tests/sample_host_files/ddt2.F90 index 22d5af0e..77653d7d 100644 --- a/test/unit_tests/sample_host_files/ddt2.F90 +++ b/test/unit_tests/sample_host_files/ddt2.F90 @@ -1,24 +1,24 @@ module ddt2 - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - private - implicit none + private + implicit none - !! \section arg_table_ddt1_t - !! \htmlinclude ddt1_t.html - !! - type, public :: ddt1_t - real, pointer :: undocumented_array(:) => NULL() - end type ddt1_t + !! \section arg_table_ddt1_t + !! \htmlinclude ddt1_t.html + !! + type, public :: ddt1_t + real, pointer :: undocumented_array(:) => null() + end type ddt1_t - !! \section arg_table_ddt2_t - !! \htmlinclude ddt2_t.html - !! - type, public :: ddt2_t - integer, public :: num_vars = 0 - real(kind_phys), allocatable :: vars(:,:,:) + !! \section arg_table_ddt2_t + !! \htmlinclude ddt2_t.html + !! + type, public :: ddt2_t + integer, public :: num_vars = 0 + real(kind=kind_phys), allocatable :: vars(:, :, :) - end type ddt2_t + end type ddt2_t end module ddt2 diff --git a/test/unit_tests/sample_host_files/ddt2_extra_var.F90 b/test/unit_tests/sample_host_files/ddt2_extra_var.F90 index 00b4c170..460e33d2 100644 --- a/test/unit_tests/sample_host_files/ddt2_extra_var.F90 +++ b/test/unit_tests/sample_host_files/ddt2_extra_var.F90 @@ -1,34 +1,34 @@ module ddt2_extra_var - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - private - implicit none + private + implicit none - !! \section arg_table_ddt1_t - !! \htmlinclude ddt1_t.html - !! - type, public :: ddt1_t - real, pointer :: undocumented_array(:) => NULL() - end type ddt1_t + !! \section arg_table_ddt1_t + !! \htmlinclude ddt1_t.html + !! + type, public :: ddt1_t + real, pointer :: undocumented_array(:) => null() + end type ddt1_t - !! \section arg_table_ddt2_t - !! \htmlinclude ddt2_t.html - !! - type, public :: ddt2_t - integer, public :: num_vars = 0 - real(kind_phys), allocatable :: vars(:,:,:) - contains - procedure :: get_num_vars - end type ddt2_t + !! \section arg_table_ddt2_t + !! \htmlinclude ddt2_t.html + !! + type, public :: ddt2_t + integer, public :: num_vars = 0 + real(kind=kind_phys), allocatable :: vars(:, :, :) + contains + procedure :: get_num_vars + end type ddt2_t -CONTAINS +contains - integer function get_num_vars(this) - class(ddt2_t), intent(in) :: this + integer function get_num_vars(this) + class(ddt2_t), intent(in) :: this - get_num_vars = this%num_vars + get_num_vars = this%num_vars - end function get_num_vars + end function get_num_vars end module ddt2_extra_var diff --git a/test/unit_tests/sample_host_files/ddt_data1_mod.F90 b/test/unit_tests/sample_host_files/ddt_data1_mod.F90 index 5efe0845..4c4ffb16 100644 --- a/test/unit_tests/sample_host_files/ddt_data1_mod.F90 +++ b/test/unit_tests/sample_host_files/ddt_data1_mod.F90 @@ -1,30 +1,30 @@ module ddt_data1_mod - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - private - implicit none + private + implicit none - !! \section arg_table_ddt1_t - !! \htmlinclude ddt1_t.html - !! - type, public :: ddt1_t - real, pointer :: undocumented_array(:) => NULL() - end type ddt1_t + !! \section arg_table_ddt1_t + !! \htmlinclude ddt1_t.html + !! + type, public :: ddt1_t + real, pointer :: undocumented_array(:) => null() + end type ddt1_t - !! \section arg_table_ddt2_t - !! \htmlinclude ddt2_t.html - !! - type, public :: ddt2_t - integer, public :: num_vars = 0 - real(kind_phys), allocatable :: vars(:,:,:) + !! \section arg_table_ddt2_t + !! \htmlinclude ddt2_t.html + !! + type, public :: ddt2_t + integer, public :: num_vars = 0 + real(kind=kind_phys), allocatable :: vars(:, :, :) - end type ddt2_t + end type ddt2_t - !> \section arg_table_ddt_data1_mod Argument Table - !! \htmlinclude arg_table_ddt_data1_mod.html - real(kind_phys) :: ps1 - real(kind_phys), allocatable :: xbox(:,:) - real(kind_phys), allocatable :: switch(:,:) + !> \section arg_table_ddt_data1_mod Argument Table + !! \htmlinclude arg_table_ddt_data1_mod.html + real(kind=kind_phys) :: ps1 + real(kind=kind_phys), allocatable :: xbox(:, :) + real(kind=kind_phys), allocatable :: switch(:, :) end module ddt_data1_mod diff --git a/test/unit_tests/sample_host_files/mismatch_hdim_mod.F90 b/test/unit_tests/sample_host_files/mismatch_hdim_mod.F90 index b3ebe52b..f7540a92 100644 --- a/test/unit_tests/sample_host_files/mismatch_hdim_mod.F90 +++ b/test/unit_tests/sample_host_files/mismatch_hdim_mod.F90 @@ -1,11 +1,11 @@ module mismatch_hdim_mod - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - !> \section arg_table_mismatch_hdim_mod Argument Table - !! \htmlinclude arg_table_mismatch_hdim_mod.html - real(kind_phys) :: ps1 - real(kind_phys), allocatable :: xbox(:,:) - real(kind_phys), allocatable :: switch(:,:) + !> \section arg_table_mismatch_hdim_mod Argument Table + !! \htmlinclude arg_table_mismatch_hdim_mod.html + real(kind=kind_phys) :: ps1 + real(kind=kind_phys), allocatable :: xbox(:, :) + real(kind=kind_phys), allocatable :: switch(:, :) end module mismatch_hdim_mod diff --git a/test/unit_tests/sample_scheme_files/invalid_dummy_arg.F90 b/test/unit_tests/sample_scheme_files/invalid_dummy_arg.F90 index 16f93864..4d4bf029 100644 --- a/test/unit_tests/sample_scheme_files/invalid_dummy_arg.F90 +++ b/test/unit_tests/sample_scheme_files/invalid_dummy_arg.F90 @@ -1,31 +1,31 @@ ! Test parameterization with no vertical level ! -MODULE invalid_dummy_arg +module invalid_dummy_arg - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: invalid_dummy_arg_run + public :: invalid_dummy_arg_run -CONTAINS +contains !> \section arg_table_invalid_dummy_arg_run Argument Table !! \htmlinclude arg_table_invalid_dummy_arg_run.html !! - subroutine invalid_dummy_arg_run(foo, timestep, temp_prev, temp_layer, qv, ps, & - errmsg, errflg) - - integer, intent(in) :: foo - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(inout) :: qv(:) - real(kind_phys), intent(inout) :: ps(:) - REAL(kind_phys), intent(in) :: woohoo(:) - REAL(kind_phys), intent(inout) :: temp_layer(foo) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + subroutine invalid_dummy_arg_run(foo, timestep, temp_prev, temp_layer, qv, ps, & + errmsg, errflg) + + integer, intent(in) :: foo + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(inout) :: qv(:) + real(kind=kind_phys), intent(inout) :: ps(:) + real(kind=kind_phys), intent(in) :: woohoo(:) + real(kind=kind_phys), intent(inout) :: temp_layer(foo) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg !---------------------------------------------------------------- integer :: col_index @@ -34,10 +34,10 @@ subroutine invalid_dummy_arg_run(foo, timestep, temp_prev, temp_layer, qv, ps, errflg = 0 do col_index = 1, foo - temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) - qv(col_index) = qv(col_index) + 1.0_kind_phys + temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) + qv(col_index) = qv(col_index) + 1.0_kind_phys end do - END SUBROUTINE invalid_dummy_arg_run + end subroutine invalid_dummy_arg_run -END MODULE invalid_dummy_arg +end module invalid_dummy_arg diff --git a/test/unit_tests/sample_scheme_files/invalid_subr_stmnt.F90 b/test/unit_tests/sample_scheme_files/invalid_subr_stmnt.F90 index 98100553..bd928bf4 100644 --- a/test/unit_tests/sample_scheme_files/invalid_subr_stmnt.F90 +++ b/test/unit_tests/sample_scheme_files/invalid_subr_stmnt.F90 @@ -1,24 +1,24 @@ ! Test parameterization with no vertical level ! -MODULE invalid_subr_stmnt +module invalid_subr_stmnt - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: invalid_subr_stmnt_init + public :: invalid_subr_stmnt_init -CONTAINS +contains !> \section arg_table_invalid_subr_stmnt_init Argument Table !! \htmlinclude arg_table_invalid_subr_stmnt_init.html !! - subroutine invalid_subr_stmnt_init (woohoo, errflg) + subroutine invalid_subr_stmnt_init(woohoo, 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 @@ -27,4 +27,4 @@ subroutine invalid_subr_stmnt_init (woohoo, errflg) end subroutine invalid_subr_stmnt_init -END MODULE invalid_subr_stmnt +end module invalid_subr_stmnt diff --git a/test/unit_tests/sample_scheme_files/mismatch_hdim.F90 b/test/unit_tests/sample_scheme_files/mismatch_hdim.F90 index 67680917..0a70acc1 100644 --- a/test/unit_tests/sample_scheme_files/mismatch_hdim.F90 +++ b/test/unit_tests/sample_scheme_files/mismatch_hdim.F90 @@ -1,48 +1,48 @@ ! Test parameterization with no vertical level ! -MODULE mismatch_hdim +module mismatch_hdim - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: mismatch_hdim_init - PUBLIC :: mismatch_hdim_run + public :: mismatch_hdim_init + public :: mismatch_hdim_run -CONTAINS +contains !> \section arg_table_mismatch_hdim_run Argument Table !! \htmlinclude arg_table_mismatch_hdim_run.html !! subroutine mismatch_hdim_run(tsfc, errmsg, errflg) - real(kind_phys), intent(inout) :: tsfc(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(inout) :: tsfc(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 - tsfc = tsfc-1.0_kind_phys + tsfc = tsfc - 1.0_kind_phys - END SUBROUTINE mismatch_hdim_run + end subroutine mismatch_hdim_run !> \section arg_table_mismatch_hdim_init Argument Table !! \htmlinclude arg_table_mismatch_hdim_init.html !! - subroutine mismatch_hdim_init (tsfc, errmsg, errflg) + subroutine mismatch_hdim_init(tsfc, errmsg, errflg) - real(kind_phys), intent(inout) :: tsfc(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(inout) :: tsfc(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - tsfc = tsfc+1.0_kind_phys + tsfc = tsfc + 1.0_kind_phys errmsg = '' errflg = 0 end subroutine mismatch_hdim_init -END MODULE mismatch_hdim +end module mismatch_hdim diff --git a/test/unit_tests/sample_scheme_files/mismatch_intent.F90 b/test/unit_tests/sample_scheme_files/mismatch_intent.F90 index abcf7bc0..7dee5298 100644 --- a/test/unit_tests/sample_scheme_files/mismatch_intent.F90 +++ b/test/unit_tests/sample_scheme_files/mismatch_intent.F90 @@ -1,33 +1,33 @@ ! Test parameterization with no vertical level ! -MODULE mismatch_intent +module mismatch_intent - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: mismatch_intent_init - PUBLIC :: mismatch_intent_run - PUBLIC :: mismatch_intent_finalize + public :: mismatch_intent_init + public :: mismatch_intent_run + public :: mismatch_intent_finalize -CONTAINS +contains !> \section arg_table_mismatch_intent_run Argument Table !! \htmlinclude arg_table_mismatch_intent_run.html !! - subroutine mismatch_intent_run(foo, timestep, temp_prev, temp_layer, qv, ps, & - errmsg, errflg) - - integer, intent(in) :: foo - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(inout) :: qv(:) - real(kind_phys), intent(inout) :: ps(:) - REAL(kind_phys), intent(in) :: temp_prev(:) - REAL(kind_phys), intent(inout) :: temp_layer(foo) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + subroutine mismatch_intent_run(foo, timestep, temp_prev, temp_layer, qv, ps, & + errmsg, errflg) + + integer, intent(in) :: foo + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(inout) :: qv(:) + real(kind=kind_phys), intent(inout) :: ps(:) + real(kind=kind_phys), intent(in) :: temp_prev(:) + real(kind=kind_phys), intent(inout) :: temp_layer(foo) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg !---------------------------------------------------------------- integer :: col_index @@ -36,19 +36,19 @@ subroutine mismatch_intent_run(foo, timestep, temp_prev, temp_layer, qv, ps, errflg = 0 do col_index = 1, foo - temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) - qv(col_index) = qv(col_index) + 1.0_kind_phys + temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) + qv(col_index) = qv(col_index) + 1.0_kind_phys end do - END SUBROUTINE mismatch_intent_run + end subroutine mismatch_intent_run !> \section arg_table_mismatch_intent_init Argument Table !! \htmlinclude arg_table_mismatch_intent_init.html !! - subroutine mismatch_intent_init (errmsg, errflg) + subroutine mismatch_intent_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 @@ -60,10 +60,10 @@ end subroutine mismatch_intent_init !> \section arg_table_mismatch_intent_finalize Argument Table !! \htmlinclude arg_table_mismatch_intent_finalize.html !! - subroutine mismatch_intent_finalize (errmsg, errflg) + subroutine mismatch_intent_finalize(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 @@ -72,4 +72,4 @@ subroutine mismatch_intent_finalize (errmsg, errflg) end subroutine mismatch_intent_finalize -END MODULE mismatch_intent +end module mismatch_intent diff --git a/test/unit_tests/sample_scheme_files/missing_arg_table.F90 b/test/unit_tests/sample_scheme_files/missing_arg_table.F90 index 9d0a02af..cd4915f8 100644 --- a/test/unit_tests/sample_scheme_files/missing_arg_table.F90 +++ b/test/unit_tests/sample_scheme_files/missing_arg_table.F90 @@ -1,33 +1,33 @@ ! Test parameterization with no vertical level ! -MODULE missing_arg_table +module missing_arg_table - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: missing_arg_table_init - PUBLIC :: missing_arg_table_run - PUBLIC :: missing_arg_table_finalize + public :: missing_arg_table_init + public :: missing_arg_table_run + public :: missing_arg_table_finalize -CONTAINS +contains !> \section arg_table_missing_arg_table_run Argument Table !! \htmlinclude arg_table_missing_arg_table_run.html !! - subroutine missing_arg_table_run(foo, timestep, temp_prev, temp_layer, qv, ps, & - errmsg, errflg) - - integer, intent(in) :: foo - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(inout) :: qv(:) - real(kind_phys), intent(inout) :: ps(:) - REAL(kind_phys), intent(in) :: temp_prev(:) - REAL(kind_phys), intent(inout) :: temp_layer(foo) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + subroutine missing_arg_table_run(foo, timestep, temp_prev, temp_layer, qv, ps, & + errmsg, errflg) + + integer, intent(in) :: foo + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(inout) :: qv(:) + real(kind=kind_phys), intent(inout) :: ps(:) + real(kind=kind_phys), intent(in) :: temp_prev(:) + real(kind=kind_phys), intent(inout) :: temp_layer(foo) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg !---------------------------------------------------------------- integer :: col_index @@ -36,19 +36,19 @@ subroutine missing_arg_table_run(foo, timestep, temp_prev, temp_layer, qv, ps, errflg = 0 do col_index = 1, foo - temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) - qv(col_index) = qv(col_index) + 1.0_kind_phys + temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) + qv(col_index) = qv(col_index) + 1.0_kind_phys end do - END SUBROUTINE missing_arg_table_run + end subroutine missing_arg_table_run !> \section arg_table_missing_arg_table_init Argument Table !! \htmlinclude arg_table_missing_arg_table_init.html !! - subroutine missing_arg_table_init (errmsg, errflg) + subroutine missing_arg_table_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 @@ -60,10 +60,10 @@ end subroutine missing_arg_table_init !> \section arg_table_missing_arg_table_finalize Argument Table !! \htmlinclude arg_table_missing_arg_table_finalize.html !! - subroutine missing_arg_table_finalize (errmsg, errflg) + subroutine missing_arg_table_finalize(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 @@ -72,4 +72,4 @@ subroutine missing_arg_table_finalize (errmsg, errflg) end subroutine missing_arg_table_finalize -END MODULE missing_arg_table +end module missing_arg_table diff --git a/test/unit_tests/sample_scheme_files/missing_fort_header.F90 b/test/unit_tests/sample_scheme_files/missing_fort_header.F90 index 92981eb5..ee6e2ae5 100644 --- a/test/unit_tests/sample_scheme_files/missing_fort_header.F90 +++ b/test/unit_tests/sample_scheme_files/missing_fort_header.F90 @@ -1,33 +1,33 @@ ! Test parameterization with no vertical level ! -MODULE missing_fort_header +module missing_fort_header - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: missing_fort_header_init - PUBLIC :: missing_fort_header_run - PUBLIC :: missing_fort_header_finalize + public :: missing_fort_header_init + public :: missing_fort_header_run + public :: missing_fort_header_finalize -CONTAINS +contains !> \section fort_header_missing_arg_table_run Argument Table !! \htmlinclude fort_header_missing_arg_table_run.html !! - subroutine missing_fort_header_run(foo, timestep, temp_prev, temp_layer, qv, ps, & - errmsg, errflg) - - integer, intent(in) :: foo - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(inout) :: qv(:) - real(kind_phys), intent(inout) :: ps(:) - REAL(kind_phys), intent(in) :: temp_prev(:) - REAL(kind_phys), intent(inout) :: temp_layer(foo) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + subroutine missing_fort_header_run(foo, timestep, temp_prev, temp_layer, qv, ps, & + errmsg, errflg) + + integer, intent(in) :: foo + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(inout) :: qv(:) + real(kind=kind_phys), intent(inout) :: ps(:) + real(kind=kind_phys), intent(in) :: temp_prev(:) + real(kind=kind_phys), intent(inout) :: temp_layer(foo) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg !---------------------------------------------------------------- integer :: col_index @@ -36,19 +36,19 @@ subroutine missing_fort_header_run(foo, timestep, temp_prev, temp_layer, qv, ps, errflg = 0 do col_index = 1, foo - temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) - qv(col_index) = qv(col_index) + 1.0_kind_phys + temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) + qv(col_index) = qv(col_index) + 1.0_kind_phys end do - END SUBROUTINE missing_fort_header_run + end subroutine missing_fort_header_run !> \section fort_header_missing_arg_table_init Argument Table !! \htmlinclude fort_header_missing_arg_table_init.html !! - subroutine missing_fort_header_init (errmsg, errflg) + subroutine missing_fort_header_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 @@ -58,10 +58,10 @@ subroutine missing_fort_header_init (errmsg, errflg) end subroutine missing_fort_header_init !! - subroutine missing_fort_header_finalize (errmsg, errflg) + subroutine missing_fort_header_finalize(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 @@ -70,4 +70,4 @@ subroutine missing_fort_header_finalize (errmsg, errflg) end subroutine missing_fort_header_finalize -END MODULE missing_fort_header +end module missing_fort_header diff --git a/test/unit_tests/sample_scheme_files/reorder.F90 b/test/unit_tests/sample_scheme_files/reorder.F90 index d3c92530..61151975 100644 --- a/test/unit_tests/sample_scheme_files/reorder.F90 +++ b/test/unit_tests/sample_scheme_files/reorder.F90 @@ -1,30 +1,30 @@ -MODULE reorder +module reorder - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: reorder_init - PUBLIC :: reorder_run - PUBLIC :: reorder_finalize + public :: reorder_init + public :: reorder_run + public :: reorder_finalize -CONTAINS +contains !> \section arg_table_reorder_run Argument Table !! \htmlinclude arg_table_reorder_run.html !! - subroutine reorder_run(foo, timestep, temp_prev, temp_layer, qv, ps, & - errmsg, errflg) - - integer, intent(in) :: foo - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(inout) :: qv(:) - real(kind_phys), intent(inout) :: ps(:) - REAL(kind_phys), intent(in) :: temp_prev(:) - REAL(kind_phys), intent(inout) :: temp_layer(foo) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + subroutine reorder_run(foo, timestep, temp_prev, temp_layer, qv, ps, & + errmsg, errflg) + + integer, intent(in) :: foo + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(inout) :: qv(:) + real(kind=kind_phys), intent(inout) :: ps(:) + real(kind=kind_phys), intent(in) :: temp_prev(:) + real(kind=kind_phys), intent(inout) :: temp_layer(foo) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg !---------------------------------------------------------------- integer :: col_index @@ -33,19 +33,19 @@ subroutine reorder_run(foo, timestep, temp_prev, temp_layer, qv, ps, & errflg = 0 do col_index = 1, foo - temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) - qv(col_index) = qv(col_index) + 1.0_kind_phys + temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) + qv(col_index) = qv(col_index) + 1.0_kind_phys end do - END SUBROUTINE reorder_run + end subroutine reorder_run !> \section arg_table_reorder_init Argument Table !! \htmlinclude arg_table_reorder_init.html !! - subroutine reorder_init (errmsg, errflg) + subroutine reorder_init(errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 @@ -55,14 +55,14 @@ end subroutine reorder_init !> \section arg_table_reorder_finalize Argument Table !! \htmlinclude arg_table_reorder_finalize.html !! - subroutine reorder_finalize (errmsg, errflg) + subroutine reorder_finalize(errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 end subroutine reorder_finalize -END MODULE reorder +end module reorder diff --git a/test/unit_tests/sample_scheme_files/temp_adjust.F90 b/test/unit_tests/sample_scheme_files/temp_adjust.F90 index 70613ba1..0ebaf0f8 100644 --- a/test/unit_tests/sample_scheme_files/temp_adjust.F90 +++ b/test/unit_tests/sample_scheme_files/temp_adjust.F90 @@ -1,54 +1,54 @@ ! Test parameterization with no vertical level ! -MODULE temp_adjust +module temp_adjust - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: temp_adjust_init - PUBLIC :: temp_adjust_run - PUBLIC :: temp_adjust_finalize + public :: temp_adjust_init + public :: temp_adjust_run + public :: temp_adjust_finalize -CONTAINS +contains !> \section arg_table_temp_adjust_register Argument Table !! \htmlinclude arg_table_temp_adjust_register.html !! subroutine temp_adjust_register(config_var, dyn_const, errflg, errmsg) - logical, intent(in) :: config_var - type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + logical, intent(in) :: config_var + type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - if (.not. config_var) then - return - end if + if ( .not. config_var) then + return + end if - allocate(dyn_const(1)) - call dyn_const(1)%instantiate(std_name="dyn_const", long_name='dyn const', & - diag_name='DYNCONST', units='kg kg-1', default_value=1._kind_phys, & - vertical_dim='vertical_layer_dimension', advected=.true., & - errcode=errflg, errmsg=errmsg) + allocate(dyn_const(1)) + call dyn_const(1)%instantiate(std_name="dyn_const", long_name='dyn const', & + diag_name='DYNCONST', units='kg kg-1', default_value=1._kind_phys, & + vertical_dim='vertical_layer_dimension', advected=.true., & + errcode=errflg, errmsg=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, temp_prev, temp_layer, qv, ps, & - errmsg, errflg) - - integer, intent(in) :: foo - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(inout) :: qv(:) - real(kind_phys), intent(inout) :: ps(:) - REAL(kind_phys), intent(in) :: temp_prev(:) - REAL(kind_phys), intent(inout) :: temp_layer(foo) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + subroutine temp_adjust_run(foo, timestep, temp_prev, temp_layer, qv, ps, & + errmsg, errflg) + + integer, intent(in) :: foo + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(inout) :: qv(:) + real(kind=kind_phys), intent(inout) :: ps(:) + real(kind=kind_phys), intent(in) :: temp_prev(:) + real(kind=kind_phys), intent(inout) :: temp_layer(foo) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg !---------------------------------------------------------------- integer :: col_index @@ -57,19 +57,19 @@ subroutine temp_adjust_run(foo, timestep, temp_prev, temp_layer, qv, ps, & errflg = 0 do col_index = 1, foo - temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) - qv(col_index) = qv(col_index) + 1.0_kind_phys + temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) + qv(col_index) = qv(col_index) + 1.0_kind_phys end do - 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 @@ -81,10 +81,10 @@ end subroutine temp_adjust_init !> \section arg_table_temp_adjust_finalize Argument Table !! \htmlinclude arg_table_temp_adjust_finalize.html !! - subroutine temp_adjust_finalize (errmsg, errflg) + subroutine temp_adjust_finalize(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 @@ -93,4 +93,4 @@ subroutine temp_adjust_finalize (errmsg, errflg) end subroutine temp_adjust_finalize -END MODULE temp_adjust +end module temp_adjust diff --git a/test/utils/test_utils.F90 b/test/utils/test_utils.F90 index 088c347d..0f87db5e 100644 --- a/test/utils/test_utils.F90 +++ b/test/utils/test_utils.F90 @@ -1,88 +1,88 @@ module test_utils - public :: check_list + public :: check_list contains - logical function check_list(test_list, chk_list, list_desc, suite_name) + logical function check_list(test_list, chk_list, list_desc, suite_name) ! Check a list () against its expected value () - ! Dummy arguments - character(len=*), intent(in) :: test_list(:) - character(len=*), intent(in) :: chk_list(:) - character(len=*), intent(in) :: list_desc - character(len=*), optional, intent(in) :: suite_name + ! Dummy arguments + character(len=*), intent(in) :: test_list(:) + character(len=*), intent(in) :: chk_list(:) + character(len=*), intent(in) :: list_desc + character(len=*), optional, intent(in) :: suite_name - ! Local variables - logical :: found - integer :: num_items - integer :: lindex, tindex - integer, allocatable :: check_unique(:) - character(len=2) :: sep - character(len=256) :: errmsg + ! Local variables + logical :: found + integer :: num_items + integer :: lindex, tindex + integer, allocatable :: check_unique(:) + character(len=2) :: sep + character(len=256) :: errmsg - check_list = .true. - errmsg = '' + check_list = .true. + errmsg = '' - ! Check the list size - num_items = size(chk_list) - if (size(test_list) /= num_items) then - write(errmsg, '(a,i0,2a)') 'ERROR: Found ', size(test_list), & - ' ', trim(list_desc) - if (present(suite_name)) then - write(errmsg(len_trim(errmsg)+1:), '(2a)') ' for suite, ', & - trim(suite_name) - end if - write(errmsg(len_trim(errmsg)+1:), '(a,i0)') ', should be ', num_items - write(6, *) trim(errmsg) - errmsg = '' - check_list = .false. - end if + ! Check the list size + num_items = size(chk_list) + if (size(test_list) /= num_items) then + write(errmsg, '(a,i0,2a)') 'ERROR: Found ', size(test_list), & + ' ', trim(list_desc) + if (present(suite_name)) then + write(errmsg(len_trim(errmsg) + 1:), '(2a)') ' for suite, ', & + trim(suite_name) + end if + write(errmsg(len_trim(errmsg) + 1:), '(a,i0)') ', should be ', num_items + write(6, *) trim(errmsg) + errmsg = '' + check_list = .false. + end if - ! Now, check the list contents for 1-1 correspondence - if (check_list) then - allocate(check_unique(num_items)) - check_unique = -1 - do lindex = 1, num_items - found = .false. - do tindex = 1, num_items - if (trim(test_list(lindex)) == trim(chk_list(tindex))) then - check_unique(tindex) = lindex - found = .true. - exit - end if - end do - if (.not. found) then - check_list = .false. - write(errmsg, '(5a)') 'ERROR: ', trim(list_desc), ' item, ', & - trim(test_list(lindex)), ', was not found' - if (present(suite_name)) then - write(errmsg(len_trim(errmsg)+1:), '(2a)') ' in suite, ', & - trim(suite_name) - end if - write(6, *) trim(errmsg) - errmsg = '' - end if - end do - if (check_list .and. any(check_unique < 0)) then - check_list = .false. - write(errmsg, '(3a)') 'ERROR: The following ', trim(list_desc), & - ' items were not found' - if (present(suite_name)) then - write(errmsg(len_trim(errmsg)+1:), '(2a)') ' in suite, ', & - trim(suite_name) - end if - sep = '; ' - do lindex = 1, num_items - if (check_unique(lindex) < 0) then - write(errmsg(len_trim(errmsg)+1:), '(2a)') sep, & - trim(chk_list(lindex)) - sep = ', ' - end if - end do - write(6, *) trim(errmsg) - errmsg = '' - end if + ! Now, check the list contents for 1-1 correspondence + if (check_list) then + allocate(check_unique(num_items)) + check_unique = -1 + do lindex = 1, num_items + found = .false. + do tindex = 1, num_items + if (trim(test_list(lindex)) == trim(chk_list(tindex))) then + check_unique(tindex) = lindex + found = .true. + exit + end if + end do + if ( .not. found) then + check_list = .false. + write(errmsg, '(5a)') 'ERROR: ', trim(list_desc), ' item, ', & + trim(test_list(lindex)), ', was not found' + if (present(suite_name)) then + write(errmsg(len_trim(errmsg) + 1:), '(2a)') ' in suite, ', & + trim(suite_name) + end if + write(6, *) trim(errmsg) + errmsg = '' end if + end do + if (check_list .and. any(check_unique < 0)) then + check_list = .false. + write(errmsg, '(3a)') 'ERROR: The following ', trim(list_desc), & + ' items were not found' + if (present(suite_name)) then + write(errmsg(len_trim(errmsg) + 1:), '(2a)') ' in suite, ', & + trim(suite_name) + end if + sep = '; ' + do lindex = 1, num_items + if (check_unique(lindex) < 0) then + write(errmsg(len_trim(errmsg) + 1:), '(2a)') sep, & + trim(chk_list(lindex)) + sep = ', ' + end if + end do + write(6, *) trim(errmsg) + errmsg = '' + end if + end if - end function check_list + end function check_list end module test_utils diff --git a/test/var_compatibility_test/effr_calc.F90 b/test/var_compatibility_test/effr_calc.F90 index 0b626c16..b8fc43ed 100644 --- a/test/var_compatibility_test/effr_calc.F90 +++ b/test/var_compatibility_test/effr_calc.F90 @@ -3,82 +3,82 @@ module effr_calc - use ccpp_kinds, only: kind_phys - - implicit none - private - - public :: effr_calc_run, effr_calc_init - - contains - !> \section arg_table_effr_calc_init Argument Table - !! \htmlinclude arg_table_effr_calc_init.html - !! - subroutine effr_calc_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order .ne. 2) then - errflg = 1 - errmsg = 'ERROR: effr_calc_init() needs to be called second' - return - else - scheme_order = scheme_order + 1 - endif - - end subroutine effr_calc_init - - !> \section arg_table_effr_calc_run Argument Table - !! \htmlinclude arg_table_effr_calc_run.html - !! - subroutine effr_calc_run(ncol, nlev, effrr_in, effrg_in, ncg_in, nci_out, & - effrl_inout, effri_out, effrs_inout, ncl_out, & - has_graupel, scalar_var, tke_inout, tke2_inout, & - errmsg, errflg) - - integer, intent(in) :: ncol - integer, intent(in) :: nlev - real(kind_phys), intent(in) :: effrr_in(:,:) - real(kind_phys), intent(in),optional :: effrg_in(:,:) - real(kind_phys), intent(in),optional :: ncg_in(:,:) - real(kind_phys), intent(out),optional :: nci_out(:,:) - real(kind_phys), intent(inout) :: effrl_inout(:,:) - real(kind_phys), intent(out),optional :: effri_out(:,:) - real(8),intent(inout) :: effrs_inout(:,:) - logical, intent(in) :: has_graupel - real(kind_phys), intent(inout) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - real(kind_phys), intent(out),optional :: ncl_out(:,:) - real(kind_phys), intent(inout) :: tke_inout - real(kind_phys), intent(inout) :: tke2_inout - - !---------------------------------------------------------------- - - real(kind_phys), parameter :: re_qc_min = 2.5 ! microns - real(kind_phys), parameter :: re_qc_max = 50. ! microns - real(kind_phys), parameter :: re_qi_avg = 75. ! microns - real(kind_phys) :: effrr_local(ncol,nlev) - real(kind_phys) :: effrg_local(ncol,nlev) - real(kind_phys) :: ncg_in_local(ncol,nlev) - real(kind_phys) :: nci_out_local(ncol,nlev) - - errmsg = '' - errflg = 0 - - effrr_local = effrr_in - if (present(effrg_in)) effrg_local = effrg_in - if (present(ncg_in)) ncg_in_local = ncg_in - if (present(nci_out)) nci_out_local = nci_out - effrl_inout = min(max(effrl_inout,re_qc_min),re_qc_max) - if (present(effri_out)) effri_out = re_qi_avg - effrs_inout = effrs_inout + (10.0 / 6.0) ! in micrometer - scalar_var = 2.0 ! in km - - end subroutine effr_calc_run + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: effr_calc_run, effr_calc_init + +contains + !> \section arg_table_effr_calc_init Argument Table + !! \htmlinclude arg_table_effr_calc_init.html + !! + subroutine effr_calc_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order /= 2) then + errflg = 1 + errmsg = 'ERROR: effr_calc_init() needs to be called second' + return + else + scheme_order = scheme_order + 1 + end if + + end subroutine effr_calc_init + + !> \section arg_table_effr_calc_run Argument Table + !! \htmlinclude arg_table_effr_calc_run.html + !! + subroutine effr_calc_run(ncol, nlev, effrr_in, effrg_in, ncg_in, nci_out, & + effrl_inout, effri_out, effrs_inout, ncl_out, & + has_graupel, scalar_var, tke_inout, tke2_inout, & + errmsg, errflg) + + integer, intent(in) :: ncol + integer, intent(in) :: nlev + real(kind=kind_phys), intent(in) :: effrr_in(:, :) + real(kind=kind_phys), intent(in), optional :: effrg_in(:, :) + real(kind=kind_phys), intent(in), optional :: ncg_in(:, :) + real(kind=kind_phys), intent(out), optional :: nci_out(:, :) + real(kind=kind_phys), intent(inout) :: effrl_inout(:, :) + real(kind=kind_phys), intent(out), optional :: effri_out(:, :) + real(kind=8), intent(inout) :: effrs_inout(:, :) + logical, intent(in) :: has_graupel + real(kind=kind_phys), intent(inout) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind=kind_phys), intent(out), optional :: ncl_out(:, :) + real(kind=kind_phys), intent(inout) :: tke_inout + real(kind=kind_phys), intent(inout) :: tke2_inout + + !---------------------------------------------------------------- + + real(kind=kind_phys), parameter :: re_qc_min = 2.5 ! microns + real(kind=kind_phys), parameter :: re_qc_max = 50. ! microns + real(kind=kind_phys), parameter :: re_qi_avg = 75. ! microns + real(kind=kind_phys) :: effrr_local(ncol, nlev) + real(kind=kind_phys) :: effrg_local(ncol, nlev) + real(kind=kind_phys) :: ncg_in_local(ncol, nlev) + real(kind=kind_phys) :: nci_out_local(ncol, nlev) + + errmsg = '' + errflg = 0 + + effrr_local = effrr_in + if (present(effrg_in)) effrg_local = effrg_in + if (present(ncg_in)) ncg_in_local = ncg_in + if (present(nci_out)) nci_out_local = nci_out + effrl_inout = min(max(effrl_inout, re_qc_min), re_qc_max) + if (present(effri_out)) effri_out = re_qi_avg + effrs_inout = effrs_inout + (10.0 / 6.0) ! in micrometer + scalar_var = 2.0 ! in km + + end subroutine effr_calc_run end module effr_calc diff --git a/test/var_compatibility_test/effr_diag.F90 b/test/var_compatibility_test/effr_diag.F90 index 409ff2f9..75da29c7 100644 --- a/test/var_compatibility_test/effr_diag.F90 +++ b/test/var_compatibility_test/effr_diag.F90 @@ -3,12 +3,12 @@ module effr_diag - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_diag_run, effr_diag_init + public :: effr_diag_run, effr_diag_init contains @@ -16,53 +16,53 @@ module effr_diag !! \htmlinclude arg_table_effr_diag_init.html !! subroutine effr_diag_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + errmsg = '' errflg = 0 - if (scheme_order .ne. 4) then - errflg = 1 - errmsg = 'ERROR: effr_diag_init() needs to be called fourth' - return - else - scheme_order = scheme_order + 1 - endif + if (scheme_order /= 4) then + errflg = 1 + errmsg = 'ERROR: effr_diag_init() needs to be called fourth' + return + else + scheme_order = scheme_order + 1 + end if end subroutine effr_diag_init - !> \section arg_table_effr_diag_run Argument Table - !! \htmlinclude arg_table_effr_diag_run.html - !! - subroutine effr_diag_run( effrr_in, scalar_var, errmsg, errflg) - - real(kind_phys), intent(in) :: effrr_in(:,:) - integer, intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - call cmp_effr_diag(effrr_in, effrr_min, effrr_max) - - if (scalar_var .ne. 380) then - errmsg = 'ERROR: effr_diag_run(): scalar_var should be 380' - errflg = 1 - endif - end subroutine effr_diag_run - - subroutine cmp_effr_diag(effr, effr_min, effr_max) - real(kind_phys), intent(in) :: effr(:,:) - real(kind_phys), intent(out) :: effr_min, effr_max - - ! Do some diagnostic calcualtions... - effr_min = minval(effr) - effr_max = maxval(effr) - - end subroutine cmp_effr_diag + !> \section arg_table_effr_diag_run Argument Table + !! \htmlinclude arg_table_effr_diag_run.html + !! + subroutine effr_diag_run(effrr_in, scalar_var, errmsg, errflg) + + real(kind=kind_phys), intent(in) :: effrr_in(:, :) + integer, intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind=kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + call cmp_effr_diag(effrr_in, effrr_min, effrr_max) + + if (scalar_var /= 380) then + errmsg = 'ERROR: effr_diag_run(): scalar_var should be 380' + errflg = 1 + end if + end subroutine effr_diag_run + + subroutine cmp_effr_diag(effr, effr_min, effr_max) + real(kind=kind_phys), intent(in) :: effr(:, :) + real(kind=kind_phys), intent(out) :: effr_min, effr_max + + ! Do some diagnostic calcualtions... + effr_min = minval(effr) + effr_max = maxval(effr) + + end subroutine cmp_effr_diag end module effr_diag diff --git a/test/var_compatibility_test/effr_post.F90 b/test/var_compatibility_test/effr_post.F90 index d42a574c..01357350 100644 --- a/test/var_compatibility_test/effr_post.F90 +++ b/test/var_compatibility_test/effr_post.F90 @@ -3,59 +3,59 @@ module effr_post - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_post_run, effr_post_init + public :: effr_post_run, effr_post_init contains - !> \section arg_table_effr_post_init Argument Table - !! \htmlinclude arg_table_effr_post_init.html - !! - subroutine effr_post_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order .ne. 3) then - errflg = 1 - errmsg = 'ERROR: effr_post_init() needs to be called third' - return - else - scheme_order = scheme_order + 1 - endif - - end subroutine effr_post_init - - !> \section arg_table_effr_post_run Argument Table - !! \htmlinclude arg_table_effr_post_run.html - !! - subroutine effr_post_run( effrr_inout, scalar_var, errmsg, errflg) - - real(kind_phys), intent(inout) :: effrr_inout(:,:) - real(kind_phys), intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - ! Do some post-processing on effrr... - effrr_inout(:,:) = effrr_inout(:,:)*1._kind_phys - - if (scalar_var .ne. 1013.0) then - errmsg = 'ERROR: effr_post_run(): scalar_var should be 1013.0' - errflg = 1 - endif - - end subroutine effr_post_run - - end module effr_post + !> \section arg_table_effr_post_init Argument Table + !! \htmlinclude arg_table_effr_post_init.html + !! + subroutine effr_post_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order /= 3) then + errflg = 1 + errmsg = 'ERROR: effr_post_init() needs to be called third' + return + else + scheme_order = scheme_order + 1 + end if + + end subroutine effr_post_init + + !> \section arg_table_effr_post_run Argument Table + !! \htmlinclude arg_table_effr_post_run.html + !! + subroutine effr_post_run(effrr_inout, scalar_var, errmsg, errflg) + + real(kind=kind_phys), intent(inout) :: effrr_inout(:, :) + real(kind=kind_phys), intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind=kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + ! Do some post-processing on effrr... + effrr_inout(:, :) = effrr_inout(:, :) * 1._kind_phys + + if (scalar_var /= 1013.0) then + errmsg = 'ERROR: effr_post_run(): scalar_var should be 1013.0' + errflg = 1 + end if + + end subroutine effr_post_run + +end module effr_post diff --git a/test/var_compatibility_test/effr_pre.F90 b/test/var_compatibility_test/effr_pre.F90 index 17a3b187..a2fe2f5c 100644 --- a/test/var_compatibility_test/effr_pre.F90 +++ b/test/var_compatibility_test/effr_pre.F90 @@ -3,58 +3,58 @@ module mod_effr_pre - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_pre_run, effr_pre_init + public :: effr_pre_run, effr_pre_init contains - !> \section arg_table_effr_pre_init Argument Table - !! \htmlinclude arg_table_effr_pre_init.html - !! - subroutine effr_pre_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order .ne. 1) then - errflg = 1 - errmsg = 'ERROR: effr_pre_init() needs to be called first' - return - else - scheme_order = scheme_order + 1 - endif - - end subroutine effr_pre_init - - !> \section arg_table_effr_pre_run Argument Table - !! \htmlinclude arg_table_effr_pre_run.html - !! - subroutine effr_pre_run( effrr_inout, scalar_var, errmsg, errflg) - - real(kind_phys), intent(inout) :: effrr_inout(:,:) - real(kind_phys), intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - ! Do some pre-processing on effrr... - effrr_inout(:,:) = effrr_inout(:,:)*1._kind_phys - - if (scalar_var .ne. 273.15) then - errmsg = 'ERROR: effr_pre_run(): scalar_var should be 273.15' - errflg = 1 - endif - - end subroutine effr_pre_run + !> \section arg_table_effr_pre_init Argument Table + !! \htmlinclude arg_table_effr_pre_init.html + !! + subroutine effr_pre_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order /= 1) then + errflg = 1 + errmsg = 'ERROR: effr_pre_init() needs to be called first' + return + else + scheme_order = scheme_order + 1 + end if + + end subroutine effr_pre_init + + !> \section arg_table_effr_pre_run Argument Table + !! \htmlinclude arg_table_effr_pre_run.html + !! + subroutine effr_pre_run(effrr_inout, scalar_var, errmsg, errflg) + + real(kind=kind_phys), intent(inout) :: effrr_inout(:, :) + real(kind=kind_phys), intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind=kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + ! Do some pre-processing on effrr... + effrr_inout(:, :) = effrr_inout(:, :) * 1._kind_phys + + if (scalar_var /= 273.15) then + errmsg = 'ERROR: effr_pre_run(): scalar_var should be 273.15' + errflg = 1 + end if + + end subroutine effr_pre_run end module mod_effr_pre diff --git a/test/var_compatibility_test/effrs_calc.F90 b/test/var_compatibility_test/effrs_calc.F90 index e9266905..3aa8d196 100644 --- a/test/var_compatibility_test/effrs_calc.F90 +++ b/test/var_compatibility_test/effrs_calc.F90 @@ -3,30 +3,30 @@ module effrs_calc - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effrs_calc_run + public :: effrs_calc_run - contains - !> \section arg_table_effrs_calc_run Argument Table - !! \htmlinclude arg_table_effrs_calc_run.html - !! - subroutine effrs_calc_run(effrs_inout, errmsg, errflg) +contains + !> \section arg_table_effrs_calc_run Argument Table + !! \htmlinclude arg_table_effrs_calc_run.html + !! + subroutine effrs_calc_run(effrs_inout, errmsg, errflg) - real(kind_phys), intent(inout) :: effrs_inout(:,:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(inout) :: effrs_inout(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - !---------------------------------------------------------------- + !---------------------------------------------------------------- - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 - effrs_inout = effrs_inout + (10.E-6_kind_phys / 3._kind_phys) ! in meters + effrs_inout = effrs_inout + (10.E-6_kind_phys / 3._kind_phys) ! in meters - end subroutine effrs_calc_run + end subroutine effrs_calc_run end module effrs_calc diff --git a/test/var_compatibility_test/module_rad_ddt.F90 b/test/var_compatibility_test/module_rad_ddt.F90 index 21a1a0ec..6e992250 100644 --- a/test/var_compatibility_test/module_rad_ddt.F90 +++ b/test/var_compatibility_test/module_rad_ddt.F90 @@ -1,5 +1,5 @@ module mod_rad_ddt - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys implicit none public ty_rad_lw, ty_rad_sw @@ -8,16 +8,16 @@ module mod_rad_ddt !! \htmlinclude arg_table_ty_rad_lw.html !! type ty_rad_lw - real(kind_phys) :: sfc_up_lw - real(kind_phys) :: sfc_down_lw + real(kind=kind_phys) :: sfc_up_lw + real(kind=kind_phys) :: sfc_down_lw end type ty_rad_lw !> \section arg_table_ty_rad_sw Argument Table !! \htmlinclude arg_table_ty_rad_sw.html !! type ty_rad_sw - real(kind_phys), pointer :: sfc_up_sw(:) => null() - real(kind_phys), pointer :: sfc_down_sw(:) => null() + real(kind=kind_phys), pointer :: sfc_up_sw(:) => null() + real(kind=kind_phys), pointer :: sfc_down_sw(:) => null() end type ty_rad_sw end module mod_rad_ddt diff --git a/test/var_compatibility_test/rad_lw.F90 b/test/var_compatibility_test/rad_lw.F90 index 5859f8bf..ded4861f 100644 --- a/test/var_compatibility_test/rad_lw.F90 +++ b/test/var_compatibility_test/rad_lw.F90 @@ -12,12 +12,12 @@ module rad_lw !> \section arg_table_rad_lw_run Argument Table !! \htmlinclude arg_table_rad_lw_run.html !! - subroutine rad_lw_run(ncol, fluxLW, errmsg, errflg) + subroutine rad_lw_run(ncol, fluxlw, errmsg, errflg) - integer, intent(in) :: ncol - type(ty_rad_lw), intent(inout) :: fluxLW(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + type(ty_rad_lw), intent(inout) :: fluxlw(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg ! Locals integer :: icol @@ -25,10 +25,10 @@ subroutine rad_lw_run(ncol, fluxLW, errmsg, errflg) errmsg = '' errflg = 0 - do icol=1,ncol - fluxLW(icol)%sfc_up_lw = 300._kind_phys - fluxLW(icol)%sfc_down_lw = 50._kind_phys - enddo + do icol = 1, ncol + fluxlw(icol)%sfc_up_lw = 300._kind_phys + fluxlw(icol)%sfc_down_lw = 50._kind_phys + end do end subroutine rad_lw_run diff --git a/test/var_compatibility_test/rad_sw.F90 b/test/var_compatibility_test/rad_sw.F90 index ddf35224..64756217 100644 --- a/test/var_compatibility_test/rad_sw.F90 +++ b/test/var_compatibility_test/rad_sw.F90 @@ -13,11 +13,11 @@ module rad_sw !! subroutine rad_sw_run(ncol, sfc_up_sw, sfc_down_sw, errmsg, errflg) - integer, intent(in) :: ncol - real(kind_phys), intent(inout) :: sfc_up_sw(:) - real(kind_phys), intent(inout) :: sfc_down_sw(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + real(kind=kind_phys), intent(inout) :: sfc_up_sw(:) + real(kind=kind_phys), intent(inout) :: sfc_down_sw(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg ! Locals integer :: icol @@ -25,10 +25,10 @@ subroutine rad_sw_run(ncol, sfc_up_sw, sfc_down_sw, errmsg, errflg) errmsg = '' errflg = 0 - do icol=1,ncol - sfc_up_sw(icol) = 100._kind_phys - sfc_down_sw(icol) = 400._kind_phys - enddo + do icol = 1, ncol + sfc_up_sw(icol) = 100._kind_phys + sfc_down_sw(icol) = 400._kind_phys + end do end subroutine rad_sw_run diff --git a/test/var_compatibility_test/test_host.F90 b/test/var_compatibility_test/test_host.F90 index f3a389e8..5d165305 100644 --- a/test/var_compatibility_test/test_host.F90 +++ b/test/var_compatibility_test/test_host.F90 @@ -1,264 +1,264 @@ 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 = 32 - integer, public, parameter :: cm = 60 + ! Public data and interfaces + integer, public, parameter :: cs = 32 + integer, public, parameter :: cm = 60 - !> \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) + use test_host_mod, only: ncols + 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 + use test_utils, only: check_list - use test_host_mod, only: ncols - 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 - 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 :: index, sind + 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 :: 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 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 - ! 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 - - ! 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 + ! 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 - 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 - 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 col_start = 1, ncols, 5 + if (errflg /= 0) then + exit + end if + col_end = min(col_start + 4, ncols) - do sind = 1, num_suites + 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 + exit end if if (errflg == 0) then - call test_host_ccpp_physics_timestep_final( & - test_suites(sind)%suite_name, errmsg, errflg) + 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, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(errmsg) - exit + 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 + 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 - if (errflg == 0) then - ! Run finished without error, check answers - if (compare_data()) then - write(6, *) 'Answers are correct!' - errflg = 0 - else - write(6, *) 'Answers are not correct!' - errflg = -1 - end if - end if + 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 (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/var_compatibility_test/test_host_data.F90 b/test/var_compatibility_test/test_host_data.F90 index c46bbfff..5389590f 100644 --- a/test/var_compatibility_test/test_host_data.F90 +++ b/test/var_compatibility_test/test_host_data.F90 @@ -1,32 +1,33 @@ module test_host_data - use ccpp_kinds, only: kind_phys - use mod_rad_ddt, only: ty_rad_lw, ty_rad_sw + use ccpp_kinds, only: kind_phys + use mod_rad_ddt, only: ty_rad_lw, & + ty_rad_sw - implicit none - private + implicit none + private !> \section arg_table_physics_state Argument Table !! \htmlinclude arg_table_physics_state.html type physics_state - real(kind_phys), dimension(:,:), allocatable :: & - effrr, & ! effective radius of cloud rain - effrl, & ! effective radius of cloud liquid water - effri, & ! effective radius of cloud ice - effrg, & ! effective radius of cloud graupel - ncg, & ! number concentration of cloud graupel - nci ! number concentration of cloud ice - real(kind_phys) :: scalar_var - type(ty_rad_lw), dimension(:), allocatable :: & - fluxLW ! Longwave radiation fluxes - type(ty_rad_sw) :: & - fluxSW ! Shortwave radiation fluxes - real(kind_phys) :: scalar_varA - real(kind_phys) :: scalar_varB - real(kind_phys) :: tke, tke2 - integer :: scalar_varC - integer :: scheme_order - integer :: num_subcycles + real(kind=kind_phys), dimension(:, :), allocatable :: & + effrr, & ! effective radius of cloud rain + effrl, & ! effective radius of cloud liquid water + effri, & ! effective radius of cloud ice + effrg, & ! effective radius of cloud graupel + ncg, & ! number concentration of cloud graupel + nci ! number concentration of cloud ice + real(kind=kind_phys) :: scalar_var + type(ty_rad_lw), dimension(:), allocatable :: & + fluxlw ! Longwave radiation fluxes + type(ty_rad_sw) :: & + fluxsw ! Shortwave radiation fluxes + real(kind=kind_phys) :: scalar_vara + real(kind=kind_phys) :: scalar_varb + real(kind=kind_phys) :: tke, tke2 + integer :: scalar_varc + integer :: scheme_order + integer :: num_subcycles end type physics_state public :: physics_state @@ -35,62 +36,62 @@ module test_host_data contains subroutine allocate_physics_state(cols, levels, state, has_graupel, has_ice) - integer, intent(in) :: cols - integer, intent(in) :: levels + integer, intent(in) :: cols + integer, intent(in) :: levels type(physics_state), intent(out) :: state - logical, intent(in) :: has_graupel - logical, intent(in) :: has_ice + logical, intent(in) :: has_graupel + logical, intent(in) :: has_ice if (allocated(state%effrr)) then - deallocate(state%effrr) + deallocate(state%effrr) end if allocate(state%effrr(cols, levels)) if (allocated(state%effrl)) then - deallocate(state%effrl) + deallocate(state%effrl) end if allocate(state%effrl(cols, levels)) if (has_ice) then - if (allocated(state%effri)) then - deallocate(state%effri) - end if - allocate(state%effri(cols, levels)) - endif + if (allocated(state%effri)) then + deallocate(state%effri) + end if + allocate(state%effri(cols, levels)) + end if if (has_graupel) then - if (allocated(state%effrg)) then - deallocate(state%effrg) - end if - allocate(state%effrg(cols, levels)) - - if (allocated(state%ncg)) then - deallocate(state%ncg) - end if - allocate(state%ncg(cols, levels)) - endif + if (allocated(state%effrg)) then + deallocate(state%effrg) + end if + allocate(state%effrg(cols, levels)) + + if (allocated(state%ncg)) then + deallocate(state%ncg) + end if + allocate(state%ncg(cols, levels)) + end if if (has_ice) then - if (allocated(state%nci)) then - deallocate(state%nci) - end if - allocate(state%nci(cols, levels)) - endif - - if (allocated(state%fluxLW)) then - deallocate(state%fluxLW) + if (allocated(state%nci)) then + deallocate(state%nci) + end if + allocate(state%nci(cols, levels)) + end if + + if (allocated(state%fluxlw)) then + deallocate(state%fluxlw) end if - allocate(state%fluxLW(cols)) + allocate(state%fluxlw(cols)) - if (associated(state%fluxSW%sfc_up_sw)) then - nullify(state%fluxSW%sfc_up_sw) + if (associated(state%fluxsw%sfc_up_sw)) then + nullify(state%fluxsw%sfc_up_sw) end if - allocate(state%fluxSW%sfc_up_sw(cols)) + allocate(state%fluxsw%sfc_up_sw(cols)) - if (associated(state%fluxSW%sfc_down_sw)) then - nullify(state%fluxSW%sfc_down_sw) + if (associated(state%fluxsw%sfc_down_sw)) then + nullify(state%fluxsw%sfc_down_sw) end if - allocate(state%fluxSW%sfc_down_sw(cols)) + allocate(state%fluxsw%sfc_down_sw(cols)) ! Initialize scheme counter. state%scheme_order = 1 diff --git a/test/var_compatibility_test/test_host_mod.F90 b/test/var_compatibility_test/test_host_mod.F90 index 09d1fdb5..33e4a858 100644 --- a/test/var_compatibility_test/test_host_mod.F90 +++ b/test/var_compatibility_test/test_host_mod.F90 @@ -1,23 +1,24 @@ 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 = 12 - integer, parameter :: pver = 4 - type(physics_state) :: phys_state - real(kind_phys) :: effrs(ncols, pver) - logical, parameter :: has_ice = .true. - logical, parameter :: has_graupel = .true. - - public :: init_data - public :: compare_data + 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 = 12 + integer, parameter :: pver = 4 + type(physics_state) :: phys_state + real(kind=kind_phys) :: effrs(ncols, pver) + logical, parameter :: has_ice = .true. + logical, parameter :: has_graupel = .true. + + public :: init_data + public :: compare_data contains @@ -27,19 +28,19 @@ subroutine init_data() call allocate_physics_state(ncols, pver, phys_state, has_graupel, has_ice) phys_state%effrr = 1.0E-3 ! 1000 microns, in meter phys_state%effrl = 1.0E-4 ! 100 microns, in meter - phys_state%scalar_var = 1.0 ! in m - phys_state%scalar_varA = 273.15 ! in K - phys_state%scalar_varB = 1013.0 ! in mb - phys_state%scalar_varC = 380 ! in ppmv - effrs = 5.0E-4 ! 500 microns, in meter + phys_state%scalar_var = 1.0 ! in m + phys_state%scalar_vara = 273.15 ! in K + phys_state%scalar_varb = 1013.0 ! in mb + phys_state%scalar_varc = 380 ! in ppmv + effrs = 5.0E-4 ! 500 microns, in meter if (has_graupel) then - phys_state%effrg = 2.5E-4 ! 250 microns, in meter - phys_state%ncg = 40 - endif + phys_state%effrg = 2.5E-4 ! 250 microns, in meter + phys_state%ncg = 40 + end if if (has_ice) then - phys_state%effri = 5.0E-5 ! 50 microns, in meter - phys_state%nci = 80 - endif + phys_state%effri = 5.0E-5 ! 50 microns, in meter + phys_state%nci = 80 + end if phys_state%tke = 10.0 !J kg-1 phys_state%tke2 = 42.0 !J kg-1 @@ -47,80 +48,85 @@ end subroutine init_data logical function compare_data() - real(kind_phys), parameter :: effrr_expected = 1.0E-3 ! 1000 microns, in meter - real(kind_phys), parameter :: effrl_expected = 5.0E-5 ! 50 microns, in meter - real(kind_phys), parameter :: effri_expected = 7.5E-5 ! 75 microns, in meter - real(kind_phys), parameter :: effrs_expected = 5.3E-4 ! 530 microns, in meter - real(kind_phys), parameter :: scalar_expected = 2.0E3 ! 2 km, in meter - real(kind_phys), parameter :: tke_expected = 10.0 ! 10 J kg-1 - real(kind_phys), parameter :: tolerance = 1.0E-6 ! used as scaling factor for expected value - real(kind_phys), parameter :: sfc_up_sw_expected = 100. ! W/m2 - real(kind_phys), parameter :: sfc_down_sw_expected = 400. ! W/m2 - real(kind_phys), parameter :: sfc_up_lw_expected = 300. ! W/m2 - real(kind_phys), parameter :: sfc_down_lw_expected = 50. ! W/m2 + real(kind=kind_phys), parameter :: effrr_expected = 1.0E-3 ! 1000 microns, in meter + real(kind=kind_phys), parameter :: effrl_expected = 5.0E-5 ! 50 microns, in meter + real(kind=kind_phys), parameter :: effri_expected = 7.5E-5 ! 75 microns, in meter + real(kind=kind_phys), parameter :: effrs_expected = 5.3E-4 ! 530 microns, in meter + real(kind=kind_phys), parameter :: scalar_expected = 2.0E3 ! 2 km, in meter + real(kind=kind_phys), parameter :: tke_expected = 10.0 ! 10 J kg-1 + real(kind=kind_phys), parameter :: tolerance = 1.0E-6 ! used as scaling factor for expected value + real(kind=kind_phys), parameter :: sfc_up_sw_expected = 100. ! W/m2 + real(kind=kind_phys), parameter :: sfc_down_sw_expected = 400. ! W/m2 + real(kind=kind_phys), parameter :: sfc_up_lw_expected = 300. ! W/m2 + real(kind=kind_phys), parameter :: sfc_down_lw_expected = 50. ! W/m2 compare_data = .true. - if (maxval(abs(phys_state%effrr - effrr_expected)) > tolerance*effrr_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrr from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effrr - effrr_expected)), ' > ', tolerance*effrr_expected - compare_data = .false. + if (maxval(abs(phys_state%effrr - effrr_expected)) > tolerance * effrr_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrr from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effrr - effrr_expected)), ' > ', tolerance * effrr_expected + compare_data = .false. + end if + + if (maxval(abs(phys_state%effrl - effrl_expected)) > tolerance * effrl_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrl from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effrl - effrl_expected)), ' > ', tolerance * effrl_expected + compare_data = .false. + end if + + if (maxval(abs(phys_state%effri - effri_expected)) > tolerance * effri_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effri from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effri - effri_expected)), ' > ', tolerance * effri_expected + compare_data = .false. + end if + + if (maxval(abs(effrs - effrs_expected)) > tolerance * effrs_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of effrs from expected value exceeds tolerance: ', & + maxval(abs(effrs - effrs_expected)), ' > ', tolerance * effrs_expected + compare_data = .false. + end if + + if (abs(phys_state%scalar_var - scalar_expected) > tolerance * scalar_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of scalar_var from expected value exceeds tolerance: ', & + abs(phys_state%scalar_var - scalar_expected), ' > ', tolerance * scalar_expected + compare_data = .false. end if - if (maxval(abs(phys_state%effrl - effrl_expected)) > tolerance*effrl_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrl from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effrl - effrl_expected)), ' > ', tolerance*effrl_expected - compare_data = .false. + if (abs(phys_state%tke - tke_expected) > tolerance * tke_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of tke from expected value exceeds tolerance: ', & + abs(phys_state%tke - tke_expected), ' > ', tolerance * tke_expected + compare_data = .false. end if - if (maxval(abs(phys_state%effri - effri_expected)) > tolerance*effri_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effri from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effri - effri_expected)), ' > ', tolerance*effri_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxsw%sfc_up_sw - sfc_up_sw_expected)) > tolerance * sfc_up_sw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_up_sw from expected value exceeds tolerance: ', & + abs(phys_state%fluxsw%sfc_up_sw - sfc_up_sw_expected), ' > ', tolerance * sfc_up_sw_expected + compare_data = .false. end if - if (maxval(abs( effrs - effrs_expected)) > tolerance*effrs_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of effrs from expected value exceeds tolerance: ', & - maxval(abs( effrs - effrs_expected)), ' > ', tolerance*effrs_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxsw%sfc_down_sw - sfc_down_sw_expected)) > tolerance * sfc_down_sw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_down_sw from expected value exceeds tolerance: ', & + abs(phys_state%fluxsw%sfc_down_sw - sfc_down_sw_expected), ' > ', tolerance * sfc_down_sw_expected + compare_data = .false. end if - if (abs( phys_state%scalar_var - scalar_expected) > tolerance*scalar_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of scalar_var from expected value exceeds tolerance: ', & - abs( phys_state%scalar_var - scalar_expected), ' > ', tolerance*scalar_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxlw%sfc_up_lw - sfc_up_lw_expected)) > tolerance * sfc_up_lw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_up_lw from expected value exceeds tolerance: ', & + abs(phys_state%fluxlw%sfc_up_lw - sfc_up_lw_expected), ' > ', tolerance * sfc_up_lw_expected + compare_data = .false. end if - if (abs( phys_state%tke - tke_expected) > tolerance*tke_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of tke from expected value exceeds tolerance: ', & - abs( phys_state%tke - tke_expected), ' > ', tolerance*tke_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxlw%sfc_down_lw - sfc_down_lw_expected)) > tolerance * sfc_down_lw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_down_lw from expected value exceeds tolerance: ', & + abs(phys_state%fluxlw%sfc_down_lw - sfc_down_lw_expected), ' > ', tolerance * sfc_down_lw_expected + compare_data = .false. end if - if (maxval(abs( phys_state%fluxSW%sfc_up_sw - sfc_up_sw_expected)) > tolerance*sfc_up_sw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_up_sw from expected value exceeds tolerance: ', & - abs( phys_state%fluxSW%sfc_up_sw - sfc_up_sw_expected), ' > ', tolerance*sfc_up_sw_expected - compare_data = .false. - end if - - if (maxval(abs( phys_state%fluxSW%sfc_down_sw - sfc_down_sw_expected)) > tolerance*sfc_down_sw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_down_sw from expected value exceeds tolerance: ', & - abs( phys_state%fluxSW%sfc_down_sw - sfc_down_sw_expected), ' > ', tolerance*sfc_down_sw_expected - compare_data = .false. - end if - - if (maxval(abs( phys_state%fluxLW%sfc_up_lw - sfc_up_lw_expected)) > tolerance*sfc_up_lw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_up_lw from expected value exceeds tolerance: ', & - abs( phys_state%fluxLW%sfc_up_lw - sfc_up_lw_expected), ' > ', tolerance*sfc_up_lw_expected - compare_data = .false. - end if - - if (maxval(abs( phys_state%fluxLW%sfc_down_lw - sfc_down_lw_expected)) > tolerance*sfc_down_lw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_down_lw from expected value exceeds tolerance: ', & - abs( phys_state%fluxLW%sfc_down_lw - sfc_down_lw_expected), ' > ', tolerance*sfc_down_lw_expected - compare_data = .false. - end if - end function compare_data end module test_host_mod diff --git a/test/var_compatibility_test/test_var_compatibility_integration.F90 b/test/var_compatibility_test/test_var_compatibility_integration.F90 index 1e081e10..36fb3404 100644 --- a/test/var_compatibility_test/test_var_compatibility_integration.F90 +++ b/test/var_compatibility_test/test_var_compatibility_integration.F90 @@ -1,85 +1,88 @@ program test_var_compatibility_integration - 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(1) = (/ 'radiation ' /) + character(len=cs), target :: test_parts1(1) = (/ 'radiation ' /) - character(len=cm), target :: test_invars1(18) = (/ & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'effective_radius_of_stratiform_cloud_graupel ', & - 'cloud_graupel_number_concentration ', & - 'scalar_variable_for_testing ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'scalar_variable_for_testing_a ', & - 'scalar_variable_for_testing_b ', & - 'scalar_variable_for_testing_c ', & - 'scheme_order_in_suite ', & - 'num_subcycles_for_effr ', & - 'flag_indicating_cloud_microphysics_has_graupel ', & - 'flag_indicating_cloud_microphysics_has_ice ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_invars1(18) = (/ & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'effective_radius_of_stratiform_cloud_graupel ', & + 'cloud_graupel_number_concentration ', & + 'scalar_variable_for_testing ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'scalar_variable_for_testing_a ', & + 'scalar_variable_for_testing_b ', & + 'scalar_variable_for_testing_c ', & + 'scheme_order_in_suite ', & + 'num_subcycles_for_effr ', & + 'flag_indicating_cloud_microphysics_has_graupel ', & + 'flag_indicating_cloud_microphysics_has_ice ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'longwave_radiation_fluxes '/) - character(len=cm), target :: test_outvars1(14) = (/ & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'effective_radius_of_stratiform_cloud_ice_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'cloud_ice_number_concentration ', & - 'scalar_variable_for_testing ', & - 'scheme_order_in_suite ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_outvars1(14) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'effective_radius_of_stratiform_cloud_ice_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'cloud_ice_number_concentration ', & + 'scalar_variable_for_testing ', & + 'scheme_order_in_suite ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'longwave_radiation_fluxes '/) - character(len=cm), target :: test_reqvars1(22) = (/ & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_ice_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'effective_radius_of_stratiform_cloud_graupel ', & - 'cloud_graupel_number_concentration ', & - 'cloud_ice_number_concentration ', & - 'scalar_variable_for_testing ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'scalar_variable_for_testing_a ', & - 'scalar_variable_for_testing_b ', & - 'scalar_variable_for_testing_c ', & - 'scheme_order_in_suite ', & - 'num_subcycles_for_effr ', & - 'flag_indicating_cloud_microphysics_has_graupel ', & - 'flag_indicating_cloud_microphysics_has_ice ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_reqvars1(22) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_ice_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'effective_radius_of_stratiform_cloud_graupel ', & + 'cloud_graupel_number_concentration ', & + 'cloud_ice_number_concentration ', & + 'scalar_variable_for_testing ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'scalar_variable_for_testing_a ', & + 'scalar_variable_for_testing_b ', & + 'scalar_variable_for_testing_c ', & + 'scheme_order_in_suite ', & + 'num_subcycles_for_effr ', & + 'flag_indicating_cloud_microphysics_has_graupel ', & + 'flag_indicating_cloud_microphysics_has_ice ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'longwave_radiation_fluxes '/) - type(suite_info) :: test_suites(1) - logical :: run_okay + type(suite_info) :: test_suites(1) + logical :: run_okay - ! Setup expected test suite info - test_suites(1)%suite_name = 'var_compatibility_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 + ! Setup expected test suite info + test_suites(1)%suite_name = 'var_compatibility_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 - 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_var_compatibility_integration diff --git a/test_prebuild/test_blocked_data/blocked_data_scheme.F90 b/test_prebuild/test_blocked_data/blocked_data_scheme.F90 index eeda2206..77e1e687 100644 --- a/test_prebuild/test_blocked_data/blocked_data_scheme.F90 +++ b/test_prebuild/test_blocked_data/blocked_data_scheme.F90 @@ -4,115 +4,123 @@ module blocked_data_scheme - use, intrinsic :: iso_fortran_env, only: error_unit - implicit none + use, intrinsic :: iso_fortran_env, only: error_unit + implicit none - private - public :: blocked_data_scheme_init, & - blocked_data_scheme_timestep_init, & - blocked_data_scheme_run, & - blocked_data_scheme_timestep_finalize, & - blocked_data_scheme_finalize + private + public :: blocked_data_scheme_init, & + blocked_data_scheme_timestep_init, & + blocked_data_scheme_run, & + blocked_data_scheme_timestep_finalize, & + blocked_data_scheme_finalize - ! This is for unit testing only - integer, parameter, dimension(4) :: data_array_sizes = (/6,6,6,3/) + ! This is for unit testing only + integer, parameter, dimension(4) :: data_array_sizes = (/6, 6, 6, 3/) - contains +contains -!! \section arg_table_blocked_data_scheme_init Argument Table -!! \htmlinclude blocked_data_scheme_init.html -!! - subroutine blocked_data_scheme_init(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In blocked_data_scheme_init: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_init + !! \section arg_table_blocked_data_scheme_init Argument Table + !! \htmlinclude blocked_data_scheme_init.html + !! + subroutine blocked_data_scheme_init(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In blocked_data_scheme_init: checking size of data array to be', sum(data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_init -!! \section arg_table_blocked_data_scheme_timestep_init Argument Table -!! \htmlinclude blocked_data_scheme_timestep_init.html -!! - subroutine blocked_data_scheme_timestep_init(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In blocked_data_scheme_timestep_init: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), " but got ", size(data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_timestep_init + !! \section arg_table_blocked_data_scheme_timestep_init Argument Table + !! \htmlinclude blocked_data_scheme_timestep_init.html + !! + subroutine blocked_data_scheme_timestep_init(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In blocked_data_scheme_timestep_init: checking size of data array to be', sum(& + data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), " but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_timestep_init -!! \section arg_table_blocked_data_scheme_run Argument Table -!! \htmlinclude blocked_data_scheme_run.html -!! - subroutine blocked_data_scheme_run(nb, data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nb - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(2(a,i3))') 'In blocked_data_scheme_run: checking size of data array for block', nb, ' to be', data_array_sizes(nb) - if (size(data_array)/=data_array_sizes(nb)) then - write(errmsg,'(a,i4)') "Error in blocked_data_scheme_run, expected size(data_array)==6, got ", size(data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_run + !! \section arg_table_blocked_data_scheme_run Argument Table + !! \htmlinclude blocked_data_scheme_run.html + !! + subroutine blocked_data_scheme_run(nb, data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nb + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(2(a,i3))') 'In blocked_data_scheme_run: checking size of data array for block', nb, & + ' to be', data_array_sizes(nb) + if (size(data_array)/=data_array_sizes(nb)) then + write(errmsg, '(a,i4)') "Error in blocked_data_scheme_run, expected size(data_array)==6, got ", size(data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_run - !! \section arg_table_blocked_data_scheme_timestep_finalize Argument Table - !! \htmlinclude blocked_data_scheme_timestep_finalize.html - !! - subroutine blocked_data_scheme_timestep_finalize(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In blocked_data_scheme_timestep_finalize: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_timestep_finalize + !! \section arg_table_blocked_data_scheme_timestep_finalize Argument Table + !! \htmlinclude blocked_data_scheme_timestep_finalize.html + !! + subroutine blocked_data_scheme_timestep_finalize(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In blocked_data_scheme_timestep_finalize: checking size of data array to be', sum(& + data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_timestep_finalize -!! \section arg_table_blocked_data_scheme_finalize Argument Table -!! \htmlinclude blocked_data_scheme_finalize.html -!! - subroutine blocked_data_scheme_finalize(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In blocked_data_scheme_finalize: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_finalize + !! \section arg_table_blocked_data_scheme_finalize Argument Table + !! \htmlinclude blocked_data_scheme_finalize.html + !! + subroutine blocked_data_scheme_finalize(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In blocked_data_scheme_finalize: checking size of data array to be', sum(& + data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_finalize end module blocked_data_scheme diff --git a/test_prebuild/test_blocked_data/data.F90 b/test_prebuild/test_blocked_data/data.F90 index 97ad051e..0d399f27 100644 --- a/test_prebuild/test_blocked_data/data.F90 +++ b/test_prebuild/test_blocked_data/data.F90 @@ -1,41 +1,41 @@ module data -!! \section arg_table_data Argument Table -!! \htmlinclude data.html -!! - use ccpp_types, only: ccpp_t + !! \section arg_table_data Argument Table + !! \htmlinclude data.html + !! + use ccpp_types, only: ccpp_t - implicit none + implicit none - private + private - public nblks, blksz, ncols - public ccpp_data_domain, ccpp_data_blocks, blocked_data_type, blocked_data_instance + public nblks, blksz, ncols + public ccpp_data_domain, ccpp_data_blocks, blocked_data_type, blocked_data_instance - integer, parameter :: nblks = 4 - type(ccpp_t), target :: ccpp_data_domain - type(ccpp_t), dimension(nblks), target :: ccpp_data_blocks + integer, parameter :: nblks = 4 + type(ccpp_t), target :: ccpp_data_domain + type(ccpp_t), dimension(nblks), target :: ccpp_data_blocks - integer, parameter, dimension(nblks) :: blksz = (/6,6,6,3/) - integer, parameter :: ncols = sum(blksz) + integer, parameter, dimension(nblks) :: blksz = (/6, 6, 6, 3/) + integer, parameter :: ncols = sum(blksz) -!! \section arg_table_blocked_data_type -!! \htmlinclude blocked_data_type.html -!! - type blocked_data_type - integer, dimension(:), allocatable :: array_data - contains - procedure :: create => blocked_data_create - end type blocked_data_type + !! \section arg_table_blocked_data_type + !! \htmlinclude blocked_data_type.html + !! + type blocked_data_type + integer, dimension(:), allocatable :: array_data + contains + procedure :: create => blocked_data_create + end type blocked_data_type - type(blocked_data_type), dimension(nblks) :: blocked_data_instance + type(blocked_data_type), dimension(nblks) :: blocked_data_instance contains - subroutine blocked_data_create(blocked_data_instance, ncol) - class(blocked_data_type), intent(inout) :: blocked_data_instance - integer, intent(in) :: ncol - allocate(blocked_data_instance%array_data(ncol)) - end subroutine blocked_data_create + subroutine blocked_data_create(blocked_data_instance, ncol) + class(blocked_data_type), intent(inout) :: blocked_data_instance + integer, intent(in) :: ncol + allocate(blocked_data_instance%array_data(ncol)) + end subroutine blocked_data_create end module data diff --git a/test_prebuild/test_blocked_data/main.F90 b/test_prebuild/test_blocked_data/main.F90 index 4711b3c9..5b357b43 100644 --- a/test_prebuild/test_blocked_data/main.F90 +++ b/test_prebuild/test_blocked_data/main.F90 @@ -1,112 +1,117 @@ program test_blocked_data - use, intrinsic :: iso_fortran_env, only: error_unit - - use ccpp_types, only: ccpp_t - use data, only: nblks, blksz, ncols - use data, only: ccpp_data_domain, ccpp_data_blocks, & - blocked_data_type, blocked_data_instance - - use ccpp_static_api, only: ccpp_physics_init, & - ccpp_physics_timestep_init, & - ccpp_physics_run, & - ccpp_physics_timestep_finalize, & - ccpp_physics_finalize - - implicit none - - character(len=*), parameter :: ccpp_suite = 'blocked_data_suite' - integer :: ib, ierr - type(ccpp_t), pointer :: cdata => null() - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! For physics running over the entire domain, - ! ccpp_thread_number and ccpp_chunk_number are - ! set to 1, indicating that arrays are to be sent - ! following their dimension specification in the - ! metadata (must match horizontal_dimension). - ccpp_data_domain%blk_no = 1 - ccpp_data_domain%thrd_no = 1 - ccpp_data_domain%thrd_cnt = 1 - - ! Loop over all blocks and threads for ccpp_data_blocks - do ib=1,nblks - ! Assign the correct block numbers, only one thread - ccpp_data_blocks(ib)%blk_no = ib - ccpp_data_blocks(ib)%thrd_no = 1 - ccpp_data_blocks(ib)%thrd_cnt = 1 - end do - - do ib=1,size(blocked_data_instance) - allocate(blocked_data_instance(ib)%array_data(blksz(ib))) - write(error_unit,'(2(a,i3))') "Allocated array_data for block", ib, " to size", size(blocked_data_instance(ib)%array_data) - end do - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_init:" - write(error_unit,'(a)') trim(cdata%errmsg) + use, intrinsic :: iso_fortran_env, only: error_unit + + use ccpp_types, only: ccpp_t + use data, only: nblks, & + blksz, & + ncols + use data, only: ccpp_data_domain, & + ccpp_data_blocks, & + blocked_data_type, & + blocked_data_instance + + use ccpp_static_api, only: ccpp_physics_init, & + ccpp_physics_timestep_init, & + ccpp_physics_run, & + ccpp_physics_timestep_finalize, & + ccpp_physics_finalize + + implicit none + + character(len=*), parameter :: ccpp_suite = 'blocked_data_suite' + integer :: ib, ierr + type(ccpp_t), pointer :: cdata => null() + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! For physics running over the entire domain, + ! ccpp_thread_number and ccpp_chunk_number are + ! set to 1, indicating that arrays are to be sent + ! following their dimension specification in the + ! metadata (must match horizontal_dimension). + ccpp_data_domain%blk_no = 1 + ccpp_data_domain%thrd_no = 1 + ccpp_data_domain%thrd_cnt = 1 + + ! Loop over all blocks and threads for ccpp_data_blocks + do ib = 1, nblks + ! Assign the correct block numbers, only one thread + ccpp_data_blocks(ib)%blk_no = ib + ccpp_data_blocks(ib)%thrd_no = 1 + ccpp_data_blocks(ib)%thrd_cnt = 1 + end do + + do ib = 1, size(blocked_data_instance) + allocate(blocked_data_instance(ib)%array_data(blksz(ib))) + write(error_unit, '(2(a,i3))') "Allocated array_data for block", ib, " to size", size(blocked_data_instance(ib)%& + array_data) + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics run step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do ib = 1, nblks + cdata => ccpp_data_blocks(ib) + call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a,i3,a)') "An error occurred in ccpp_physics_run for block", ib, ":" + write(error_unit, '(a)') trim(cdata%errmsg) stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics run step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - do ib=1,nblks - cdata => ccpp_data_blocks(ib) - call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a,i3,a)') "An error occurred in ccpp_physics_run for block", ib, ":" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - end do - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_finalize:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_finalize:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if + end if + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_finalize:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_finalize:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if contains -end program test_blocked_data \ No newline at end of file +end program test_blocked_data diff --git a/test_prebuild/test_chunked_data/chunked_data_scheme.F90 b/test_prebuild/test_chunked_data/chunked_data_scheme.F90 index 1bb2a266..392167b2 100644 --- a/test_prebuild/test_chunked_data/chunked_data_scheme.F90 +++ b/test_prebuild/test_chunked_data/chunked_data_scheme.F90 @@ -4,115 +4,123 @@ module chunked_data_scheme - use, intrinsic :: iso_fortran_env, only: error_unit - implicit none + use, intrinsic :: iso_fortran_env, only: error_unit + implicit none - private - public :: chunked_data_scheme_init, & - chunked_data_scheme_timestep_init, & - chunked_data_scheme_run, & - chunked_data_scheme_timestep_finalize, & - chunked_data_scheme_finalize + private + public :: chunked_data_scheme_init, & + chunked_data_scheme_timestep_init, & + chunked_data_scheme_run, & + chunked_data_scheme_timestep_finalize, & + chunked_data_scheme_finalize - ! This is for unit testing only - integer, parameter, dimension(4) :: data_array_sizes = (/6,6,6,3/) + ! This is for unit testing only + integer, parameter, dimension(4) :: data_array_sizes = (/6, 6, 6, 3/) - contains +contains -!! \section arg_table_chunked_data_scheme_init Argument Table -!! \htmlinclude chunked_data_scheme_init.html -!! - subroutine chunked_data_scheme_init(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In chunked_data_scheme_init: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_init + !! \section arg_table_chunked_data_scheme_init Argument Table + !! \htmlinclude chunked_data_scheme_init.html + !! + subroutine chunked_data_scheme_init(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In chunked_data_scheme_init: checking size of data array to be', sum(data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_init -!! \section arg_table_chunked_data_scheme_timestep_init Argument Table -!! \htmlinclude chunked_data_scheme_timestep_init.html -!! - subroutine chunked_data_scheme_timestep_init(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In chunked_data_scheme_timestep_init: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), " but got ", size(data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_timestep_init + !! \section arg_table_chunked_data_scheme_timestep_init Argument Table + !! \htmlinclude chunked_data_scheme_timestep_init.html + !! + subroutine chunked_data_scheme_timestep_init(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In chunked_data_scheme_timestep_init: checking size of data array to be', sum(& + data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), " but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_timestep_init -!! \section arg_table_chunked_data_scheme_run Argument Table -!! \htmlinclude chunked_data_scheme_run.html -!! - subroutine chunked_data_scheme_run(nchunk, data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nchunk - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(2(a,i3))') 'In chunked_data_scheme_run: checking size of data array for chunk', nchunk, ' to be', data_array_sizes(nchunk) - if (size(data_array)/=data_array_sizes(nchunk)) then - write(errmsg,'(a,i4)') "Error in chunked_data_scheme_run, expected size(data_array)==6, got ", size(data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_run + !! \section arg_table_chunked_data_scheme_run Argument Table + !! \htmlinclude chunked_data_scheme_run.html + !! + subroutine chunked_data_scheme_run(nchunk, data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nchunk + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(2(a,i3))') 'In chunked_data_scheme_run: checking size of data array for chunk', nchunk, & + ' to be', data_array_sizes(nchunk) + if (size(data_array)/=data_array_sizes(nchunk)) then + write(errmsg, '(a,i4)') "Error in chunked_data_scheme_run, expected size(data_array)==6, got ", size(data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_run - !! \section arg_table_chunked_data_scheme_timestep_finalize Argument Table - !! \htmlinclude chunked_data_scheme_timestep_finalize.html - !! - subroutine chunked_data_scheme_timestep_finalize(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In chunked_data_scheme_timestep_finalize: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_timestep_finalize + !! \section arg_table_chunked_data_scheme_timestep_finalize Argument Table + !! \htmlinclude chunked_data_scheme_timestep_finalize.html + !! + subroutine chunked_data_scheme_timestep_finalize(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In chunked_data_scheme_timestep_finalize: checking size of data array to be', sum(& + data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_timestep_finalize -!! \section arg_table_chunked_data_scheme_finalize Argument Table -!! \htmlinclude chunked_data_scheme_finalize.html -!! - subroutine chunked_data_scheme_finalize(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In chunked_data_scheme_finalize: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_finalize + !! \section arg_table_chunked_data_scheme_finalize Argument Table + !! \htmlinclude chunked_data_scheme_finalize.html + !! + subroutine chunked_data_scheme_finalize(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In chunked_data_scheme_finalize: checking size of data array to be', sum(& + data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_finalize end module chunked_data_scheme diff --git a/test_prebuild/test_chunked_data/data.F90 b/test_prebuild/test_chunked_data/data.F90 index 8fbf21ed..82c4abac 100644 --- a/test_prebuild/test_chunked_data/data.F90 +++ b/test_prebuild/test_chunked_data/data.F90 @@ -1,43 +1,43 @@ module data -!! \section arg_table_dATa Argument Table -!! \htmlinclude datA.Html -!! - use ccpp_types, only: ccpp_t + !! \section arg_table_dATa Argument Table + !! \htmlinclude datA.Html + !! + use ccpp_types, only: ccpp_t - implicit none + implicit none - private + private - public nchunks, chunksize, chunk_begin, chunk_end, ncols - public ccpp_data_domain, ccpp_data_chunks, chunked_data_type, chunked_data_instance + public nchunks, chunksize, chunk_begin, chunk_end, ncols + public ccpp_data_domain, ccpp_data_chunks, chunked_data_type, chunked_data_instance - integer, parameter :: nchunks = 4 - type(ccpp_t), target :: ccpp_data_domain - type(ccpp_t), dimension(nchunks), target :: ccpp_data_chunks + integer, parameter :: nchunks = 4 + type(ccpp_t), target :: ccpp_data_domain + type(ccpp_t), dimension(nchunks), target :: ccpp_data_chunks - integer, parameter, dimension(nchunks) :: chunksize = (/6,6,6,3/) - integer, parameter, dimension(nchunks) :: chunk_begin = (/1,7,13,19/) - integer, parameter, dimension(nchunks) :: chunk_end = (/6,12,18,21/) - integer, parameter :: ncols = sum(chunksize) + integer, parameter, dimension(nchunks) :: chunksize = (/6, 6, 6, 3/) + integer, parameter, dimension(nchunks) :: chunk_begin = (/1, 7, 13, 19/) + integer, parameter, dimension(nchunks) :: chunk_end = (/6, 12, 18, 21/) + integer, parameter :: ncols = sum(chunksize) -!! \section arg_table_cHuNkEd_dATa_TYPe -!! \htmlinclude CHuNKed_Data_tYpe.hTMl -!! - type chunked_data_type - integer, dimension(:), allocatable :: array_data - contains - procedure :: create => chunked_data_create - end type chunked_data_type + !! \section arg_table_cHuNkEd_dATa_TYPe + !! \htmlinclude CHuNKed_Data_tYpe.hTMl + !! + type chunked_data_type + integer, dimension(:), allocatable :: array_data + contains + procedure :: create => chunked_data_create + end type chunked_data_type - type(chunked_data_type) :: chunked_data_instance + type(chunked_data_type) :: chunked_data_instance contains - subroutine chunked_data_create(chunked_data_instance, ncol) - class(chunked_data_type), intent(inout) :: chunked_data_instance - integer, intent(in) :: ncol - allocate(chunked_data_instance%array_data(ncol)) - end subroutine chunked_data_create + subroutine chunked_data_create(chunked_data_instance, ncol) + class(chunked_data_type), intent(inout) :: chunked_data_instance + integer, intent(in) :: ncol + allocate(chunked_data_instance%array_data(ncol)) + end subroutine chunked_data_create end module data diff --git a/test_prebuild/test_chunked_data/main.F90 b/test_prebuild/test_chunked_data/main.F90 index a1af449b..da96d1d1 100644 --- a/test_prebuild/test_chunked_data/main.F90 +++ b/test_prebuild/test_chunked_data/main.F90 @@ -1,110 +1,114 @@ program test_chunked_data - use, intrinsic :: iso_fortran_env, only: error_unit - - use ccpp_types, only: ccpp_t - use data, only: nchunks, chunksize, ncols - use data, only: ccpp_data_domain, ccpp_data_chunks, & - chunked_data_type, chunked_data_instance - - use ccpp_static_api, only: ccpp_physics_init, & - ccpp_physics_timestep_init, & - ccpp_physics_run, & - ccpp_physics_timestep_finalize, & - ccpp_physics_finalize - - implicit none - - character(len=*), parameter :: ccpp_suite = 'chunked_data_suite' - integer :: ic, ierr - type(ccpp_t), pointer :: cdata => null() - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! For physics running over the entire domain, - ! ccpp_thread_number and ccpp_chunk_number are - ! set to 1, indicating that arrays are to be sent - ! following their dimension specification in the - ! metadata (must match horizontal_dimension). - ccpp_data_domain%thrd_no = 1 - ccpp_data_domain%chunk_no = 1 - ccpp_data_domain%thrd_cnt = 1 - - ! Loop over all chunks and threads for ccpp_data_chunks - do ic=1,nchunks - ! Assign the correct chunk numbers, only one thread - ccpp_data_chunks(ic)%chunk_no = ic - ccpp_data_chunks(ic)%thrd_no = 1 - ccpp_data_chunks(ic)%thrd_cnt = 1 - end do - - call chunked_data_instance%create(ncols) - write(error_unit,'(2(a,i3))') "Chunked_data_instance%array_data to size", size(chunked_data_instance%array_data) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_init:" - write(error_unit,'(a)') trim(cdata%errmsg) + use, intrinsic :: iso_fortran_env, only: error_unit + + use ccpp_types, only: ccpp_t + use data, only: nchunks, & + chunksize, & + ncols + use data, only: ccpp_data_domain, & + ccpp_data_chunks, & + chunked_data_type, & + chunked_data_instance + + use ccpp_static_api, only: ccpp_physics_init, & + ccpp_physics_timestep_init, & + ccpp_physics_run, & + ccpp_physics_timestep_finalize, & + ccpp_physics_finalize + + implicit none + + character(len=*), parameter :: ccpp_suite = 'chunked_data_suite' + integer :: ic, ierr + type(ccpp_t), pointer :: cdata => null() + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! For physics running over the entire domain, + ! ccpp_thread_number and ccpp_chunk_number are + ! set to 1, indicating that arrays are to be sent + ! following their dimension specification in the + ! metadata (must match horizontal_dimension). + ccpp_data_domain%thrd_no = 1 + ccpp_data_domain%chunk_no = 1 + ccpp_data_domain%thrd_cnt = 1 + + ! Loop over all chunks and threads for ccpp_data_chunks + do ic = 1, nchunks + ! Assign the correct chunk numbers, only one thread + ccpp_data_chunks(ic)%chunk_no = ic + ccpp_data_chunks(ic)%thrd_no = 1 + ccpp_data_chunks(ic)%thrd_cnt = 1 + end do + + call chunked_data_instance%create(ncols) + write(error_unit, '(2(a,i3))') "Chunked_data_instance%array_data to size", size(chunked_data_instance%array_data) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics run step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do ic = 1, nchunks + cdata => ccpp_data_chunks(ic) + call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a,i3,a)') "An error occurred in ccpp_physics_run for chunk", ic, ":" + write(error_unit, '(a)') trim(cdata%errmsg) stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics run step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - do ic=1,nchunks - cdata => ccpp_data_chunks(ic) - call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a,i3,a)') "An error occurred in ccpp_physics_run for chunk", ic, ":" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - end do - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_finalize:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_finalize:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if + end if + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_finalize:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_finalize:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if contains -end program test_chunked_data \ No newline at end of file +end program test_chunked_data diff --git a/test_prebuild/test_opt_arg/ccpp_kinds.F90 b/test_prebuild/test_opt_arg/ccpp_kinds.F90 index cf6bfeaf..a07ded9b 100644 --- a/test_prebuild/test_opt_arg/ccpp_kinds.F90 +++ b/test_prebuild/test_opt_arg/ccpp_kinds.F90 @@ -1,13 +1,13 @@ module ccpp_kinds -!! \section arg_table_ccpp_kinds -!! \htmlinclude ccpp_kinds.html -!! + !! \section arg_table_ccpp_kinds + !! \htmlinclude ccpp_kinds.html + !! - use iso_fortran_env, only: real64 + use iso_fortran_env, only: real64 - implicit none + implicit none - integer, parameter :: kind_phys = real64 + integer, parameter :: kind_phys = real64 end module ccpp_kinds diff --git a/test_prebuild/test_opt_arg/data.F90 b/test_prebuild/test_opt_arg/data.F90 index e16051fd..f66cf8c1 100644 --- a/test_prebuild/test_opt_arg/data.F90 +++ b/test_prebuild/test_opt_arg/data.F90 @@ -1,23 +1,23 @@ module data -!! \section arg_table_data Argument Table -!! \htmlinclude data.html -!! - use ccpp_types, only: ccpp_t - use ccpp_kinds, only: kind_phys + !! \section arg_table_data Argument Table + !! \htmlinclude data.html + !! + use ccpp_types, only: ccpp_t + use ccpp_kinds, only: kind_phys - implicit none + implicit none - private + private - public cdata, nx, flag_for_opt_arg, std_arg, opt_arg, opt_arg_2 + public cdata, nx, flag_for_opt_arg, std_arg, opt_arg, opt_arg_2 - type(ccpp_t), target :: cdata - integer, parameter :: nx = 3 - logical :: flag_for_opt_arg + type(ccpp_t), target :: cdata + integer, parameter :: nx = 3 + logical :: flag_for_opt_arg - integer, dimension(nx) :: std_arg - integer, dimension(:), allocatable :: opt_arg - real(kind=kind_phys), dimension(:), allocatable :: opt_arg_2 + integer, dimension(nx) :: std_arg + integer, dimension(:), allocatable :: opt_arg + real(kind=kind_phys), dimension(:), allocatable :: opt_arg_2 end module data diff --git a/test_prebuild/test_opt_arg/main.F90 b/test_prebuild/test_opt_arg/main.F90 index 932958bc..7716c077 100644 --- a/test_prebuild/test_opt_arg/main.F90 +++ b/test_prebuild/test_opt_arg/main.F90 @@ -1,119 +1,127 @@ program test_opt_arg - use, intrinsic :: iso_fortran_env, only: output_unit, error_unit - - use ccpp_types, only: ccpp_t - use data, only: cdata, nx, flag_for_opt_arg, std_arg, opt_arg, opt_arg_2 - - use ccpp_static_api, only: ccpp_physics_init, & - ccpp_physics_timestep_init, & - ccpp_physics_run, & - ccpp_physics_timestep_finalize, & - ccpp_physics_finalize - - implicit none - - character(len=*), parameter :: ccpp_suite = 'opt_arg_suite' - integer :: ierr - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata%blk_no = 1 - cdata%thrd_no = 1 - cdata%thrd_cnt = 1 - - std_arg = 1 - flag_for_opt_arg = .true. - allocate(opt_arg(nx)) - allocate(opt_arg_2(nx)) - - ! std_arg must all be 1, opt_arg must all be 0 - write(output_unit,'(a)') "After ccpp_init: check std_arg(:)==1, opt_arg(:)==0, opt_arg_2(:)==0" - if (.not. all(std_arg .eq. 1)) write(error_unit,'(a,3i3)') "Error after ccpp_init: std_arg=", std_arg - if (.not. all(opt_arg .eq. 0)) write(error_unit,'(a,3i3)') "Error after ccpp_init: opt_arg=", opt_arg - if (.not. all(opt_arg_2 .eq. 0)) write(error_unit,'(a,3i3)') "Error after ccpp_init: opt_arg_2=", opt_arg_2 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 1, opt_arg must all be 0 - write(output_unit,'(a)') "After ccpp_physics_init: check std_arg(:)==1 and opt_arg(:)==0" - if (.not. all(std_arg .eq. 1)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_init: std_arg=", std_arg - if (.not. all(opt_arg .eq. 0)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_init: opt_arg=", opt_arg - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 1, opt_arg must all be 2 - write(output_unit,'(a)') "After ccpp_physics_timestep_init: check std_arg(:)==1 and opt_arg(:)==2" - if (.not. all(std_arg .eq. 1)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_timestep_init: std_arg=", std_arg - if (.not. all(opt_arg .eq. 2)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_timestep_init: opt_arg=", opt_arg - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics run step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_run:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 1, opt_arg must all be 3 - write(output_unit,'(a)') "After ccpp_physics_run: check std_arg(:)==1 and opt_arg(:)==3" - if (.not. all(std_arg .eq. 1)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_run: std_arg=", std_arg - if (.not. all(opt_arg .eq. 3)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_run: opt_arg=", opt_arg - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - deallocate(opt_arg) - flag_for_opt_arg = .false. - - call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 7, opt_arg no longer allocated - write(output_unit,'(a)') "After ccpp_physics_timestep_final: check std_arg(:)==7; opt_arg not allocated" - if (.not. all(std_arg .eq. 7)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_timestep_final: std_arg=", std_arg - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 7, opt_arg no longer allocated - write(output_unit,'(a)') "After ccpp_physics_timestep_final: check std_arg(:)==7; opt_arg not allocated" - if (.not. all(std_arg .eq. 7)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_timestep_final: std_arg=", std_arg + use, intrinsic :: iso_fortran_env, only: output_unit, & + error_unit + + use ccpp_types, only: ccpp_t + use data, only: cdata, & + nx, & + flag_for_opt_arg, & + std_arg, & + opt_arg, & + opt_arg_2 + + use ccpp_static_api, only: ccpp_physics_init, & + ccpp_physics_timestep_init, & + ccpp_physics_run, & + ccpp_physics_timestep_finalize, & + ccpp_physics_finalize + + implicit none + + character(len=*), parameter :: ccpp_suite = 'opt_arg_suite' + integer :: ierr + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata%blk_no = 1 + cdata%thrd_no = 1 + cdata%thrd_cnt = 1 + + std_arg = 1 + flag_for_opt_arg = .true. + allocate(opt_arg(nx)) + allocate(opt_arg_2(nx)) + + ! std_arg must all be 1, opt_arg must all be 0 + write(output_unit, '(a)') "After ccpp_init: check std_arg(:)==1, opt_arg(:)==0, opt_arg_2(:)==0" + if ( .not. all(std_arg == 1)) write(error_unit, '(a,3i3)') "Error after ccpp_init: std_arg=", std_arg + if ( .not. all(opt_arg == 0)) write(error_unit, '(a,3i3)') "Error after ccpp_init: opt_arg=", opt_arg + if ( .not. all(opt_arg_2 == 0)) write(error_unit, '(a,3i3)') "Error after ccpp_init: opt_arg_2=", opt_arg_2 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 1, opt_arg must all be 0 + write(output_unit, '(a)') "After ccpp_physics_init: check std_arg(:)==1 and opt_arg(:)==0" + if ( .not. all(std_arg == 1)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_init: std_arg=", std_arg + if ( .not. all(opt_arg == 0)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_init: opt_arg=", opt_arg + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 1, opt_arg must all be 2 + write(output_unit, '(a)') "After ccpp_physics_timestep_init: check std_arg(:)==1 and opt_arg(:)==2" + if ( .not. all(std_arg == 1)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_timestep_init: std_arg=", std_arg + if ( .not. all(opt_arg == 2)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_timestep_init: opt_arg=", opt_arg + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics run step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_run:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 1, opt_arg must all be 3 + write(output_unit, '(a)') "After ccpp_physics_run: check std_arg(:)==1 and opt_arg(:)==3" + if ( .not. all(std_arg == 1)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_run: std_arg=", std_arg + if ( .not. all(opt_arg == 3)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_run: opt_arg=", opt_arg + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + deallocate(opt_arg) + flag_for_opt_arg = .false. + + call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 7, opt_arg no longer allocated + write(output_unit, '(a)') "After ccpp_physics_timestep_final: check std_arg(:)==7; opt_arg not allocated" + if ( .not. all(std_arg == 7)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_timestep_final: std_arg=", & + std_arg + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 7, opt_arg no longer allocated + write(output_unit, '(a)') "After ccpp_physics_timestep_final: check std_arg(:)==7; opt_arg not allocated" + if ( .not. all(std_arg == 7)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_timestep_final: std_arg=", & + std_arg end program test_opt_arg diff --git a/test_prebuild/test_opt_arg/opt_arg_scheme.F90 b/test_prebuild/test_opt_arg/opt_arg_scheme.F90 index 1a36fffd..33be0973 100644 --- a/test_prebuild/test_opt_arg/opt_arg_scheme.F90 +++ b/test_prebuild/test_opt_arg/opt_arg_scheme.F90 @@ -4,87 +4,87 @@ module opt_arg_scheme - use, intrinsic :: iso_fortran_env, only: error_unit - use ccpp_kinds, only: kind_phys + use, intrinsic :: iso_fortran_env, only: error_unit + use ccpp_kinds, only: kind_phys - implicit none + implicit none - private - public :: opt_arg_scheme_timestep_init, & - opt_arg_scheme_run, & - opt_arg_scheme_timestep_finalize + private + public :: opt_arg_scheme_timestep_init, & + opt_arg_scheme_run, & + opt_arg_scheme_timestep_finalize - contains +contains -!! \section arg_table_opt_arg_scheme_timestep_init Argument Table -!! \htmlinclude opt_arg_scheme_timestep_init.html -!! - subroutine opt_arg_scheme_timestep_init(nx, var, opt_var, opt_var_2, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nx - integer, intent(in) :: var(:) - integer, optional, intent(out) :: opt_var(:) - real(kind=kind_phys), optional, intent(out) :: opt_var_2(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Initialize opt_var from var if opt_var if present - if (present(opt_var)) then - opt_var = 2*var - end if - ! Initialize opt_var_2 from var if opt_var_2 present - if (present(opt_var_2)) then - opt_var_2 = 3.0_kind_phys*var - end if - end subroutine opt_arg_scheme_timestep_init + !! \section arg_table_opt_arg_scheme_timestep_init Argument Table + !! \htmlinclude opt_arg_scheme_timestep_init.html + !! + subroutine opt_arg_scheme_timestep_init(nx, var, opt_var, opt_var_2, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nx + integer, intent(in) :: var(:) + integer, optional, intent(out) :: opt_var(:) + real(kind=kind_phys), optional, intent(out) :: opt_var_2(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Initialize opt_var from var if opt_var if present + if (present(opt_var)) then + opt_var = 2 * var + end if + ! Initialize opt_var_2 from var if opt_var_2 present + if (present(opt_var_2)) then + opt_var_2 = 3.0_kind_phys * var + end if + end subroutine opt_arg_scheme_timestep_init -!! \section arg_table_opt_arg_scheme_run Argument Table -!! \htmlinclude opt_arg_scheme_run.html -!! - subroutine opt_arg_scheme_run(nx, var, opt_var, opt_var_2, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nx - integer, intent(in) :: var(:) - integer, optional, intent(inout) :: opt_var(:) - real(kind=kind_phys), optional, intent(inout) :: opt_var_2(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Update opt_var from var if opt_var present - if (present(opt_var)) then - opt_var = 3*var - end if - ! Update opt_var_2 from var if opt_var_2 present - if (present(opt_var_2)) then - opt_var_2 = 4.0_kind_phys*var - end if - end subroutine opt_arg_scheme_run + !! \section arg_table_opt_arg_scheme_run Argument Table + !! \htmlinclude opt_arg_scheme_run.html + !! + subroutine opt_arg_scheme_run(nx, var, opt_var, opt_var_2, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nx + integer, intent(in) :: var(:) + integer, optional, intent(inout) :: opt_var(:) + real(kind=kind_phys), optional, intent(inout) :: opt_var_2(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Update opt_var from var if opt_var present + if (present(opt_var)) then + opt_var = 3 * var + end if + ! Update opt_var_2 from var if opt_var_2 present + if (present(opt_var_2)) then + opt_var_2 = 4.0_kind_phys * var + end if + end subroutine opt_arg_scheme_run -!! \section arg_table_opt_arg_scheme_timestep_finalize Argument Table -!! \htmlinclude opt_arg_scheme_timestep_finalize.html -!! - subroutine opt_arg_scheme_timestep_finalize(nx, var, opt_var, opt_var_2, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nx - integer, intent(inout) :: var(:) - integer, optional, intent(in) :: opt_var(:) - real(kind=kind_phys), optional, intent(inout) :: opt_var_2(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Update var from opt_var if opt_var is present - if (present(opt_var)) then - var = 4*opt_var - else - var = 7*var - end if - ! Update opt_var_2 if present - if (present(opt_var_2)) then - opt_var_2 = opt_var_2 + 5.0_kind_phys - end if - end subroutine opt_arg_scheme_timestep_finalize + !! \section arg_table_opt_arg_scheme_timestep_finalize Argument Table + !! \htmlinclude opt_arg_scheme_timestep_finalize.html + !! + subroutine opt_arg_scheme_timestep_finalize(nx, var, opt_var, opt_var_2, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nx + integer, intent(inout) :: var(:) + integer, optional, intent(in) :: opt_var(:) + real(kind=kind_phys), optional, intent(inout) :: opt_var_2(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Update var from opt_var if opt_var is present + if (present(opt_var)) then + var = 4 * opt_var + else + var = 7 * var + end if + ! Update opt_var_2 if present + if (present(opt_var_2)) then + opt_var_2 = opt_var_2 + 5.0_kind_phys + end if + end subroutine opt_arg_scheme_timestep_finalize end module opt_arg_scheme diff --git a/test_prebuild/test_unit_conv/ccpp_kinds.F90 b/test_prebuild/test_unit_conv/ccpp_kinds.F90 index cf6bfeaf..a07ded9b 100644 --- a/test_prebuild/test_unit_conv/ccpp_kinds.F90 +++ b/test_prebuild/test_unit_conv/ccpp_kinds.F90 @@ -1,13 +1,13 @@ module ccpp_kinds -!! \section arg_table_ccpp_kinds -!! \htmlinclude ccpp_kinds.html -!! + !! \section arg_table_ccpp_kinds + !! \htmlinclude ccpp_kinds.html + !! - use iso_fortran_env, only: real64 + use iso_fortran_env, only: real64 - implicit none + implicit none - integer, parameter :: kind_phys = real64 + integer, parameter :: kind_phys = real64 end module ccpp_kinds diff --git a/test_prebuild/test_unit_conv/data.F90 b/test_prebuild/test_unit_conv/data.F90 index 645a531b..ad6db921 100644 --- a/test_prebuild/test_unit_conv/data.F90 +++ b/test_prebuild/test_unit_conv/data.F90 @@ -1,24 +1,24 @@ module data -!! \section arg_table_data Argument Table -!! \htmlinclude data.html -!! - use ccpp_kinds, only : kind_phys - use ccpp_types, only: ccpp_t + !! \section arg_table_data Argument Table + !! \htmlinclude data.html + !! + use ccpp_kinds, only : kind_phys + use ccpp_types, only: ccpp_t - implicit none + implicit none - private + private - public ncols, ncolsrun, nspecies - public cdata, data_array, data_array2, opt_array_flag + public ncols, ncolsrun, nspecies + public cdata, data_array, data_array2, opt_array_flag - integer, parameter :: ncols = 4 - integer, parameter :: ncolsrun = ncols - integer, parameter :: nspecies = 2 - type(ccpp_t), target :: cdata - real(kind_phys), dimension(1:ncols,1:nspecies) :: data_array - real(kind_phys), dimension(1:ncols) :: data_array2 - logical :: opt_array_flag + integer, parameter :: ncols = 4 + integer, parameter :: ncolsrun = ncols + integer, parameter :: nspecies = 2 + type(ccpp_t), target :: cdata + real(kind=kind_phys), dimension(1:ncols, 1:nspecies) :: data_array + real(kind=kind_phys), dimension(1:ncols) :: data_array2 + logical :: opt_array_flag end module data diff --git a/test_prebuild/test_unit_conv/main.F90 b/test_prebuild/test_unit_conv/main.F90 index 3eb6462e..dabcebac 100644 --- a/test_prebuild/test_unit_conv/main.F90 +++ b/test_prebuild/test_unit_conv/main.F90 @@ -1,92 +1,96 @@ program test_unit_conv - use, intrinsic :: iso_fortran_env, only: error_unit - - use ccpp_types, only: ccpp_t - use data, only: ncols, nspecies - use data, only: cdata, data_array, data_array2, opt_array_flag - - use ccpp_static_api, only: ccpp_physics_init, & - ccpp_physics_timestep_init, & - ccpp_physics_run, & - ccpp_physics_timestep_finalize, & - ccpp_physics_finalize - - implicit none - - character(len=*), parameter :: ccpp_suite = 'unit_conv_suite' - integer :: ierr - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! For physics running over the entire domain, - ! ccpp_thread_number and ccpp_chunk_number are - ! set to 1, indicating that arrays are to be sent - ! following their dimension specification in the - ! metadata (must match horizontal_dimension). - cdata%thrd_no = 1 - cdata%chunk_no = 1 - cdata%thrd_cnt = 1 - - data_array = 1.0_8 - data_array2 = 42.0_8 - opt_array_flag = .true. - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics run step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_run:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_finalize:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if + use, intrinsic :: iso_fortran_env, only: error_unit + + use ccpp_types, only: ccpp_t + use data, only: ncols, & + nspecies + use data, only: cdata, & + data_array, & + data_array2, & + opt_array_flag + + use ccpp_static_api, only: ccpp_physics_init, & + ccpp_physics_timestep_init, & + ccpp_physics_run, & + ccpp_physics_timestep_finalize, & + ccpp_physics_finalize + + implicit none + + character(len=*), parameter :: ccpp_suite = 'unit_conv_suite' + integer :: ierr + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! For physics running over the entire domain, + ! ccpp_thread_number and ccpp_chunk_number are + ! set to 1, indicating that arrays are to be sent + ! following their dimension specification in the + ! metadata (must match horizontal_dimension). + cdata%thrd_no = 1 + cdata%chunk_no = 1 + cdata%thrd_cnt = 1 + + data_array = 1.0_8 + data_array2 = 42.0_8 + opt_array_flag = .true. + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics run step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_run:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_finalize:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if contains diff --git a/test_prebuild/test_unit_conv/unit_conv_scheme_1.F90 b/test_prebuild/test_unit_conv/unit_conv_scheme_1.F90 index 9ef178ff..5ef02560 100644 --- a/test_prebuild/test_unit_conv/unit_conv_scheme_1.F90 +++ b/test_prebuild/test_unit_conv/unit_conv_scheme_1.F90 @@ -4,62 +4,67 @@ module unit_conv_scheme_1 - use, intrinsic :: iso_fortran_env, only: error_unit - use ccpp_kinds, only : kind_phys - implicit none + use, intrinsic :: iso_fortran_env, only: error_unit + use ccpp_kinds, only : kind_phys + implicit none - private - public :: unit_conv_scheme_1_run + private + public :: unit_conv_scheme_1_run - !! This is for unit testing only - real(kind_phys), parameter :: target_value = 1.0_kind_phys - real(kind_phys), parameter :: target_value2 = 42.0_kind_phys + !! This is for unit testing only + real(kind=kind_phys), parameter :: target_value = 1.0_kind_phys + real(kind=kind_phys), parameter :: target_value2 = 42.0_kind_phys - contains +contains -!! \section arg_table_unit_conv_scheme_1_run Argument Table -!! \htmlinclude unit_conv_scheme_1_run.html -!! - subroutine unit_conv_scheme_1_run(data_array, data_array2, data_array_opt, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - real(kind_phys), intent(inout) :: data_array(:) - real(kind_phys), intent(inout) :: data_array2(:) - real(kind_phys), intent(inout), optional :: data_array_opt(:) + !! \section arg_table_unit_conv_scheme_1_run Argument Table + !! \htmlinclude unit_conv_scheme_1_run.html + !! + subroutine unit_conv_scheme_1_run(data_array, data_array2, data_array_opt, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind=kind_phys), intent(inout) :: data_array(:) + real(kind=kind_phys), intent(inout) :: data_array2(:) + real(kind=kind_phys), intent(inout), optional :: data_array_opt(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check values in data array - write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_1_run: checking min/max values of data array to be approximately ', target_value - if (minval(data_array)<0.99*target_value .or. maxval(data_array)>1.01*target_value) then - write(errmsg,'(3(a,e12.4),a)') "Error in unit_conv_scheme_1_run, expected values for data_array of approximately ", & - target_value, " but got [ ", minval(data_array), " : ", maxval(data_array), " ]" - errflg = 1 - return - end if - ! Check values in data array2 - write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_1_run: checking min/max values of data array 2 to be approximately ', target_value2 - if (minval(data_array2)<0.99*target_value2 .or. maxval(data_array2)>1.01*target_value2) then - write(errmsg,'(3(a,e12.4),a)') "Error in unit_conv_scheme_1_run, expected values for data array 2 of approximately ", & - target_value2, " but got [ ", minval(data_array2), " : ", maxval(data_array2), " ]" - errflg = 1 - return - end if - ! Check for presence of optional data array, then check its values - write(error_unit,'(a)') 'In unit_conv_scheme_1_run: checking for presence of optional data array' - if (.not. present(data_array_opt)) then - write(error_unit,'(a)') 'Error in unit_conv_scheme_1_run, optional data array expected but not present' - errflg = 1 - return - endif - write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_1_run: checking min/max values of optional data array to be approximately ', target_value - if (minval(data_array_opt)<0.99*target_value .or. maxval(data_array_opt)>1.01*target_value) then - write(errmsg,'(3(a,e12.4),a)') 'Error in unit_conv_scheme_1_run, expected values of approximately ', & - target_value, ' but got [ ', minval(data_array_opt), ' : ', maxval(data_array_opt), ' ]' - errflg = 1 - return - end if - end subroutine unit_conv_scheme_1_run + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check values in data array + write(error_unit, '(a,e12.4)') & + 'In unit_conv_scheme_1_run: checking min/max values of data array to be approximately ', target_value + if (minval(data_array) < 0.99 * target_value .or. maxval(data_array) > 1.01 * target_value) then + write(errmsg, '(3(a,e12.4),a)') & + "Error in unit_conv_scheme_1_run, expected values for data_array of approximately ", & + target_value, " but got [ ", minval(data_array), " : ", maxval(data_array), " ]" + errflg = 1 + return + end if + ! Check values in data array2 + write(error_unit, '(a,e12.4)') & + 'In unit_conv_scheme_1_run: checking min/max values of data array 2 to be approximately ', target_value2 + if (minval(data_array2) < 0.99 * target_value2 .or. maxval(data_array2) > 1.01 * target_value2) then + write(errmsg, '(3(a,e12.4),a)') & + "Error in unit_conv_scheme_1_run, expected values for data array 2 of approximately ", & + target_value2, " but got [ ", minval(data_array2), " : ", maxval(data_array2), " ]" + errflg = 1 + return + end if + ! Check for presence of optional data array, then check its values + write(error_unit, '(a)') 'In unit_conv_scheme_1_run: checking for presence of optional data array' + if ( .not. present(data_array_opt)) then + write(error_unit, '(a)') 'Error in unit_conv_scheme_1_run, optional data array expected but not present' + errflg = 1 + return + end if + write(error_unit, '(a,e12.4)') & + 'In unit_conv_scheme_1_run: checking min/max values of optional data array to be approximately ', target_value + if (minval(data_array_opt) < 0.99 * target_value .or. maxval(data_array_opt) > 1.01 * target_value) then + write(errmsg, '(3(a,e12.4),a)') 'Error in unit_conv_scheme_1_run, expected values of approximately ', & + target_value, ' but got [ ', minval(data_array_opt), ' : ', maxval(data_array_opt), ' ]' + errflg = 1 + return + end if + end subroutine unit_conv_scheme_1_run end module unit_conv_scheme_1 diff --git a/test_prebuild/test_unit_conv/unit_conv_scheme_2.F90 b/test_prebuild/test_unit_conv/unit_conv_scheme_2.F90 index 66f07d93..ddeee342 100644 --- a/test_prebuild/test_unit_conv/unit_conv_scheme_2.F90 +++ b/test_prebuild/test_unit_conv/unit_conv_scheme_2.F90 @@ -4,62 +4,66 @@ module unit_conv_scheme_2 - use, intrinsic :: iso_fortran_env, only: error_unit - use ccpp_kinds, only : kind_phys - implicit none + use, intrinsic :: iso_fortran_env, only: error_unit + use ccpp_kinds, only : kind_phys + implicit none - private - public :: unit_conv_scheme_2_run + private + public :: unit_conv_scheme_2_run - !! This is for unit testing only - real(kind_phys), parameter :: target_value = 1.0E-3_kind_phys - real(kind_phys), parameter :: target_value2 = 42.0_kind_phys + !! This is for unit testing only + real(kind=kind_phys), parameter :: target_value = 1.0E-3_kind_phys + real(kind=kind_phys), parameter :: target_value2 = 42.0_kind_phys - contains +contains -!! \section arg_table_unit_conv_scheme_2_run Argument Table -!! \htmlinclude unit_conv_scheme_2_run.html -!! - subroutine unit_conv_scheme_2_run(data_array, data_array2, data_array_opt, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - real(kind_phys), intent(inout) :: data_array(:) - real(kind_phys), intent(inout) :: data_array2(:) - real(kind_phys), intent(inout), optional :: data_array_opt(:) + !! \section arg_table_unit_conv_scheme_2_run Argument Table + !! \htmlinclude unit_conv_scheme_2_run.html + !! + subroutine unit_conv_scheme_2_run(data_array, data_array2, data_array_opt, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind=kind_phys), intent(inout) :: data_array(:) + real(kind=kind_phys), intent(inout) :: data_array2(:) + real(kind=kind_phys), intent(inout), optional :: data_array_opt(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check values in data array - write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_2_run: checking min/max values of data array to be approximately ', target_value - if (minval(data_array)<0.99*target_value .or. maxval(data_array)>1.01*target_value) then - write(errmsg,'(3(a,e12.4),a)') 'Error in unit_conv_scheme_2_run, expected values of approximately ', & - target_value, ' but got [ ', minval(data_array), ' : ', maxval(data_array), ' ]' - errflg = 1 - return - end if - ! Check values in data array2 - write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_2_run: checking min/max values of data array 2 to be approximately ', target_value2 - if (minval(data_array2)<0.99*target_value2 .or. maxval(data_array2)>1.01*target_value2) then - write(errmsg,'(3(a,e12.4),a)') "Error in unit_conv_scheme_2_run, expected values for data array 2 of approximately ", & - target_value2, " but got [ ", minval(data_array2), " : ", maxval(data_array2), " ]" - errflg = 1 - return - end if - ! Check for presence of optional data array, then check its values - write(error_unit,'(a)') 'In unit_conv_scheme_2_run: checking for presence of optional data array' - if (.not. present(data_array_opt)) then - write(error_unit,'(a)') 'Error in unit_conv_scheme_2_run, optional data array expected but not present' - errflg = 1 - return - endif - write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_2_run: checking min/max values of optional data array to be approximately ', target_value - if (minval(data_array_opt)<0.99*target_value .or. maxval(data_array_opt)>1.01*target_value) then - write(errmsg,'(3(a,e12.4),a)') 'Error in unit_conv_scheme_2_run, expected values of approximately ', & - target_value, ' but got [ ', minval(data_array_opt), ' : ', maxval(data_array_opt), ' ]' - errflg = 1 - return - end if - end subroutine unit_conv_scheme_2_run + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check values in data array + write(error_unit, '(a,e12.4)') & + 'In unit_conv_scheme_2_run: checking min/max values of data array to be approximately ', target_value + if (minval(data_array) < 0.99 * target_value .or. maxval(data_array) > 1.01 * target_value) then + write(errmsg, '(3(a,e12.4),a)') 'Error in unit_conv_scheme_2_run, expected values of approximately ', & + target_value, ' but got [ ', minval(data_array), ' : ', maxval(data_array), ' ]' + errflg = 1 + return + end if + ! Check values in data array2 + write(error_unit, '(a,e12.4)') & + 'In unit_conv_scheme_2_run: checking min/max values of data array 2 to be approximately ', target_value2 + if (minval(data_array2) < 0.99 * target_value2 .or. maxval(data_array2) > 1.01 * target_value2) then + write(errmsg, '(3(a,e12.4),a)') & + "Error in unit_conv_scheme_2_run, expected values for data array 2 of approximately ", & + target_value2, " but got [ ", minval(data_array2), " : ", maxval(data_array2), " ]" + errflg = 1 + return + end if + ! Check for presence of optional data array, then check its values + write(error_unit, '(a)') 'In unit_conv_scheme_2_run: checking for presence of optional data array' + if ( .not. present(data_array_opt)) then + write(error_unit, '(a)') 'Error in unit_conv_scheme_2_run, optional data array expected but not present' + errflg = 1 + return + end if + write(error_unit, '(a,e12.4)') & + 'In unit_conv_scheme_2_run: checking min/max values of optional data array to be approximately ', target_value + if (minval(data_array_opt) < 0.99 * target_value .or. maxval(data_array_opt) > 1.01 * target_value) then + write(errmsg, '(3(a,e12.4),a)') 'Error in unit_conv_scheme_2_run, expected values of approximately ', & + target_value, ' but got [ ', minval(data_array_opt), ' : ', maxval(data_array_opt), ' ]' + errflg = 1 + return + end if + end subroutine unit_conv_scheme_2_run end module unit_conv_scheme_2 From b0bf988506341e6f79d728cce9ad391603483d2b Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 23 Apr 2026 08:16:21 -0600 Subject: [PATCH 3/6] Revert Fortran formatting and update .codee-format and .github/workflows/fortran-formatting.yaml --- .codee-format | 2 +- .github/workflows/fortran-formatting.yaml | 28 +- doc/HelloWorld/hello_scheme.F90 | 92 +- doc/HelloWorld/hello_world_host.F90 | 45 +- doc/HelloWorld/hello_world_mod.F90 | 78 +- doc/HelloWorld/temp_adjust.F90 | 84 +- logging/logging.F90 | 320 +-- src/ccpp_constituent_prop_mod.F90 | 22 +- src/ccpp_hash_table.F90 | 6 +- src/ccpp_scheme_utils.F90 | 5 +- stub/data.F90 | 16 +- stub/stub.F90 | 48 +- .../apply_constituent_tendencies.F90 | 50 +- test/advection_test/cld_ice.F90 | 220 +- test/advection_test/cld_liq.F90 | 182 +- test/advection_test/const_indices.F90 | 173 +- test/advection_test/dlc_liq.F90 | 58 +- .../test_advection_host_integration.F90 | 137 +- test/advection_test/test_host.F90 | 2166 ++++++++--------- test/advection_test/test_host_data.F90 | 98 +- test/advection_test/test_host_mod.F90 | 323 ++- test/capgen_test/adjust/temp_kinds.F90 | 8 +- .../source_dir1/environ_conditions.F90 | 102 +- test/capgen_test/source_dir2/temp_set.F90 | 149 +- test/capgen_test/temp_adjust.F90 | 5 +- .../test_capgen_host_integration.F90 | 5 +- test/capgen_test/test_host.F90 | 11 +- test/capgen_test/test_host_mod.F90 | 5 +- test/ddthost_test/environ_conditions.F90 | 82 +- test/ddthost_test/host_ccpp_ddt.F90 | 22 +- test/ddthost_test/make_ddt.F90 | 241 +- test/ddthost_test/setup_coeffs.F90 | 6 +- test/ddthost_test/temp_set.F90 | 106 +- .../test_ddt_host_integration.F90 | 139 +- test/ddthost_test/test_host.F90 | 488 ++-- test/ddthost_test/test_host_data.F90 | 34 +- test/ddthost_test/test_host_mod.F90 | 181 +- test/hash_table_tests/test_hash.F90 | 401 ++- test/nested_suite_test/ccpp_kinds.F90 | 10 +- test/nested_suite_test/effr_calc.F90 | 154 +- test/nested_suite_test/effr_diag.F90 | 94 +- test/nested_suite_test/effr_post.F90 | 102 +- test/nested_suite_test/effr_pre.F90 | 98 +- test/nested_suite_test/effrs_calc.F90 | 34 +- test/nested_suite_test/module_rad_ddt.F90 | 10 +- test/nested_suite_test/rad_lw.F90 | 18 +- test/nested_suite_test/rad_sw.F90 | 18 +- test/nested_suite_test/test_host.F90 | 466 ++-- test/nested_suite_test/test_host_data.F90 | 117 +- test/nested_suite_test/test_host_mod.F90 | 182 +- .../test_nested_suite_integration.F90 | 157 +- .../sample_files/test_fortran_to_metadata.F90 | 22 +- .../sample_host_files/data1_mod.F90 | 12 +- test/unit_tests/sample_host_files/ddt1.F90 | 20 +- test/unit_tests/sample_host_files/ddt2.F90 | 32 +- .../sample_host_files/ddt2_extra_var.F90 | 46 +- .../sample_host_files/ddt_data1_mod.F90 | 42 +- .../sample_host_files/mismatch_hdim_mod.F90 | 12 +- .../sample_scheme_files/invalid_dummy_arg.F90 | 42 +- .../invalid_subr_stmnt.F90 | 20 +- .../sample_scheme_files/mismatch_hdim.F90 | 36 +- .../sample_scheme_files/mismatch_intent.F90 | 58 +- .../sample_scheme_files/missing_arg_table.F90 | 58 +- .../missing_fort_header.F90 | 58 +- .../sample_scheme_files/reorder.F90 | 58 +- .../sample_scheme_files/temp_adjust.F90 | 82 +- test/utils/test_utils.F90 | 150 +- test/var_compatibility_test/effr_calc.F90 | 154 +- test/var_compatibility_test/effr_diag.F90 | 94 +- test/var_compatibility_test/effr_post.F90 | 102 +- test/var_compatibility_test/effr_pre.F90 | 98 +- test/var_compatibility_test/effrs_calc.F90 | 34 +- .../var_compatibility_test/module_rad_ddt.F90 | 10 +- test/var_compatibility_test/rad_lw.F90 | 18 +- test/var_compatibility_test/rad_sw.F90 | 18 +- test/var_compatibility_test/test_host.F90 | 466 ++-- .../var_compatibility_test/test_host_data.F90 | 117 +- test/var_compatibility_test/test_host_mod.F90 | 182 +- .../test_var_compatibility_integration.F90 | 151 +- .../test_blocked_data/blocked_data_scheme.F90 | 212 +- test_prebuild/test_blocked_data/data.F90 | 54 +- test_prebuild/test_blocked_data/main.F90 | 217 +- .../test_chunked_data/chunked_data_scheme.F90 | 212 +- test_prebuild/test_chunked_data/data.F90 | 58 +- test_prebuild/test_chunked_data/main.F90 | 212 +- test_prebuild/test_opt_arg/ccpp_kinds.F90 | 12 +- test_prebuild/test_opt_arg/data.F90 | 28 +- test_prebuild/test_opt_arg/main.F90 | 238 +- test_prebuild/test_opt_arg/opt_arg_scheme.F90 | 152 +- test_prebuild/test_unit_conv/ccpp_kinds.F90 | 12 +- test_prebuild/test_unit_conv/data.F90 | 32 +- test_prebuild/test_unit_conv/main.F90 | 178 +- .../test_unit_conv/unit_conv_scheme_1.F90 | 109 +- .../test_unit_conv/unit_conv_scheme_2.F90 | 108 +- 94 files changed, 5776 insertions(+), 5848 deletions(-) diff --git a/.codee-format b/.codee-format index bf2b136d..57c14698 100644 --- a/.codee-format +++ b/.codee-format @@ -88,7 +88,7 @@ SpacesAroundOperators: Relational: Both RelationalLegacy: Both LogicalBinary: Both - LogicalNot: Both + LogicalNot: Trailing UnaryPlusMinus: NoTrailing Comma: OnlyTrailing Concat: Both diff --git a/.github/workflows/fortran-formatting.yaml b/.github/workflows/fortran-formatting.yaml index 968e20fb..977d5e2c 100644 --- a/.github/workflows/fortran-formatting.yaml +++ b/.github/workflows/fortran-formatting.yaml @@ -36,8 +36,32 @@ jobs: # Filter list of modified files to exclude certain files EXCLUDED_FILES=( - # file1 - # file2 + # Exclude all .F90 files in test/unit_tests/** + test/unit_tests/sample_files/test_fortran_to_metadata.F90 + test/unit_tests/sample_files/fortran_files/array_parsing_test.F90 + test/unit_tests/sample_files/fortran_files/linebreak_test.F90 + test/unit_tests/sample_files/fortran_files/long_string_test.F90 + test/unit_tests/sample_files/fortran_files/comments_test.F90 + test/unit_tests/sample_host_files/ddt1_plus.F90 + test/unit_tests/sample_host_files/mismatch_hdim_mod.F90 + test/unit_tests/sample_host_files/ddt1.F90 + test/unit_tests/sample_host_files/ddt2_extra_var.F90 + test/unit_tests/sample_host_files/ddt2.F90 + test/unit_tests/sample_host_files/ddt_data1_mod.F90 + test/unit_tests/sample_host_files/data1_mod.F90 + test/unit_tests/sample_scheme_files/CCPPnotset_var_missing_in_meta.F90 + test/unit_tests/sample_scheme_files/CCPPeq1_var_missing_in_meta.F90 + test/unit_tests/sample_scheme_files/missing_fort_header.F90 + test/unit_tests/sample_scheme_files/mismatch_intent.F90 + test/unit_tests/sample_scheme_files/CCPPgt1_var_in_fort_meta.F90 + test/unit_tests/sample_scheme_files/mismatch_hdim.F90 + test/unit_tests/sample_scheme_files/CCPPeq1_var_missing_in_fort.F90 + test/unit_tests/sample_scheme_files/temp_adjust.F90 + test/unit_tests/sample_scheme_files/CCPPeq1_var_in_fort_meta.F90 + test/unit_tests/sample_scheme_files/reorder.F90 + test/unit_tests/sample_scheme_files/invalid_dummy_arg.F90 + test/unit_tests/sample_scheme_files/invalid_subr_stmnt.F90 + test/unit_tests/sample_scheme_files/missing_arg_table.F90 ) FILTERED_FILES=() while IFS= read -r file; do diff --git a/doc/HelloWorld/hello_scheme.F90 b/doc/HelloWorld/hello_scheme.F90 index b97c3472..28019deb 100644 --- a/doc/HelloWorld/hello_scheme.F90 +++ b/doc/HelloWorld/hello_scheme.F90 @@ -1,64 +1,64 @@ !Hello demonstration parameterization ! -module hello_scheme +MODULE hello_scheme - use ccpp_kinds, only: kind_phys + USE ccpp_kinds, ONLY: kind_phys - implicit none - private + IMPLICIT NONE + PRIVATE - public :: hello_scheme_init - public :: hello_scheme_run - public :: hello_scheme_finalize + PUBLIC :: hello_scheme_init + PUBLIC :: hello_scheme_run + PUBLIC :: hello_scheme_finalize -contains +CONTAINS - !> \section arg_table_hello_scheme_run Argument Table - !! \htmlinclude arg_table_hello_scheme_run.html - !! - subroutine hello_scheme_run(ncol, lev, ilev, timestep, temp_level, & - temp_layer, errmsg, errflg) - !---------------------------------------------------------------- - implicit none - !---------------------------------------------------------------- +!> \section arg_table_hello_scheme_run Argument Table +!! \htmlinclude arg_table_hello_scheme_run.html +!! + SUBROUTINE hello_scheme_run(ncol, lev, ilev, timestep, temp_level, & + temp_layer, errmsg, errflg) +!---------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------- - integer, intent(in) :: ncol, lev, ilev - real(kind=kind_phys), intent(inout) :: temp_level(:, :) - real(kind=kind_phys), intent(in) :: timestep - real(kind=kind_phys), intent(out) :: temp_layer(:, :) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- + integer, intent(in) :: ncol, lev, ilev + REAL(kind_phys), intent(inout) :: temp_level(:, :) + real(kind_phys), intent(in) :: timestep + REAL(kind_phys), INTENT(out) :: temp_layer(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg +!---------------------------------------------------------------- - integer :: col_index - integer :: lev_index + integer :: col_index + integer :: lev_index errmsg = '' errflg = 0 if (ilev /= (lev + 1)) then - errflg = 1 - errmsg = 'Invalid value for ilev, must be lev+1' - return + errflg = 1 + errmsg = 'Invalid value for ilev, must be lev+1' + return end if do col_index = 1, ncol - do lev_index = 1, lev - temp_layer(col_index, lev_index) = (temp_level(col_index, lev_index) & - + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys - end do + do lev_index = 1, lev + temp_layer(col_index, lev_index) = (temp_level(col_index, lev_index) & + + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys + end do end do - end subroutine hello_scheme_run + END SUBROUTINE hello_scheme_run - !> \section arg_table_hello_scheme_init Argument Table - !! \htmlinclude arg_table_hello_scheme_init.html - !! - subroutine hello_scheme_init(errmsg, errflg) +!> \section arg_table_hello_scheme_init Argument Table +!! \htmlinclude arg_table_hello_scheme_init.html +!! + subroutine hello_scheme_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 @@ -67,13 +67,13 @@ subroutine hello_scheme_init(errmsg, errflg) end subroutine hello_scheme_init - !> \section arg_table_hello_scheme_finalize Argument Table - !! \htmlinclude arg_table_hello_scheme_finalize.html - !! - subroutine hello_scheme_finalize(errmsg, errflg) +!> \section arg_table_hello_scheme_finalize Argument Table +!! \htmlinclude arg_table_hello_scheme_finalize.html +!! + subroutine hello_scheme_finalize (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 @@ -82,4 +82,4 @@ subroutine hello_scheme_finalize(errmsg, errflg) end subroutine hello_scheme_finalize -end module hello_scheme +END MODULE hello_scheme diff --git a/doc/HelloWorld/hello_world_host.F90 b/doc/HelloWorld/hello_world_host.F90 index 2e2c3ee2..2c4066de 100644 --- a/doc/HelloWorld/hello_world_host.F90 +++ b/doc/HelloWorld/hello_world_host.F90 @@ -7,51 +7,50 @@ module hello_world_host public hello_world_sub -contains +CONTAINS !> \section arg_table_hello_world_sub Argument Table !! \htmlinclude arg_table_hello_world_sub.html !! subroutine hello_world_sub() - use hello_world_mod, only: ncols - use helloworld_ccpp_cap, only: helloworld_ccpp_physics_initialize - use helloworld_ccpp_cap, only: helloworld_ccpp_physics_timestep_initial - use helloworld_ccpp_cap, only: helloworld_ccpp_physics_run - use helloworld_ccpp_cap, only: helloworld_ccpp_physics_timestep_final - use helloworld_ccpp_cap, only: helloworld_ccpp_physics_finalize - use helloworld_ccpp_cap, only: ccpp_physics_suite_list - use helloworld_ccpp_cap, only: ccpp_physics_suite_part_list - use hello_world_mod, only: init_temp, & - compare_temp - - integer :: col_start, col_end - integer :: index + use hello_world_mod, only: ncols + use HelloWorld_ccpp_cap, only: HelloWorld_ccpp_physics_initialize + use HelloWorld_ccpp_cap, only: HelloWorld_ccpp_physics_timestep_initial + use HelloWorld_ccpp_cap, only: HelloWorld_ccpp_physics_run + use HelloWorld_ccpp_cap, only: HelloWorld_ccpp_physics_timestep_final + use HelloWorld_ccpp_cap, only: HelloWorld_ccpp_physics_finalize + use HelloWorld_ccpp_cap, only: ccpp_physics_suite_list + use HelloWorld_ccpp_cap, only: ccpp_physics_suite_part_list + use hello_world_mod, only: init_temp, compare_temp + + integer :: col_start, col_end + integer :: index character(len=128), allocatable :: part_names(:) - character(len=512) :: errmsg - integer :: errflg + character(len=512) :: errmsg + integer :: errflg ! Initialize our 'data' call init_temp() ! Use the suite information to setup the run - call helloworld_ccpp_physics_initialize('hello_world_suite', errmsg, errflg) + call HelloWorld_ccpp_physics_initialize('hello_world_suite', errmsg, errflg) if (errflg /= 0) then write(6, *) trim(errmsg) stop end if ! Initialize the timestep - call helloworld_ccpp_physics_timestep_initial('hello_world_suite', errmsg, errflg) + call HelloWorld_ccpp_physics_timestep_initial('hello_world_suite', errmsg, errflg) if (errflg /= 0) then write(6, *) trim(errmsg) stop end if do col_start = 1, ncols, 5 - col_end = min(col_start + 4, ncols) + col_end = MIN(col_start + 4, ncols) - call helloworld_ccpp_physics_run('hello_world_suite', 'physics', col_start, col_end, errmsg, errflg) + call HelloWorld_ccpp_physics_run('hello_world_suite', 'physics', col_start, col_end, errmsg, errflg) if (errflg /= 0) then write(6, *) trim(errmsg) call ccpp_physics_suite_part_list('hello_world_suite', part_names, errmsg, errflg) @@ -63,12 +62,12 @@ subroutine hello_world_sub() end if end do - call helloworld_ccpp_physics_timestep_final('hello_world_suite', errmsg, errflg) + call HelloWorld_ccpp_physics_timestep_final('hello_world_suite', errmsg, errflg) - call helloworld_ccpp_physics_finalize('hello_world_suite', errmsg, errflg) + call HelloWorld_ccpp_physics_finalize('hello_world_suite', errmsg, errflg) if (errflg /= 0) then write(6, *) trim(errmsg) - write(6, '(a)') 'An error occurred in ccpp_timestep_final, Exiting...' + write(6,'(a)') 'An error occurred in ccpp_timestep_final, Exiting...' stop end if diff --git a/doc/HelloWorld/hello_world_mod.F90 b/doc/HelloWorld/hello_world_mod.F90 index 42db1c5b..44b689dd 100644 --- a/doc/HelloWorld/hello_world_mod.F90 +++ b/doc/HelloWorld/hello_world_mod.F90 @@ -1,59 +1,59 @@ module hello_world_mod - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - public + implicit none + public - integer :: ntimes_loop - !> \section arg_table_hello_world_mod Argument Table - !! \htmlinclude arg_table_hello_world_host.html - !! - integer, parameter :: ncols = 10 - integer, parameter :: pver = 5 - integer, parameter :: pverp = 6 - real(kind=kind_phys) :: temp_midpoints(ncols, pver) - real(kind=kind_phys) :: temp_interfaces(ncols, pverp) - real(kind=kind_phys) :: dt + integer :: ntimes_loop + !> \section arg_table_hello_world_mod Argument Table + !! \htmlinclude arg_table_hello_world_host.html + !! + integer, parameter :: ncols = 10 + integer, parameter :: pver = 5 + integer, parameter :: pverp = 6 + real(kind_phys) :: temp_midpoints(ncols, pver) + real(kind_phys) :: temp_interfaces(ncols, pverp) + real(kind_phys) :: dt - public :: init_temp - public :: compare_temp + public :: init_temp + public :: compare_temp contains - subroutine init_temp() + subroutine init_temp() - integer :: col - integer :: lev + integer :: col + integer :: lev - temp_midpoints = 0.0_kind_phys - do lev = 1, pverp - do col = 1, ncols - temp_interfaces(col, lev) = real(((lev - 1) * ncols) + col, kind=kind_phys) + temp_midpoints = 0.0_kind_phys + do lev = 1, pverp + do col = 1, ncols + temp_interfaces(col, lev) = real(((lev - 1) * ncols) + col, kind=kind_phys) + end do end do - end do - end subroutine init_temp + end subroutine init_temp - logical function compare_temp() + logical function compare_temp() - integer :: col - integer :: lev - real(kind=kind_phys) :: avg + integer :: col + integer :: lev + real(kind_phys) :: avg - compare_temp = .true. + compare_temp = .true. - do lev = 1, pver - do col = 1, ncols - avg = (temp_interfaces(col, lev) + temp_interfaces(col, lev + 1)) - avg = 1.0_kind_phys + (avg / 2.0_kind_phys) - if (temp_midpoints(col, lev) /= avg) then - write(6, *) col, lev, temp_midpoints(col, lev), avg - compare_temp = .false. - end if + do lev = 1, pver + do col = 1, ncols + avg = (temp_interfaces(col,lev) + temp_interfaces(col,lev+1)) + avg = 1.0_kind_phys + (avg / 2.0_kind_phys) + if (temp_midpoints(col, lev) /= avg) then + write(6, *) col, lev, temp_midpoints(col, lev), avg + compare_temp = .false. + end if + end do end do - end do - end function compare_temp + end function compare_temp end module hello_world_mod diff --git a/doc/HelloWorld/temp_adjust.F90 b/doc/HelloWorld/temp_adjust.F90 index df8bc5b2..4b6f6186 100644 --- a/doc/HelloWorld/temp_adjust.F90 +++ b/doc/HelloWorld/temp_adjust.F90 @@ -1,57 +1,57 @@ !Hello demonstration parameterization ! -module temp_adjust +MODULE temp_adjust - use ccpp_kinds, only: kind_phys + USE ccpp_kinds, ONLY: kind_phys - implicit none - private + IMPLICIT NONE + PRIVATE - public :: temp_adjust_init - public :: temp_adjust_run - public :: temp_adjust_finalize + PUBLIC :: temp_adjust_init + PUBLIC :: temp_adjust_run + PUBLIC :: temp_adjust_finalize -contains +CONTAINS - !> \section arg_table_temp_adjust_run Argument Table - !! \htmlinclude arg_table_temp_adjust_run.html - !! - subroutine temp_adjust_run(nbox, lev, temp_layer, & - timestep, errmsg, errflg) - !---------------------------------------------------------------- - implicit none - !---------------------------------------------------------------- +!> \section arg_table_temp_adjust_run Argument Table +!! \htmlinclude arg_table_temp_adjust_run.html +!! + SUBROUTINE temp_adjust_run(nbox, lev, temp_layer, & + timestep, errmsg, errflg) +!---------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------- - integer, intent(in) :: nbox, lev - real(kind=kind_phys), intent(inout) :: temp_layer(:, :) - real(kind=kind_phys), intent(in) :: timestep - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- + integer, intent(in) :: nbox, lev + REAL(kind_phys), intent(inout) :: temp_layer(:, :) + real(kind_phys), intent(in) :: timestep + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg +!---------------------------------------------------------------- - integer :: box_index - integer :: lev_index + integer :: box_index + integer :: lev_index errmsg = '' errflg = 0 do box_index = 1, nbox - do lev_index = 1, lev - temp_layer(box_index, lev_index) = temp_layer(box_index, lev_index) & - + 1.0_kind_phys - end do + do lev_index = 1, lev + temp_layer(box_index, lev_index) = temp_layer(box_index, lev_index) & + + 1.0_kind_phys + end do end do - 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) +!> \section arg_table_temp_adjust_init Argument Table +!! \htmlinclude arg_table_temp_adjust_init.html +!! + 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 @@ -60,13 +60,13 @@ subroutine temp_adjust_init(errmsg, errflg) end subroutine temp_adjust_init - !> \section arg_table_temp_adjust_finalize Argument Table - !! \htmlinclude arg_table_temp_adjust_finalize.html - !! - subroutine temp_adjust_finalize(errmsg, errflg) +!> \section arg_table_temp_adjust_finalize Argument Table +!! \htmlinclude arg_table_temp_adjust_finalize.html +!! + subroutine temp_adjust_finalize (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 @@ -75,4 +75,4 @@ subroutine temp_adjust_finalize(errmsg, errflg) end subroutine temp_adjust_finalize -end module temp_adjust +END MODULE temp_adjust diff --git a/logging/logging.F90 b/logging/logging.F90 index 9567bd5e..59e82786 100644 --- a/logging/logging.F90 +++ b/logging/logging.F90 @@ -1,58 +1,58 @@ module marbl_logging - ! ============ - ! Module Usage - ! ============ - ! - ! Assume a variable named StatusLog (as appears in the marbl_interface_class) - ! - ! ----------------------------------------------- - ! Use the following routines to write log entries - ! ----------------------------------------------- - ! - ! (1) StatusLog%log_noerror -- this stores a log message in StatusLog that does - ! not contain a fatal error - ! (2) StatusLog%log_header -- this stores a log message in StatusLog that is - ! meant to be read as a section header; e.g. StatusLog%log_header('HEADER',...) - ! writes the following (including blank lines) - ! - ! ------ - ! HEADER - ! ------ - ! - ! (3) StatusLog%log_error -- this stores a log message in StatusLog that DOES - ! contain a fatal error. It does this by setting StatusLog%labort_marbl = - ! .true.; when a call from the GCM to MARBL returns, it is important for the - ! GCM to check the value of StatusLog%labort_marbl and abort the run if an - ! error has been reported. - ! (4) StatusLog%log_error_trace -- this stores a log message in StatusLog - ! detailing what subroutine was just called and where it was called from. It - ! is meant to provide more information when trying to trace the path through - ! the code that resulted in an error. - ! - ! ----------------------------------------------- - ! Pseudo-code for writing StatusLog in the driver - ! ----------------------------------------------- - ! - ! type(marbl_status_log_entry_type), pointer :: LogEntry - ! - ! ! Set pointer to first entry of the log - ! LogEntry => StatusLog%FullLog - ! - ! do while (associated(LogEntry)) - ! ! If running in parallel, you may want to check if you are the master - ! ! task or if LogEntry%lalltasks = .true. - ! write(stdout,*) trim(LogEntry%LogMessage) - ! LogEntry => LogEntry%next - ! end do - ! - ! ! Erase contents of log now that they have been written out - ! call StatusLog%erase() - ! - ! if (StatusLog%labort_marbl) then - ! [GCM abort call: "error found in MARBL"] - ! end if - ! +! ============ +! Module Usage +! ============ +! +! Assume a variable named StatusLog (as appears in the marbl_interface_class) +! +! ----------------------------------------------- +! Use the following routines to write log entries +! ----------------------------------------------- +! +! (1) StatusLog%log_noerror -- this stores a log message in StatusLog that does +! not contain a fatal error +! (2) StatusLog%log_header -- this stores a log message in StatusLog that is +! meant to be read as a section header; e.g. StatusLog%log_header('HEADER',...) +! writes the following (including blank lines) +! +! ------ +! HEADER +! ------ +! +! (3) StatusLog%log_error -- this stores a log message in StatusLog that DOES +! contain a fatal error. It does this by setting StatusLog%labort_marbl = +! .true.; when a call from the GCM to MARBL returns, it is important for the +! GCM to check the value of StatusLog%labort_marbl and abort the run if an +! error has been reported. +! (4) StatusLog%log_error_trace -- this stores a log message in StatusLog +! detailing what subroutine was just called and where it was called from. It +! is meant to provide more information when trying to trace the path through +! the code that resulted in an error. +! +! ----------------------------------------------- +! Pseudo-code for writing StatusLog in the driver +! ----------------------------------------------- +! +! type(marbl_status_log_entry_type), pointer :: LogEntry +! +! ! Set pointer to first entry of the log +! LogEntry => StatusLog%FullLog +! +! do while (associated(LogEntry)) +! ! If running in parallel, you may want to check if you are the master +! ! task or if LogEntry%lalltasks = .true. +! write(stdout,*) trim(LogEntry%LogMessage) +! LogEntry => LogEntry%next +! end do +! +! ! Erase contents of log now that they have been written out +! call StatusLog%erase() +! +! if (StatusLog%labort_marbl) then +! [GCM abort call: "error found in MARBL"] +! end if +! use marbl_kinds_mod, only : char_len @@ -60,16 +60,16 @@ module marbl_logging private save - integer, parameter, private :: marbl_log_len = 2 * char_len + integer, parameter, private :: marbl_log_len = 2*char_len !**************************************************************************** type, public :: marbl_status_log_entry_type - integer :: elementind = -1 ! ElementInd < 0 implies no location data - logical :: lonly_master_writes ! True => message should be written to stdout - ! master task; False => all tasks - character(len=marbl_log_len) :: logmessage ! Message text - character(len=char_len) :: codelocation ! Information on where log was written + integer :: ElementInd = -1 ! ElementInd < 0 implies no location data + logical :: lonly_master_writes ! True => message should be written to stdout + ! master task; False => all tasks + character(len=marbl_log_len) :: LogMessage ! Message text + character(len=char_len) :: CodeLocation ! Information on where log was written type(marbl_status_log_entry_type), pointer :: next end type marbl_status_log_entry_type @@ -89,12 +89,12 @@ module marbl_logging ! code in this file. type, private :: marbl_log_output_options_type logical :: labort_on_warning ! True => elevate Warnings to Errors - logical :: llogverbose ! Debugging output should be given Verbose label - logical :: llognamelist ! Write namelists to log? - logical :: lloggeneral ! General diagnostic output - logical :: llogwarning ! Warnings (can be elevated to errors via labort_on_warning) - logical :: llogerror ! Errors (will toggle labort_marbl whether log - ! is written or not) + logical :: lLogVerbose ! Debugging output should be given Verbose label + logical :: lLogNamelist ! Write namelists to log? + logical :: lLogGeneral ! General diagnostic output + logical :: lLogWarning ! Warnings (can be elevated to errors via labort_on_warning) + logical :: lLogError ! Errors (will toggle labort_marbl whether log + ! is written or not) contains procedure :: construct => marbl_output_options_constructor end type marbl_log_output_options_type @@ -103,17 +103,17 @@ module marbl_logging type, public :: marbl_log_type logical, private :: lconstructed = .false. ! True => constructor was already called - logical, public :: labort_marbl = .false. ! True => driver should abort GCM - logical, public :: lwarning = .false. ! True => warnings are present - type(marbl_log_output_options_type) :: outputoptions - type(marbl_status_log_entry_type), pointer :: fulllog - type(marbl_status_log_entry_type), pointer :: lastentry + logical, public :: labort_marbl = .false. ! True => driver should abort GCM + logical, public :: lwarning = .false. ! True => warnings are present + type(marbl_log_output_options_type) :: OutputOptions + type(marbl_status_log_entry_type), pointer :: FullLog + type(marbl_status_log_entry_type), pointer :: LastEntry contains procedure, public :: construct => marbl_log_constructor - procedure, public :: log_header => marbl_log_header - procedure, public :: log_error => marbl_log_error - procedure, public :: log_warning => marbl_log_warning - procedure, public :: log_noerror => marbl_log_noerror + procedure, public :: log_header => marbl_log_header + procedure, public :: log_error => marbl_log_error + procedure, public :: log_warning => marbl_log_warning + procedure, public :: log_noerror => marbl_log_noerror procedure, public :: log_error_trace => marbl_log_error_trace procedure, public :: log_warning_trace => marbl_log_warning_trace procedure, public :: erase => marbl_log_erase @@ -126,12 +126,12 @@ module marbl_logging !**************************************************************************** - subroutine marbl_output_options_constructor(this, labort_on_warning, logverbose, lognamelist, & - loggeneral, logwarning, logerror) + subroutine marbl_output_options_constructor(this, labort_on_warning, LogVerbose, LogNamelist, & + LogGeneral, LogWarning, LogError) class(marbl_log_output_options_type), intent(inout) :: this - logical, intent(in), optional :: labort_on_warning, logverbose, lognamelist - logical, intent(in), optional :: loggeneral, logwarning, logerror + logical, intent(in), optional :: labort_on_warning, LogVerbose, LogNamelist + logical, intent(in), optional :: LogGeneral, LogWarning, LogError if (present(labort_on_warning)) then this%labort_on_warning = labort_on_warning @@ -139,34 +139,34 @@ subroutine marbl_output_options_constructor(this, labort_on_warning, logverbose, this%labort_on_warning = .false. end if - if (present(logverbose)) then - this%llogverbose = logverbose + if (present(LogVerbose)) then + this%lLogVerbose = LogVerbose else - this%llogverbose = .false. + this%lLogVerbose = .false. end if - if (present(lognamelist)) then - this%llognamelist = lognamelist + if (present(LogNamelist)) then + this%lLogNamelist = LogNamelist else - this%llognamelist = .true. + this%lLogNamelist = .true. end if - if (present(loggeneral)) then - this%lloggeneral = loggeneral + if (present(LogGeneral)) then + this%lLogGeneral = LogGeneral else - this%lloggeneral = .true. + this%lLogGeneral = .true. end if - if (present(logwarning)) then - this%llogwarning = logwarning + if (present(LogWarning)) then + this%lLogWarning = LogWarning else - this%llogwarning = .true. + this%lLogWarning = .true. end if - if (present(logerror)) then - this%llogerror = logerror + if (present(LogError)) then + this%lLogError = LogError else - this%llogerror = .true. + this%lLogError = .true. end if end subroutine marbl_output_options_constructor @@ -179,162 +179,162 @@ subroutine marbl_log_constructor(this) if (this%lconstructed) return this%lconstructed = .true. - nullify(this%fulllog) - nullify(this%lastentry) - call this%outputoptions%construct() + nullify(this%FullLog) + nullify(this%LastEntry) + call this%OutputOptions%construct() end subroutine marbl_log_constructor !**************************************************************************** - subroutine marbl_log_header(this, headermsg, codeloc) + subroutine marbl_log_header(this, HeaderMsg, CodeLoc) class(marbl_log_type), intent(inout) :: this ! StatusMsg is the message to be printed in the log; it does not need to ! contain the name of the module or subroutine producing the log message ! CodeLoc is the name of the subroutine that is calling StatusLog%log_noerror - character(len=*), intent(in) :: headermsg, codeloc + character(len=*), intent(in) :: HeaderMsg, CodeLoc - character(len=len_trim(headermsg)) :: dashes + character(len=len_trim(HeaderMsg)) :: dashes integer :: n - do n = 1, len(dashes) + do n=1, len(dashes) dashes(n:n) = '-' end do - call this%log_noerror('', codeloc) - call this%log_noerror(dashes, codeloc) - call this%log_noerror(headermsg, codeloc) - call this%log_noerror(dashes, codeloc) - call this%log_noerror('', codeloc) + call this%log_noerror('', CodeLoc) + call this%log_noerror(dashes, CodeLoc) + call this%log_noerror(HeaderMsg, CodeLoc) + call this%log_noerror(dashes, CodeLoc) + call this%log_noerror('', CodeLoc) end subroutine marbl_log_header !**************************************************************************** - subroutine marbl_log_error(this, errormsg, codeloc, elemind) + subroutine marbl_log_error(this, ErrorMsg, CodeLoc, ElemInd) class(marbl_log_type), intent(inout) :: this ! ErrorMsg is the error message to be printed in the log; it does not need ! to contain the name of the module or subroutine triggering the error ! CodeLoc is the name of the subroutine that is calling StatusLog%log_error - character(len=*), intent(in) :: errormsg, codeloc - integer, optional, intent(in) :: elemind + character(len=*), intent(in) :: ErrorMsg, CodeLoc + integer, optional, intent(in) :: ElemInd - character(len=marbl_log_len) :: errormsg_loc ! Message text + character(len=marbl_log_len) :: ErrorMsg_loc ! Message text this%labort_marbl = .true. ! Only allocate memory and add entry if we want to log full namelist! - if ( .not. this%outputoptions%llogerror) then + if (.not.this%OutputOptions%lLogError) then return end if - write(errormsg_loc, "(4A)") "MARBL ERROR (", trim(codeloc), "): ", & - trim(errormsg) + write(ErrorMsg_loc, "(4A)") "MARBL ERROR (", trim(CodeLoc), "): ", & + trim(ErrorMsg) - call this%append_to_log(errormsg_loc, codeloc, elemind, lonly_master_writes=.false.) + call this%append_to_log(ErrorMsg_loc, CodeLoc, ElemInd, lonly_master_writes=.false.) end subroutine marbl_log_error !**************************************************************************** - subroutine marbl_log_warning(this, warningmsg, codeloc, elemind) + subroutine marbl_log_warning(this, WarningMsg, CodeLoc, ElemInd) class(marbl_log_type), intent(inout) :: this ! WarningMsg is the message to be printed in the log; it does not need to ! contain the name of the module or subroutine producing the log message ! CodeLoc is the name of the subroutine that is calling StatusLog%log_warning - character(len=*), intent(in) :: warningmsg, codeloc - integer, optional, intent(in) :: elemind + character(len=*), intent(in) :: WarningMsg, CodeLoc + integer, optional, intent(in) :: ElemInd - character(len=marbl_log_len) :: warningmsg_loc ! Message text + character(len=marbl_log_len) :: WarningMsg_loc ! Message text this%lwarning = .true. ! Only allocate memory and add entry if we want to log full namelist! - if ( .not. this%outputoptions%llogwarning) then + if (.not.this%OutputOptions%lLogWarning) then return end if - write(warningmsg_loc, "(4A)") "MARBL WARNING (", trim(codeloc), "): ", & - trim(warningmsg) + write(WarningMsg_loc, "(4A)") "MARBL WARNING (", trim(CodeLoc), "): ", & + trim(WarningMsg) - call this%append_to_log(warningmsg_loc, codeloc, elemind, lonly_master_writes=.false.) + call this%append_to_log(WarningMsg_loc, CodeLoc, ElemInd, lonly_master_writes=.false.) end subroutine marbl_log_warning !**************************************************************************** - subroutine marbl_log_noerror(this, statusmsg, codeloc, elemind, lonly_master_writes) + subroutine marbl_log_noerror(this, StatusMsg, CodeLoc, ElemInd, lonly_master_writes) class(marbl_log_type), intent(inout) :: this ! StatusMsg is the message to be printed in the log; it does not need to ! contain the name of the module or subroutine producing the log message ! CodeLoc is the name of the subroutine that is calling StatusLog%log_noerror - character(len=*), intent(in) :: statusmsg, codeloc - integer, optional, intent(in) :: elemind + character(len=*), intent(in) :: StatusMsg, CodeLoc + integer, optional, intent(in) :: ElemInd ! If lonly_master_writes is .false., then this is a message that should be ! printed out regardless of which task produced it. By default, MARBL assumes ! that only the master task needs to print a message - logical, optional, intent(in) :: lonly_master_writes + logical, optional, intent(in) :: lonly_master_writes ! Only allocate memory and add entry if we want to log full namelist! - if ( .not. this%outputoptions%lloggeneral) then + if (.not.this%OutputOptions%lLogGeneral) then return end if - call this%append_to_log(statusmsg, codeloc, elemind, lonly_master_writes) + call this%append_to_log(StatusMsg, CodeLoc, ElemInd, lonly_master_writes) end subroutine marbl_log_noerror !**************************************************************************** - subroutine append_to_log(this, statusmsg, codeloc, elemind, lonly_master_writes) + subroutine append_to_log(this, StatusMsg, CodeLoc, ElemInd, lonly_master_writes) class(marbl_log_type), intent(inout) :: this ! StatusMsg is the message to be printed in the log; it does not need to ! contain the name of the module or subroutine producing the log message ! CodeLoc is the name of the subroutine that is calling StatusLog%log_noerror - character(len=*), intent(in) :: statusmsg, codeloc - integer, optional, intent(in) :: elemind + character(len=*), intent(in) :: StatusMsg, CodeLoc + integer, optional, intent(in) :: ElemInd ! If lonly_master_writes is .false., then this is a message that should be ! printed out regardless of which task produced it. By default, MARBL assumes ! that only the master task needs to print a message - logical, optional, intent(in) :: lonly_master_writes + logical, optional, intent(in) :: lonly_master_writes type(marbl_status_log_entry_type), pointer :: new_entry allocate(new_entry) nullify(new_entry%next) - if (present(elemind)) then - new_entry%elementind = elemind + if (present(ElemInd)) then + new_entry%ElementInd = ElemInd else - new_entry%elementind = -1 + new_entry%ElementInd = -1 end if - new_entry%logmessage = trim(statusmsg) - new_entry%codelocation = trim(codeloc) + new_entry%LogMessage = trim(StatusMsg) + new_entry%CodeLocation = trim(CodeLoc) if (present(lonly_master_writes)) then new_entry%lonly_master_writes = lonly_master_writes else new_entry%lonly_master_writes = .true. end if - if (associated(this%fulllog)) then + if (associated(this%FullLog)) then ! Append new entry to last entry in the log - this%lastentry%next => new_entry + this%LastEntry%next => new_entry else - this%fulllog => new_entry + this%FullLog => new_entry end if ! Update LastEntry attribute of linked list - this%lastentry => new_entry + this%LastEntry => new_entry end subroutine append_to_log !**************************************************************************** - subroutine marbl_log_error_trace(this, routinename, codeloc, elemind) + subroutine marbl_log_error_trace(this, RoutineName, CodeLoc, ElemInd) - ! This routine should only be called if another subroutine has returned and - ! StatusLog%labort_marbl = .true. + ! This routine should only be called if another subroutine has returned and + ! StatusLog%labort_marbl = .true. class(marbl_log_type), intent(inout) :: this ! RoutineName is the name of the subroutine that returned with @@ -347,21 +347,21 @@ subroutine marbl_log_error_trace(this, routinename, codeloc, elemind) ! ! When the log is printed, this will provide a traceback through the sequence ! of calls that led to the original error message. - character(len=*), intent(in) :: routinename, codeloc - integer, optional, intent(in) :: elemind + character(len=*), intent(in) :: RoutineName, CodeLoc + integer, optional, intent(in) :: ElemInd character(len=char_len) :: log_message - write(log_message, "(2A)") "Error reported from ", trim(routinename) - call this%log_error(log_message, codeloc, elemind) + write(log_message, "(2A)") "Error reported from ", trim(RoutineName) + call this%log_error(log_message, CodeLoc, ElemInd) end subroutine marbl_log_error_trace !**************************************************************************** - subroutine marbl_log_warning_trace(this, routinename, codeloc, elemind) + subroutine marbl_log_warning_trace(this, RoutineName, CodeLoc, ElemInd) - ! This routine should only be called if another subroutine has returned and - ! StatusLog%lwarning = .true. + ! This routine should only be called if another subroutine has returned and + ! StatusLog%lwarning = .true. class(marbl_log_type), intent(inout) :: this ! RoutineName is the name of the subroutine that returned with @@ -374,12 +374,12 @@ subroutine marbl_log_warning_trace(this, routinename, codeloc, elemind) ! ! When the log is printed, this will provide a traceback through the sequence ! of calls that led to the original warning message. - character(len=*), intent(in) :: routinename, codeloc - integer, optional, intent(in) :: elemind + character(len=*), intent(in) :: RoutineName, CodeLoc + integer, optional, intent(in) :: ElemInd character(len=char_len) :: log_message - write(log_message, "(2A)") "Warning reported from ", trim(routinename) - call this%log_warning(log_message, codeloc, elemind) + write(log_message, "(2A)") "Warning reported from ", trim(RoutineName) + call this%log_warning(log_message, CodeLoc, ElemInd) this%lwarning = .false. end subroutine marbl_log_warning_trace @@ -391,13 +391,13 @@ subroutine marbl_log_erase(this) class(marbl_log_type), intent(inout) :: this type(marbl_status_log_entry_type), pointer :: tmp - do while (associated(this%fulllog)) - tmp => this%fulllog%next - deallocate(this%fulllog) - this%fulllog => tmp + do while (associated(this%FullLog)) + tmp => this%FullLog%next + deallocate(this%FullLog) + this%FullLog => tmp end do - nullify(this%fulllog) - nullify(this%lastentry) + nullify(this%FullLog) + nullify(this%LastEntry) this%lwarning = .false. diff --git a/src/ccpp_constituent_prop_mod.F90 b/src/ccpp_constituent_prop_mod.F90 index 851d20c4..d75be966 100644 --- a/src/ccpp_constituent_prop_mod.F90 +++ b/src/ccpp_constituent_prop_mod.F90 @@ -3,10 +3,8 @@ module ccpp_constituent_prop_mod ! ccpp_contituent_prop_mod contains types and procedures for storing ! and retrieving constituent properties - use ccpp_hashable, only: ccpp_hashable_t, & - ccpp_hashable_char_t - use ccpp_hash_table, only: ccpp_hash_table_t, & - ccpp_hash_iterator_t + use ccpp_hashable, only: ccpp_hashable_t, ccpp_hashable_char_t + use ccpp_hash_table, only: ccpp_hash_table_t, ccpp_hash_iterator_t use ccpp_kinds, only: kind_phys implicit none @@ -370,7 +368,7 @@ logical function ccp_is_instantiated(this, errcode, errmsg) ccp_is_instantiated = allocated(this%var_std_name) call initialize_errvars(errcode, errmsg) - if ( .not. ccp_is_instantiated) then + if (.not.ccp_is_instantiated) then call append_errvars(1, "ccpp_constituent_properties_t object is not initialized", & subname, errcode=errcode, errmsg=errmsg) end if @@ -1095,7 +1093,7 @@ logical function ccp_model_const_locked(this, errcode, errmsg, warn_func) ! Use an initialized hash table as double check if (this%hash_table%is_initialized()) then ccp_model_const_locked = this%table_locked .and. this%data_locked - if (( .not. (this%table_locked .and. this%data_locked)) .and. & + if ((.not.(this%table_locked .and. this%data_locked)) .and. & present(errmsg) .and. present(warn_func)) then ! Write a warning as a courtesy to calling function but do not set ! errcode (let caller decide). @@ -1127,7 +1125,7 @@ logical function ccp_model_const_props_locked(this, errcode, errmsg, warn_func) ! Use an initialized hash table as double check if (this%hash_table%is_initialized()) then ccp_model_const_props_locked = this%table_locked - if ( .not. this%table_locked .and. & + if (.not.this%table_locked .and. & present(errmsg) .and. present(warn_func)) then ! Write a warning as a courtesy to calling function but do not set ! errcode (let caller decide). @@ -1160,7 +1158,7 @@ logical function ccp_model_const_data_locked(this, errcode, errmsg, warn_func) ! Use an initialized hash table as double check if (this%hash_table%is_initialized()) then ccp_model_const_data_locked = this%data_locked - if ( .not. this%data_locked .and. & + if (.not.this%data_locked .and. & present(errmsg) .and. present(warn_func)) then ! Write a warning as a courtesy to calling function but do not set ! errcode (let caller decide). @@ -1193,10 +1191,10 @@ logical function ccp_model_const_okay_to_add(this, errcode, errmsg, & ccp_model_const_okay_to_add = this%hash_table%is_initialized() if (ccp_model_const_okay_to_add) then - ccp_model_const_okay_to_add = .not. (this%const_props_locked(errcode=errcode, & + ccp_model_const_okay_to_add = .not.(this%const_props_locked(errcode=errcode, & errmsg=errmsg, warn_func=subname) .or. this%const_data_locked(errcode=errcode, & errmsg=errmsg, warn_func=subname)) - if ( .not. ccp_model_const_okay_to_add) then + if (.not.ccp_model_const_okay_to_add) then call append_errvars(1, & "WARNING: Model constituents are locked", & subname, errcode=errcode, errmsg=errmsg, caller=warn_func) @@ -1442,7 +1440,7 @@ subroutine ccp_model_const_table_lock(this, errcode, errmsg) call this%const_metadata(index_const)%set(cprop) end if ! Make sure this is a layer variable - if ( .not. cprop%is_layer_var()) then + if (.not.cprop%is_layer_var()) then call cprop%vertical_dimension(dimname, & errcode=errcode, errmsg=errmsg) call append_errvars(1, "ERROR: Bad vertical dimension, '" // & @@ -1512,7 +1510,7 @@ subroutine ccp_model_const_data_lock(this, ncols, num_layers, errcode, errmsg) "WARNING: Model constituent data already locked, ignoring", & subname, errcode=errcode, errmsg=errmsg) errcode_local = errcode_local + 1 - else if ( .not. this%const_props_locked(errcode=errcode, errmsg=errmsg, & + else if (.not.this%const_props_locked(errcode=errcode, errmsg=errmsg, & warn_func=subname)) then call append_errvars(1, & "WARNING: Model constituent properties not yet locked, ignoring", & diff --git a/src/ccpp_hash_table.F90 b/src/ccpp_hash_table.F90 index dc9ff2ec..685c9049 100644 --- a/src/ccpp_hash_table.F90 +++ b/src/ccpp_hash_table.F90 @@ -260,8 +260,8 @@ function hash_table_table_value(this, key, errmsg) result(tbl_val) end if end if - if (( .not. associated(tbl_val)) .and. present(errmsg)) then - if ( .not. have_error(errmsg)) then ! Still need to test for empty + if ((.not.associated(tbl_val)) .and. present(errmsg)) then + if (.not.have_error(errmsg)) then ! Still need to test for empty write(errmsg, *) subname, ": No entry for '", trim(key), "'" end if end if @@ -453,7 +453,7 @@ subroutine hash_iterator_next_entry(this) end if if (has_table_next) then this%table_entry => this%table_entry%next - else if (( .not. has_table_entry) .and. & + else if ((.not.has_table_entry) .and. & associated(this%hash_table%table(this%index)%next)) then this%table_entry => this%hash_table%table(this%index)%next else diff --git a/src/ccpp_scheme_utils.F90 b/src/ccpp_scheme_utils.F90 index 913e9040..f6920e85 100644 --- a/src/ccpp_scheme_utils.F90 +++ b/src/ccpp_scheme_utils.F90 @@ -2,8 +2,7 @@ module ccpp_scheme_utils ! Module of utilities available to CCPP schemes - use ccpp_constituent_prop_mod, only: ccpp_model_constituents_t, & - int_unassigned + use ccpp_constituent_prop_mod, only: ccpp_model_constituents_t, int_unassigned implicit none private @@ -63,7 +62,7 @@ subroutine ccpp_initialize_constituent_ptr(const_obj) ! Dummy arguments type(ccpp_model_constituents_t), pointer, intent(in) :: const_obj - if ( .not. initialized) then + if (.not.initialized) then constituent_obj => const_obj initialized = .true. end if diff --git a/stub/data.F90 b/stub/data.F90 index b65dad75..d2a21c15 100644 --- a/stub/data.F90 +++ b/stub/data.F90 @@ -1,17 +1,17 @@ module data - !! \section arg_table_data Argument Table - !! \htmlinclude data.html - !! +!! \section arg_table_data Argument Table +!! \htmlinclude data.html +!! - use ccpp_types, only: ccpp_t + use ccpp_types, only: ccpp_t - implicit none + implicit none - private + private - public ccpp_data + public ccpp_data - type(ccpp_t), save, target :: ccpp_data + type(ccpp_t), save, target :: ccpp_data end module data diff --git a/stub/stub.F90 b/stub/stub.F90 index 009294b6..0b392daa 100644 --- a/stub/stub.F90 +++ b/stub/stub.F90 @@ -4,32 +4,32 @@ module stub - implicit none - private - public :: stub_init, stub_finalize + implicit none + private + public :: stub_init, stub_finalize -contains + contains - !! \section arg_table_stub_init Argument Table - !! \htmlinclude stub_init.html - !! - subroutine stub_init(errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - end subroutine stub_init +!! \section arg_table_stub_init Argument Table +!! \htmlinclude stub_init.html +!! + subroutine stub_init(errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + end subroutine stub_init - !! \section arg_table_stub_finalize Argument Table - !! \htmlinclude stub_finalize.html - !! - subroutine stub_finalize(errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - end subroutine stub_finalize +!! \section arg_table_stub_finalize Argument Table +!! \htmlinclude stub_finalize.html +!! + subroutine stub_finalize(errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + end subroutine stub_finalize end module stub diff --git a/test/advection_test/apply_constituent_tendencies.F90 b/test/advection_test/apply_constituent_tendencies.F90 index 63a1881c..150b1190 100644 --- a/test/advection_test/apply_constituent_tendencies.F90 +++ b/test/advection_test/apply_constituent_tendencies.F90 @@ -7,33 +7,33 @@ module apply_constituent_tendencies public :: apply_constituent_tendencies_run -contains - - !> \section arg_table_apply_constituent_tendencies_run Argument Table - !!! \htmlinclude apply_constituent_tendencies_run.html - subroutine apply_constituent_tendencies_run(const_tend, const, errcode, errmsg) - ! Dummy arguments - real(kind=kind_phys), intent(inout) :: const_tend(:, :, :) ! constituent tendency array - real(kind=kind_phys), intent(inout) :: const(:, :, :) ! constituent state array - integer, intent(out) :: errcode - character(len=512), intent(out) :: errmsg - - ! Local variables - integer :: klev, jcnst, icol - - errcode = 0 - errmsg = '' - - do icol = 1, size(const_tend, 1) - do klev = 1, size(const_tend, 2) - do jcnst = 1, size(const_tend, 3) - const(icol, klev, jcnst) = const(icol, klev, jcnst) + const_tend(icol, klev, jcnst) - end do +CONTAINS + + !> \section arg_table_apply_constituent_tendencies_run Argument Table + !!! \htmlinclude apply_constituent_tendencies_run.html + subroutine apply_constituent_tendencies_run(const_tend, const, errcode, errmsg) + ! Dummy arguments + real(kind_phys), intent(inout) :: const_tend(:,:,:) ! constituent tendency array + real(kind_phys), intent(inout) :: const(:,:,:) ! constituent state array + integer, intent(out) :: errcode + character(len=512), intent(out) :: errmsg + + ! Local variables + integer :: klev, jcnst, icol + + errcode = 0 + errmsg = '' + + do icol = 1, size(const_tend, 1) + do klev = 1, size(const_tend, 2) + do jcnst = 1, size(const_tend, 3) + const(icol, klev, jcnst) = const(icol, klev, jcnst) + const_tend(icol, klev, jcnst) + end do + end do end do - end do - const_tend = 0._kind_phys + const_tend = 0._kind_phys - end subroutine apply_constituent_tendencies_run + end subroutine apply_constituent_tendencies_run end module apply_constituent_tendencies diff --git a/test/advection_test/cld_ice.F90 b/test/advection_test/cld_ice.F90 index 3ace2f91..15f5b502 100644 --- a/test/advection_test/cld_ice.F90 +++ b/test/advection_test/cld_ice.F90 @@ -1,127 +1,127 @@ ! Test parameterization with advected species ! -module cld_ice - - use ccpp_kinds, only: kind_phys - - implicit none - private - - public :: cld_ice_register - public :: cld_ice_init - public :: cld_ice_run - public :: cld_ice_final - - real(kind=kind_phys), private :: tcld = huge(1.0_kind_phys) - -contains - - !> \section arg_table_cld_ice_register Argument Table - !! \htmlinclude arg_table_cld_ice_register.html - !! - subroutine cld_ice_register(dyn_const_ice, errmsg, errcode) - use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t - type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const_ice(:) - integer, intent(out) :: errcode - character(len=512), intent(out) :: errmsg - - errmsg = '' - errcode = 0 - allocate(dyn_const_ice(2), stat=errcode) - if (errcode /= 0) then - errmsg = 'Error allocating dyn_const in cld_ice_dynamic_constituents' - return - end if - call dyn_const_ice(1)%instantiate(std_name='dyn_const1', long_name='dyn const1', & - diag_name='DYNCONST1', units='kg kg-1', default_value=0._kind_phys, & - vertical_dim='vertical_layer_dimension', advected=.true., & - min_value=1000._kind_phys, water_species=.true., mixing_ratio_type='wet', & - errcode=errcode, errmsg=errmsg) - call dyn_const_ice(2)%instantiate(std_name='dyn_const2_wrt_moist_air', long_name='dyn const2', & - diag_name='DYNCONST2', units='kg kg-1', default_value=0._kind_phys, & - vertical_dim='vertical_layer_dimension', advected=.true., & - water_species=.false., errcode=errcode, errmsg=errmsg) - - end subroutine cld_ice_register - - !> \section arg_table_cld_ice_run Argument Table - !! \htmlinclude arg_table_cld_ice_run.html - !! - subroutine cld_ice_run(ncol, timestep, temp, qv, ps, cld_ice_array, & - errmsg, errflg) - - integer, intent(in) :: ncol - real(kind=kind_phys), intent(in) :: timestep - real(kind=kind_phys), intent(inout) :: temp(:, :) - real(kind=kind_phys), intent(inout) :: qv(:, :) - real(kind=kind_phys), intent(in) :: ps(:) - real(kind=kind_phys), intent(inout) :: cld_ice_array(:, :) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - - integer :: icol - integer :: ilev - real(kind=kind_phys) :: frz - - errmsg = '' - errflg = 0 - - ! Apply state-of-the-art thermodynamics :) - do icol = 1, ncol - do ilev = 1, size(temp, 2) - if (temp(icol, ilev) < tcld) then - frz = max(qv(icol, ilev) - 0.5_kind_phys, 0.0_kind_phys) - cld_ice_array(icol, ilev) = cld_ice_array(icol, ilev) + frz - qv(icol, ilev) = qv(icol, ilev) - frz - if (frz > 0.0_kind_phys) then - temp(icol, ilev) = temp(icol, ilev) + 1.0_kind_phys - end if - end if +MODULE cld_ice + + USE ccpp_kinds, ONLY: kind_phys + + IMPLICIT NONE + PRIVATE + + PUBLIC :: cld_ice_register + PUBLIC :: cld_ice_init + PUBLIC :: cld_ice_run + PUBLIC :: cld_ice_final + + real(kind_phys), private :: tcld = HUGE(1.0_kind_phys) + +CONTAINS + + !> \section arg_table_cld_ice_register Argument Table + !! \htmlinclude arg_table_cld_ice_register.html + !! + subroutine cld_ice_register(dyn_const_ice, errmsg, errcode) + use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t + type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const_ice(:) + integer, intent(out) :: errcode + character(len=512), intent(out) :: errmsg + + errmsg = '' + errcode = 0 + allocate(dyn_const_ice(2), stat=errcode) + if (errcode /= 0) then + errmsg = 'Error allocating dyn_const in cld_ice_dynamic_constituents' + return + end if + call dyn_const_ice(1)%instantiate(std_name='dyn_const1', long_name='dyn const1', & + diag_name='DYNCONST1', units='kg kg-1', default_value=0._kind_phys, & + vertical_dim='vertical_layer_dimension', advected=.true., & + min_value=1000._kind_phys, water_species=.true., mixing_ratio_type='wet', & + errcode=errcode, errmsg=errmsg) + call dyn_const_ice(2)%instantiate(std_name='dyn_const2_wrt_moist_air', long_name='dyn const2', & + diag_name='DYNCONST2', units='kg kg-1', default_value=0._kind_phys, & + vertical_dim='vertical_layer_dimension', advected=.true., & + water_species=.false., errcode=errcode, errmsg=errmsg) + + end subroutine cld_ice_register + + !> \section arg_table_cld_ice_run Argument Table + !! \htmlinclude arg_table_cld_ice_run.html + !! + subroutine cld_ice_run(ncol, timestep, temp, qv, ps, cld_ice_array, & + errmsg, errflg) + + integer, intent(in) :: ncol + real(kind_phys), intent(in) :: timestep + real(kind_phys), intent(inout) :: temp(:,:) + real(kind_phys), intent(inout) :: qv(:,:) + real(kind_phys), intent(in) :: ps(:) + REAL(kind_phys), intent(inout) :: cld_ice_array(:,:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + + integer :: icol + integer :: ilev + real(kind_phys) :: frz + + errmsg = '' + errflg = 0 + + ! Apply state-of-the-art thermodynamics :) + do icol = 1, ncol + do ilev = 1, size(temp, 2) + if (temp(icol, ilev) < tcld) then + frz = MAX(qv(icol, ilev) - 0.5_kind_phys, 0.0_kind_phys) + cld_ice_array(icol, ilev) = cld_ice_array(icol, ilev) + frz + qv(icol, ilev) = qv(icol, ilev) - frz + if (frz > 0.0_kind_phys) then + temp(icol, ilev) = temp(icol, ilev) + 1.0_kind_phys + end if + end if + end do end do - end do - end subroutine cld_ice_run + END SUBROUTINE cld_ice_run - !> \section arg_table_cld_ice_init Argument Table - !! \htmlinclude arg_table_cld_ice_init.html - !! - subroutine cld_ice_init(tfreeze, cld_ice_array, errmsg, errflg) + !> \section arg_table_cld_ice_init Argument Table + !! \htmlinclude arg_table_cld_ice_init.html + !! + subroutine cld_ice_init(tfreeze, cld_ice_array, errmsg, errflg) - real(kind=kind_phys), intent(in) :: tfreeze - real(kind=kind_phys), intent(inout) :: cld_ice_array(:, :) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), intent(in) :: tfreeze + real(kind_phys), intent(inout) :: cld_ice_array(:,:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - errmsg = '' - errflg = 0 - cld_ice_array = 0.0_kind_phys - tcld = tfreeze - 20.0_kind_phys + errmsg = '' + errflg = 0 + cld_ice_array = 0.0_kind_phys + tcld = tfreeze - 20.0_kind_phys - end subroutine cld_ice_init + end subroutine cld_ice_init - !> \section arg_table_cld_ice_final Argument Table - !! \htmlinclude arg_table_cld_ice_final.html - !! + !> \section arg_table_cld_ice_final Argument Table + !! \htmlinclude arg_table_cld_ice_final.html + !! - !> @{ - !! This routine does nothing, but it tests if blank - !! lines and doxygen comments between metadata hooks - !! and the subroutine are parsed correctly. - !! @{ + !> @{ + !! This routine does nothing, but it tests if blank + !! lines and doxygen comments between metadata hooks + !! and the subroutine are parsed correctly. + !! @{ - subroutine cld_ice_final(errmsg, errflg) + subroutine cld_ice_final(errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 - end subroutine cld_ice_final + end subroutine cld_ice_final - !! @} - !! @} + !! @} + !! @} -end module cld_ice +END MODULE cld_ice diff --git a/test/advection_test/cld_liq.F90 b/test/advection_test/cld_liq.F90 index cb02cf11..83a6f961 100644 --- a/test/advection_test/cld_liq.F90 +++ b/test/advection_test/cld_liq.F90 @@ -1,102 +1,102 @@ ! Test parameterization with advected species ! -module cld_liq - - use ccpp_kinds, only: kind_phys - use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t - - implicit none - private - - public :: cld_liq_register - public :: cld_liq_init - public :: cld_liq_run - -contains - - !> \section arg_table_cld_liq_register Argument Table - !! \htmlinclude arg_table_cld_liq_register.html - !! - subroutine cld_liq_register(dyn_const, errmsg, errflg) - type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - - errmsg = '' - errflg = 0 - allocate(dyn_const(1), stat=errflg) - if (errflg /= 0) then - errmsg = 'Error allocating dyn_const in cld_liq_register' - return - end if - call dyn_const(1)%instantiate(std_name="dyn_const3_wrt_moist_air_and_condensed_water", long_name='dyn const3', & - diag_name='DYNCONST3', units='kg kg-1', default_value=1._kind_phys, & - vertical_dim='vertical_layer_dimension', advected=.true., & - water_species=.true., mixing_ratio_type='dry', & - errcode=errflg, errmsg=errmsg) - - end subroutine cld_liq_register - - !> \section arg_table_cld_liq_run Argument Table - !! \htmlinclude arg_table_cld_liq_run.html - !! - subroutine cld_liq_run(ncol, timestep, tcld, temp, qv, ps, & - cld_liq_tend, errmsg, errflg) - - integer, intent(in) :: ncol - real(kind=kind_phys), intent(in) :: timestep - real(kind=kind_phys), intent(in) :: tcld - real(kind=kind_phys), intent(inout) :: temp(:, :) - real(kind=kind_phys), intent(inout) :: qv(:, :) - real(kind=kind_phys), intent(in) :: ps(:) - real(kind=kind_phys), intent(inout) :: cld_liq_tend(:, :) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - - integer :: icol - integer :: ilev - real(kind=kind_phys) :: cond - - errmsg = '' - errflg = 0 - - ! Apply state-of-the-art thermodynamics :) - do icol = 1, ncol - do ilev = 1, size(temp, 2) - if ((qv(icol, ilev) > 0.0_kind_phys) .and. & - (temp(icol, ilev) <= tcld)) then - cond = min(qv(icol, ilev), 0.1_kind_phys) - cld_liq_tend(icol, ilev) = cond - qv(icol, ilev) = qv(icol, ilev) - cond - if (cond > 0.0_kind_phys) then - temp(icol, ilev) = temp(icol, ilev) + (cond * 5.0_kind_phys) - end if - end if +MODULE cld_liq + + USE ccpp_kinds, ONLY: kind_phys + use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t + + IMPLICIT NONE + PRIVATE + + PUBLIC :: cld_liq_register + PUBLIC :: cld_liq_init + PUBLIC :: cld_liq_run + +CONTAINS + + !> \section arg_table_cld_liq_register Argument Table + !! \htmlinclude arg_table_cld_liq_register.html + !! + subroutine cld_liq_register(dyn_const, errmsg, errflg) + type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + + errmsg = '' + errflg = 0 + allocate(dyn_const(1), stat=errflg) + if (errflg /= 0) then + errmsg = 'Error allocating dyn_const in cld_liq_register' + return + end if + call dyn_const(1)%instantiate(std_name="dyn_const3_wrt_moist_air_and_condensed_water", long_name='dyn const3', & + diag_name='DYNCONST3', units='kg kg-1', default_value=1._kind_phys, & + vertical_dim='vertical_layer_dimension', advected=.true., & + water_species=.true., mixing_ratio_type='dry', & + errcode=errflg, errmsg=errmsg) + + end subroutine cld_liq_register + + !> \section arg_table_cld_liq_run Argument Table + !! \htmlinclude arg_table_cld_liq_run.html + !! + subroutine cld_liq_run(ncol, timestep, tcld, temp, qv, ps, & + cld_liq_tend, errmsg, errflg) + + integer, intent(in) :: ncol + real(kind_phys), intent(in) :: timestep + real(kind_phys), intent(in) :: tcld + real(kind_phys), intent(inout) :: temp(:,:) + real(kind_phys), intent(inout) :: qv(:,:) + real(kind_phys), intent(in) :: ps(:) + REAL(kind_phys), intent(inout) :: cld_liq_tend(:,:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + + integer :: icol + integer :: ilev + real(kind_phys) :: cond + + errmsg = '' + errflg = 0 + + ! Apply state-of-the-art thermodynamics :) + do icol = 1, ncol + do ilev = 1, size(temp, 2) + if ( (qv(icol, ilev) > 0.0_kind_phys) .and. & + (temp(icol, ilev) <= tcld)) then + cond = MIN(qv(icol, ilev), 0.1_kind_phys) + cld_liq_tend(icol, ilev) = cond + qv(icol, ilev) = qv(icol, ilev) - cond + if (cond > 0.0_kind_phys) then + temp(icol, ilev) = temp(icol, ilev) + (cond * 5.0_kind_phys) + end if + end if + end do end do - end do - end subroutine cld_liq_run + END SUBROUTINE cld_liq_run - !> \section arg_table_cld_liq_init Argument Table - !! \htmlinclude arg_table_cld_liq_init.html - !! - subroutine cld_liq_init(tfreeze, cld_liq_array, tcld, errmsg, errflg) + !> \section arg_table_cld_liq_init Argument Table + !! \htmlinclude arg_table_cld_liq_init.html + !! + subroutine cld_liq_init(tfreeze, cld_liq_array, tcld, errmsg, errflg) - real(kind=kind_phys), intent(in) :: tfreeze - real(kind=kind_phys), intent(out) :: cld_liq_array(:, :) - real(kind=kind_phys), intent(out) :: tcld - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), intent(in) :: tfreeze + real(kind_phys), intent(out) :: cld_liq_array(:,:) + real(kind_phys), intent(out) :: tcld + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - ! This routine currently does nothing + ! This routine currently does nothing - errmsg = '' - errflg = 0 - cld_liq_array = 0.0_kind_phys - tcld = tfreeze - 20.0_kind_phys + errmsg = '' + errflg = 0 + cld_liq_array = 0.0_kind_phys + tcld = tfreeze - 20.0_kind_phys - end subroutine cld_liq_init + end subroutine cld_liq_init -end module cld_liq +END MODULE cld_liq diff --git a/test/advection_test/const_indices.F90 b/test/advection_test/const_indices.F90 index b9595982..0d9cf2e7 100644 --- a/test/advection_test/const_indices.F90 +++ b/test/advection_test/const_indices.F90 @@ -1,95 +1,94 @@ ! Test collection of constituent indices ! -module const_indices - - use ccpp_kinds, only: kind_phys - - implicit none - private - - public :: const_indices_init - public :: const_indices_run - -contains - - !> \section arg_table_const_indices_run Argument Table - !! \htmlinclude arg_table_const_indices_run.html - !! - subroutine const_indices_run(const_std_name, num_consts, test_stdname_array, & - const_index, const_inds, errmsg, errflg) - use ccpp_constituent_prop_mod, only: int_unassigned - use ccpp_scheme_utils, only: ccpp_constituent_index - use ccpp_scheme_utils, only: ccpp_constituent_indices - - character(len=*), intent(in) :: const_std_name - integer, intent(in) :: num_consts - character(len=*), intent(in) :: test_stdname_array(:) - integer, intent(out) :: const_index - integer, intent(out) :: const_inds(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - - integer :: indx - integer :: test_indx - - errmsg = '' - errflg = 0 - - ! Find the constituent index for - call ccpp_constituent_index(const_std_name, const_index, errflg, errmsg) - if (errflg == 0) then - call ccpp_constituent_indices(test_stdname_array, const_inds, errflg, errmsg) - end if - ! Check that a non-registered constituent is detectable but - ! does not cause an error - if (errflg == 0) then - call ccpp_constituent_index('unobtainium', test_indx, errflg, errmsg) - if (test_indx /= int_unassigned) then - if (errflg == 0) then - ! Do not add an error if one is already reported - errflg = 2 - write(errmsg, '(2a,i0,a,i0)') "ccpp_constituent_index called for ", & - "'unobtainium' returned an index of ", test_indx, ", not ", & - int_unassigned - end if +MODULE const_indices + + USE ccpp_kinds, ONLY: kind_phys + + IMPLICIT NONE + PRIVATE + + PUBLIC :: const_indices_init + PUBLIC :: const_indices_run + +CONTAINS + + !> \section arg_table_const_indices_run Argument Table + !! \htmlinclude arg_table_const_indices_run.html + !! + subroutine const_indices_run(const_std_name, num_consts, test_stdname_array, & + const_index, const_inds, errmsg, errflg) + use ccpp_constituent_prop_mod, only: int_unassigned + use ccpp_scheme_utils, only: ccpp_constituent_index + use ccpp_scheme_utils, only: ccpp_constituent_indices + + character(len=*), intent(in) :: const_std_name + integer, intent(in) :: num_consts + character(len=*), intent(in) :: test_stdname_array(:) + integer, intent(out) :: const_index + integer, intent(out) :: const_inds(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + + integer :: indx + integer :: test_indx + + errmsg = '' + errflg = 0 + + ! Find the constituent index for + call ccpp_constituent_index(const_std_name, const_index, errflg, errmsg) + if (errflg == 0) then + call ccpp_constituent_indices(test_stdname_array, const_inds, errflg, errmsg) + end if + ! Check that a non-registered constituent is detectable but + ! does not cause an error + if (errflg == 0) then + call ccpp_constituent_index('unobtainium', test_indx, errflg, errmsg) + if (test_indx /= int_unassigned) then + if (errflg == 0) then + ! Do not add an error if one is already reported + errflg = 2 + write(errmsg, '(2a,i0,a,i0)') "ccpp_constituent_index called for ", & + "'unobtainium' returned an index of ", test_indx, ", not ", & + int_unassigned + end if + end if end if - end if - - end subroutine const_indices_run - - !> \section arg_table_const_indices_init Argument Table - !! \htmlinclude arg_table_const_indices_init.html - !! - subroutine const_indices_init(const_std_name, num_consts, test_stdname_array, & - const_index, const_inds, errmsg, errflg) - use ccpp_scheme_utils, only: ccpp_constituent_index, & - ccpp_constituent_indices - - character(len=*), intent(in) :: const_std_name - integer, intent(in) :: num_consts - character(len=*), intent(in) :: test_stdname_array(:) - integer, intent(out) :: const_index - integer, intent(out) :: const_inds(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - - integer :: indx - - errmsg = '' - errflg = 0 - ! Find the constituent index for - call ccpp_constituent_index(const_std_name, const_index, errflg, errmsg) - if (errflg == 0) then - call ccpp_constituent_indices(test_stdname_array, const_inds, errflg, errmsg) - end if + end subroutine const_indices_run + + !> \section arg_table_const_indices_init Argument Table + !! \htmlinclude arg_table_const_indices_init.html + !! + subroutine const_indices_init(const_std_name, num_consts, test_stdname_array, & + const_index, const_inds, errmsg, errflg) + use ccpp_scheme_utils, only: ccpp_constituent_index, ccpp_constituent_indices + + character(len=*), intent(in) :: const_std_name + integer, intent(in) :: num_consts + character(len=*), intent(in) :: test_stdname_array(:) + integer, intent(out) :: const_index + integer, intent(out) :: const_inds(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + + integer :: indx + + errmsg = '' + errflg = 0 + + ! Find the constituent index for + call ccpp_constituent_index(const_std_name, const_index, errflg, errmsg) + if (errflg == 0) then + call ccpp_constituent_indices(test_stdname_array, const_inds, errflg, errmsg) + end if - end subroutine const_indices_init + end subroutine const_indices_init - !! @} - !! @} + !! @} + !! @} -end module const_indices +END MODULE const_indices diff --git a/test/advection_test/dlc_liq.F90 b/test/advection_test/dlc_liq.F90 index 20ff4b7b..db456073 100644 --- a/test/advection_test/dlc_liq.F90 +++ b/test/advection_test/dlc_liq.F90 @@ -1,41 +1,41 @@ ! Test parameterization with a runtime constituents ! properties object outside of the register phase -module dlc_liq +MODULE dlc_liq - use ccpp_kinds, only: kind_phys - use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t + USE ccpp_kinds, ONLY: kind_phys + use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t - implicit none - private + IMPLICIT NONE + PRIVATE - public :: dlc_liq_init + PUBLIC :: dlc_liq_init -contains +CONTAINS - !> \section arg_table_dlc_liq_init Argument Table - !! \htmlinclude arg_table_dlc_liq_init.html - !! - subroutine dlc_liq_init(dyn_const, errmsg, errflg) - type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + !> \section arg_table_dlc_liq_init Argument Table + !! \htmlinclude arg_table_dlc_liq_init.html + !! + subroutine dlc_liq_init(dyn_const, errmsg, errflg) + type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - character(len=256) :: stdname + character(len=256) :: stdname - errmsg = '' - errflg = 0 - allocate(dyn_const(1), stat=errflg) - if (errflg /= 0) then - errmsg = 'Error allocating dyn_const in dlc_liq_init' - return - end if - call dyn_const(1)%instantiate(std_name="dyn_const3", long_name='dyn const3', & - diag_name='DYNCONST3', units='kg kg-1', default_value=1._kind_phys, & - vertical_dim='vertical_layer_dimension', advected=.true., & - errcode=errflg, errmsg=errmsg) - call dyn_const(1)%standard_name(stdname, errcode=errflg, errmsg=errmsg) + errmsg = '' + errflg = 0 + allocate(dyn_const(1), stat=errflg) + if (errflg /= 0) then + errmsg = 'Error allocating dyn_const in dlc_liq_init' + return + end if + call dyn_const(1)%instantiate(std_name="dyn_const3", long_name='dyn const3', & + diag_name='DYNCONST3', units='kg kg-1', default_value=1._kind_phys, & + vertical_dim='vertical_layer_dimension', advected=.true., & + errcode=errflg, errmsg=errmsg) + call dyn_const(1)%standard_name(stdname, errcode=errflg, errmsg=errmsg) - end subroutine dlc_liq_init + end subroutine dlc_liq_init -end module dlc_liq +END MODULE dlc_liq diff --git a/test/advection_test/test_advection_host_integration.F90 b/test/advection_test/test_advection_host_integration.F90 index 4dfb2d18..728137fa 100644 --- a/test/advection_test/test_advection_host_integration.F90 +++ b/test/advection_test/test_advection_host_integration.F90 @@ -1,80 +1,77 @@ 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(1) - character(len=cm), target :: test_invars1(12) - character(len=cm), target :: test_outvars1(13) - character(len=cm), target :: test_reqvars1(18) + character(len=cs), target :: test_parts1(1) + character(len=cm), target :: test_invars1(12) + character(len=cm), target :: test_outvars1(13) + character(len=cm), target :: test_reqvars1(18) - type(suite_info) :: test_suites(1) - logical :: run_okay + type(suite_info) :: test_suites(1) + logical :: run_okay - test_parts1 = (/ 'physics '/) - test_invars1 = (/ & - 'banana_array_dim ', & - 'cloud_ice_dry_mixing_ratio ', & - 'cloud_liquid_dry_mixing_ratio ', & - 'tendency_of_cloud_liquid_dry_mixing_ratio', & - 'surface_air_pressure ', & - 'temperature ', & - 'time_step_for_physics ', & - 'water_temperature_at_freezing ', & - 'ccpp_constituent_tendencies ', & - 'ccpp_constituents ', & - 'number_of_ccpp_constituents ', & - 'water_vapor_specific_humidity ' /) - test_outvars1 = (/ & - 'ccpp_error_message ', & - 'ccpp_error_code ', & - 'temperature ', & - 'water_vapor_specific_humidity ', & - 'cloud_liquid_dry_mixing_ratio ', & - 'ccpp_constituent_tendencies ', & - 'ccpp_constituents ', & - 'dynamic_constituents_for_cld_liq ', & - 'dynamic_constituents_for_cld_ice ', & - 'tendency_of_cloud_liquid_dry_mixing_ratio', & - 'test_banana_constituent_index ', & - 'test_banana_constituent_indices ', & - 'cloud_ice_dry_mixing_ratio ' /) - test_reqvars1 = (/ & - 'banana_array_dim ', & - 'surface_air_pressure ', & - 'temperature ', & - 'time_step_for_physics ', & - 'cloud_liquid_dry_mixing_ratio ', & - 'tendency_of_cloud_liquid_dry_mixing_ratio', & - 'cloud_ice_dry_mixing_ratio ', & - 'dynamic_constituents_for_cld_liq ', & - 'dynamic_constituents_for_cld_ice ', & - 'water_temperature_at_freezing ', & - 'ccpp_constituent_tendencies ', & - 'ccpp_constituents ', & - 'number_of_ccpp_constituents ', & - 'test_banana_constituent_index ', & - 'test_banana_constituent_indices ', & - 'water_vapor_specific_humidity ', & - 'ccpp_error_message ', & - 'ccpp_error_code ' /) + test_parts1 = (/ 'physics '/) + test_invars1 = (/ & + 'banana_array_dim ', & + 'cloud_ice_dry_mixing_ratio ', & + 'cloud_liquid_dry_mixing_ratio ', & + 'tendency_of_cloud_liquid_dry_mixing_ratio', & + 'surface_air_pressure ', & + 'temperature ', & + 'time_step_for_physics ', & + 'water_temperature_at_freezing ', & + 'ccpp_constituent_tendencies ', & + 'ccpp_constituents ', & + 'number_of_ccpp_constituents ', & + 'water_vapor_specific_humidity ' /) + test_outvars1 = (/ & + 'ccpp_error_message ', & + 'ccpp_error_code ', & + 'temperature ', & + 'water_vapor_specific_humidity ', & + 'cloud_liquid_dry_mixing_ratio ', & + 'ccpp_constituent_tendencies ', & + 'ccpp_constituents ', & + 'dynamic_constituents_for_cld_liq ', & + 'dynamic_constituents_for_cld_ice ', & + 'tendency_of_cloud_liquid_dry_mixing_ratio', & + 'test_banana_constituent_index ', & + 'test_banana_constituent_indices ', & + 'cloud_ice_dry_mixing_ratio ' /) + test_reqvars1 = (/ & + 'banana_array_dim ', & + 'surface_air_pressure ', & + 'temperature ', & + 'time_step_for_physics ', & + 'cloud_liquid_dry_mixing_ratio ', & + 'tendency_of_cloud_liquid_dry_mixing_ratio', & + 'cloud_ice_dry_mixing_ratio ', & + 'dynamic_constituents_for_cld_liq ', & + 'dynamic_constituents_for_cld_ice ', & + 'water_temperature_at_freezing ', & + 'ccpp_constituent_tendencies ', & + 'ccpp_constituents ', & + 'number_of_ccpp_constituents ', & + 'test_banana_constituent_index ', & + 'test_banana_constituent_indices ', & + 'water_vapor_specific_humidity ', & + 'ccpp_error_message ', & + 'ccpp_error_code ' /) - ! Setup expected test suite info - test_suites(1)%suite_name = 'cld_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 + ! Setup expected test suite info + test_suites(1)%suite_name = 'cld_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 - 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/advection_test/test_host.F90 b/test/advection_test/test_host.F90 index 3cd46825..30a618e8 100644 --- a/test/advection_test/test_host.F90 +++ b/test/advection_test/test_host.F90 @@ -1,1114 +1,1110 @@ module test_prog - use ccpp_kinds, only: kind_phys - use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t - - implicit none - private - - public test_host - - ! Public data and interfaces - integer, public, parameter :: cs = 16 - integer, public, parameter :: cm = 41 - - !> \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 - - type(ccpp_constituent_properties_t), private, target, allocatable :: host_constituents(:) - - private :: check_suite - private :: advect_constituents ! Move data around - private :: check_errflg - -contains - - subroutine check_errflg(subname, errflg, errmsg, errflg_final) - ! If errflg is not zero, print an error message - character(len=*), intent(in) :: subname - integer, intent(in) :: errflg - character(len=*), intent(in) :: errmsg - - integer, intent(out) :: errflg_final - - if (errflg /= 0) then - write(6, '(a,i0,4a)') "Error ", errflg, " from ", trim(subname), & - ':', trim(errmsg) - !Notify test script that a failure occurred: - errflg_final = -1 !Notify test script that a failure occured - end if - - end subroutine check_errflg - - 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 - logical :: check - integer :: errflg - character(len=512) :: errmsg - character(len=128), allocatable :: test_list(:) - - check_suite = .true. - ! 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 - - subroutine advect_constituents() - use test_host_mod, only: phys_state, & - ncnst - use test_host_mod, only: twist_array - - ! Local variables - integer :: q_ind ! Constituent index - - do q_ind = 1, ncnst ! Skip checks, they were done in constituents_in - call twist_array(phys_state%q(:, :, q_ind)) - end do - end subroutine advect_constituents - - !> \section arg_table_test_host Argument Table - !! \htmlinclude arg_table_test_host.html - !! - subroutine test_host(retval, test_suites) - - use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t - use test_host_mod, only: num_time_steps - use test_host_mod, only: init_data, & - compare_data - use test_host_mod, only: ncols, & - pver - use test_host_data, only: num_consts, & - std_name_array, & - const_std_name - use test_host_data, only: check_constituent_indices - use test_host_ccpp_cap, only: test_host_ccpp_deallocate_dynamic_constituents - use test_host_ccpp_cap, only: test_host_ccpp_register_constituents - use test_host_ccpp_cap, only: test_host_ccpp_is_scheme_constituent - use test_host_ccpp_cap, only: test_host_ccpp_initialize_constituents - use test_host_ccpp_cap, only: test_host_ccpp_number_constituents - use test_host_ccpp_cap, only: test_host_constituents_array - 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_ccpp_cap, only: test_host_const_get_index - use test_host_ccpp_cap, only: test_host_model_const_properties - use test_utils, only: check_list - - type(suite_info), intent(in) :: test_suites(:) - logical, intent(out) :: retval - - logical :: check - integer :: col_start, col_end - integer :: index, sind - integer :: index_liq, index_ice - integer :: index_dyn1, index_dyn2, index_dyn3 - integer :: time_step - integer :: num_suites - integer :: num_advected ! Num advected species - logical :: const_log - logical :: is_constituent - logical :: has_default - integer :: test_scalar_const_index - integer :: test_const_indices(num_consts) - character(len=128), allocatable :: suite_names(:) - character(len=256) :: const_str - character(len=512) :: errmsg - character(len=512) :: expected_error - integer :: errflg - integer :: errflg_final ! Used to notify testing script of test failure - real(kind=kind_phys), pointer :: const_ptr(:, :, :) - real(kind=kind_phys) :: default_value - real(kind=kind_phys) :: check_value - type(ccpp_constituent_prop_ptr_t), pointer :: const_props(:) - character(len=*), parameter :: subname = 'test_host' - - ! Initialized "final" error flag used to report a failure to the larged - ! testing script: - errflg_final = 0 - - ! 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) + use ccpp_kinds, only: kind_phys + use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t + + implicit none + private + + public test_host + + ! Public data and interfaces + integer, public, parameter :: cs = 16 + integer, public, parameter :: cm = 41 + + !> \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 + + type(ccpp_constituent_properties_t), private, target, allocatable :: host_constituents(:) + + private :: check_suite + private :: advect_constituents ! Move data around + private :: check_errflg + +CONTAINS + + subroutine check_errflg(subname, errflg, errmsg, errflg_final) + ! If errflg is not zero, print an error message + character(len=*), intent(in) :: subname + integer, intent(in) :: errflg + character(len=*), intent(in) :: errmsg + + integer, intent(out) :: errflg_final + + if (errflg /= 0) then + write(6, '(a,i0,4a)') "Error ", errflg, " from ", trim(subname), & + ':', trim(errmsg) + !Notify test script that a failure occurred: + errflg_final = -1 !Notify test script that a failure occured + end if + + end subroutine check_errflg + + 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 + logical :: check + integer :: errflg + character(len=512) :: errmsg + character(len=128), allocatable :: test_list(:) + + check_suite = .true. + ! 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 + + subroutine advect_constituents() + use test_host_mod, only: phys_state, ncnst + use test_host_mod, only: twist_array + + ! Local variables + integer :: q_ind ! Constituent index + + do q_ind = 1, ncnst ! Skip checks, they were done in constituents_in + call twist_array(phys_state%q(:,:,q_ind)) + end do + end subroutine advect_constituents + + !> \section arg_table_test_host Argument Table + !! \htmlinclude arg_table_test_host.html + !! + subroutine test_host(retval, test_suites) + + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t + use test_host_mod, only: num_time_steps + use test_host_mod, only: init_data, compare_data + use test_host_mod, only: ncols, pver + use test_host_data, only: num_consts, std_name_array, const_std_name + use test_host_data, only: check_constituent_indices + use test_host_ccpp_cap, only: test_host_ccpp_deallocate_dynamic_constituents + use test_host_ccpp_cap, only: test_host_ccpp_register_constituents + use test_host_ccpp_cap, only: test_host_ccpp_is_scheme_constituent + use test_host_ccpp_cap, only: test_host_ccpp_initialize_constituents + use test_host_ccpp_cap, only: test_host_ccpp_number_constituents + use test_host_ccpp_cap, only: test_host_constituents_array + 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_ccpp_cap, only: test_host_const_get_index + use test_host_ccpp_cap, only: test_host_model_const_properties + use test_utils, only: check_list + + type(suite_info), intent(in) :: test_suites(:) + logical, intent(out) :: retval + + logical :: check + integer :: col_start, col_end + integer :: index, sind + integer :: index_liq, index_ice + integer :: index_dyn1, index_dyn2, index_dyn3 + integer :: time_step + integer :: num_suites + integer :: num_advected ! Num advected species + logical :: const_log + logical :: is_constituent + logical :: has_default + integer :: test_scalar_const_index + integer :: test_const_indices(num_consts) + character(len=128), allocatable :: suite_names(:) + character(len=256) :: const_str + character(len=512) :: errmsg + character(len=512) :: expected_error + integer :: errflg + integer :: errflg_final ! Used to notify testing script of test failure + real(kind_phys), pointer :: const_ptr(:,:,:) + real(kind_phys) :: default_value + real(kind_phys) :: check_value + type(ccpp_constituent_prop_ptr_t), pointer :: const_props(:) + character(len=*), parameter :: subname = 'test_host' + + ! Initialized "final" error flag used to report a failure to the larged + ! testing script: + errflg_final = 0 + + ! 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 + + errflg = 0 + errmsg = '' + + ! Check that is_scheme_constituent works as expected + call test_host_ccpp_is_scheme_constituent('specific_humidity', & + is_constituent, errflg, errmsg) + call check_errflg(subname//"_ccpp_is_scheme_constituent", errflg, & + errmsg, errflg_final) + ! specific_humidity should not be an existing constituent + if (is_constituent) then + write(6, *) "ERROR: specific humidity is already a constituent" + errflg_final = -1 ! Notify test script that a failure occurred + end if + call test_host_ccpp_is_scheme_constituent('cloud_ice_dry_mixing_ratio', & + is_constituent, errflg, errmsg) + call check_errflg(subname//"_ccpp_is_scheme_constituent", errflg, & + errmsg, errflg_final) + ! cloud_ice_dry_mixing_ratio should be an existing constituent + if (.not. is_constituent) then + write(6, *) "ERROR: cloud_ice_dry_mixing ratio not found in ", & + "host cap constituent list" + errflg_final = -1 ! Notify test script that a failure occurred + end if + + ! Use the suite information to call the register phase 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 + if (errflg == 0) then + 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) + exit + end if + end if + end do + + ! Register the constituents to find out what needs advecting + ! DO A COUPLE OF TESTS FIRST + + ! First confirm the correct error occurs if you try to add an + ! incompatible constituent with the same standard name + expected_error = 'ccp_model_const_add_metadata ERROR: Trying to add ' //& + 'constituent specific_humidity but an incompatible ' // & + 'constituent with this name already exists' + allocate(host_constituents(2)) + call host_constituents(1)%instantiate(std_name="specific_humidity", & + long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & + vertical_dim="vertical_layer_dimension", advected=.true., & + min_value=1000._kind_phys, molar_mass=2000._kind_phys, & + errcode=errflg, errmsg=errmsg) + call host_constituents(2)%instantiate(std_name="specific_humidity", & + long_name="Specific humidity", diag_name='H2O', units="kg kg", & + vertical_dim="vertical_layer_dimension", advected=.true., & + min_value=1000._kind_phys, molar_mass=2000._kind_phys, & + errcode=errflg, errmsg=errmsg) + call check_errflg(subname//'.initialize', errflg, errmsg, errflg_final) + if (errflg == 0) then + call test_host_ccpp_register_constituents(host_constituents, & + errmsg=errmsg, errflg=errflg) + end if + ! Check the error + if (errflg == 0) then + write(6, '(2a)') 'ERROR register_constituents: expected this error: ', & + trim(expected_error) + else + if (trim(errmsg) /= trim(expected_error)) then + write(6, '(4a)') 'ERROR register_constituents: expected this error: ', & + trim(expected_error), ' Got: ', trim(errmsg) + end if + end if + ! Now try again but with a compatible constituent - should be ignored when + ! the constituents object is created + ! Use the suite information to call the register phase + errflg = 0 + call test_host_ccpp_deallocate_dynamic_constituents() + deallocate(host_constituents) do sind = 1, num_suites - check = check_suite(test_suites(sind)) - retval = retval .and. check + if (errflg == 0) then + 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) + exit + end if + end if end do - end if - !!! Return here if any check failed - if ( .not. retval) then - return - end if - - errflg = 0 - errmsg = '' - - ! Check that is_scheme_constituent works as expected - call test_host_ccpp_is_scheme_constituent('specific_humidity', & - is_constituent, errflg, errmsg) - call check_errflg(subname // "_ccpp_is_scheme_constituent", errflg, & - errmsg, errflg_final) - ! specific_humidity should not be an existing constituent - if (is_constituent) then - write(6, *) "ERROR: specific humidity is already a constituent" - errflg_final = -1 ! Notify test script that a failure occurred - end if - call test_host_ccpp_is_scheme_constituent('cloud_ice_dry_mixing_ratio', & - is_constituent, errflg, errmsg) - call check_errflg(subname // "_ccpp_is_scheme_constituent", errflg, & - errmsg, errflg_final) - ! cloud_ice_dry_mixing_ratio should be an existing constituent - if ( .not. is_constituent) then - write(6, *) "ERROR: cloud_ice_dry_mixing ratio not found in ", & - "host cap constituent list" - errflg_final = -1 ! Notify test script that a failure occurred - end if - - ! Use the suite information to call the register phase - do sind = 1, num_suites + allocate(host_constituents(2)) + call host_constituents(1)%instantiate(std_name="specific_humidity", & + long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & + vertical_dim="vertical_layer_dimension", advected=.true., & + min_value=1000._kind_phys, molar_mass=2000._kind_phys, & + errcode=errflg, errmsg=errmsg) + call host_constituents(2)%instantiate(std_name="specific_humidity", & + long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & + vertical_dim="vertical_layer_dimension", advected=.true., & + min_value=1000._kind_phys, molar_mass=2000._kind_phys, & + errcode=errflg, errmsg=errmsg) + call check_errflg(subname//'.initialize', errflg, errmsg, errflg_final) if (errflg == 0) then - 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) - exit - end if - end if - end do - - ! Register the constituents to find out what needs advecting - ! DO A COUPLE OF TESTS FIRST - - ! First confirm the correct error occurs if you try to add an - ! incompatible constituent with the same standard name - expected_error = 'ccp_model_const_add_metadata ERROR: Trying to add ' //& - 'constituent specific_humidity but an incompatible ' // & - 'constituent with this name already exists' - allocate(host_constituents(2)) - call host_constituents(1)%instantiate(std_name="specific_humidity", & - long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & - vertical_dim="vertical_layer_dimension", advected=.true., & - min_value=1000._kind_phys, molar_mass=2000._kind_phys, & - errcode=errflg, errmsg=errmsg) - call host_constituents(2)%instantiate(std_name="specific_humidity", & - long_name="Specific humidity", diag_name='H2O', units="kg kg", & - vertical_dim="vertical_layer_dimension", advected=.true., & - min_value=1000._kind_phys, molar_mass=2000._kind_phys, & - errcode=errflg, errmsg=errmsg) - call check_errflg(subname // '.initialize', errflg, errmsg, errflg_final) - if (errflg == 0) then - call test_host_ccpp_register_constituents(host_constituents, & - errmsg=errmsg, errflg=errflg) - end if - ! Check the error - if (errflg == 0) then - write(6, '(2a)') 'ERROR register_constituents: expected this error: ', & - trim(expected_error) - else - if (trim(errmsg) /= trim(expected_error)) then - write(6, '(4a)') 'ERROR register_constituents: expected this error: ', & - trim(expected_error), ' Got: ', trim(errmsg) - end if - end if - ! Now try again but with a compatible constituent - should be ignored when - ! the constituents object is created - ! Use the suite information to call the register phase - errflg = 0 - call test_host_ccpp_deallocate_dynamic_constituents() - deallocate(host_constituents) - do sind = 1, num_suites + call test_host_ccpp_register_constituents(host_constituents, & + errmsg=errmsg, errflg=errflg) + end if + if (errflg /= 0) then + write(6, '(2a)') 'ERROR register_constituents: ', trim(errmsg) + retval = .false. + return + end if + ! Check number of advected constituents if (errflg == 0) then - 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) - exit - end if - end if - end do - allocate(host_constituents(2)) - call host_constituents(1)%instantiate(std_name="specific_humidity", & - long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & - vertical_dim="vertical_layer_dimension", advected=.true., & - min_value=1000._kind_phys, molar_mass=2000._kind_phys, & - errcode=errflg, errmsg=errmsg) - call host_constituents(2)%instantiate(std_name="specific_humidity", & - long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & - vertical_dim="vertical_layer_dimension", advected=.true., & - min_value=1000._kind_phys, molar_mass=2000._kind_phys, & - errcode=errflg, errmsg=errmsg) - call check_errflg(subname // '.initialize', errflg, errmsg, errflg_final) - if (errflg == 0) then - call test_host_ccpp_register_constituents(host_constituents, & - errmsg=errmsg, errflg=errflg) - end if - if (errflg /= 0) then - write(6, '(2a)') 'ERROR register_constituents: ', trim(errmsg) - retval = .false. - return - end if - ! Check number of advected constituents - if (errflg == 0) then - call test_host_ccpp_number_constituents(num_advected, errmsg=errmsg, & - errflg=errflg) - call check_errflg(subname // ".num_advected", errflg, errmsg, errflg_final) - end if - if (num_advected /= 6) then - write(6, '(a,i0)') "ERROR: num advected constituents = ", num_advected - retval = .false. - return - end if - ! Initialize constituent data - call test_host_ccpp_initialize_constituents(ncols, pver, errflg, errmsg) - - ! Stop tests here if initialization failed (as all other tests will likely - ! fail as well: - if (errflg /= 0) then - retval = .false. - return - end if - - ! Initialize our 'data' - const_ptr => test_host_constituents_array() - - ! Check if the specific humidity index can be found: - call test_host_const_get_index('specific_humidity', index, & - errflg, errmsg) - call check_errflg(subname // ".index_specific_humidity", errflg, errmsg, & - errflg_final) - - ! Check if the cloud liquid index can be found: - call test_host_const_get_index('cloud_liquid_dry_mixing_ratio', & - index_liq, errflg, errmsg) - call check_errflg(subname // ".index_cld_liq", errflg, errmsg, & - errflg_final) - - ! Check if the cloud ice index can be found: - call test_host_const_get_index('cloud_ice_dry_mixing_ratio', & - index_ice, errflg, errmsg) - call check_errflg(subname // ".index_cld_ice", errflg, errmsg, & - errflg_final) - - ! Check if the dynamic constituents indices can be found - call test_host_const_get_index('dyn_const1', index_dyn1, errflg, errmsg) - call check_errflg(subname // ".index_dyn_const1", errflg, errmsg, & - errflg_final) - call test_host_const_get_index('dyn_const2_wrt_moist_air', index_dyn2, errflg, errmsg) - call check_errflg(subname // ".index_dyn_const2", errflg, errmsg, & - errflg_final) - call test_host_const_get_index('dyn_const3_wrt_moist_air_and_condensed_water', index_dyn3, errflg, errmsg) - call check_errflg(subname // ".index_dyn_const3", errflg, errmsg, & - errflg_final) - - ! Load up the test array indices - call test_host_const_get_index(const_std_name, test_scalar_const_index, errflg, errmsg) - call check_errflg(subname // "." // const_std_name, errflg, errmsg, & - errflg_final) - do sind = 1, num_consts - call test_host_const_get_index(std_name_array(sind), & - test_const_indices(sind), errflg, errmsg) - call check_errflg(subname // "." // std_name_array(sind), errflg, errmsg, & - errflg_final) - end do - - ! Stop tests here if the index checks failed, as all other tests will - ! likely fail as well: - if (errflg_final /= 0) then - retval = .false. - return - end if - - call init_data(const_ptr, index, index_liq, index_ice, index_dyn3) - - ! Check some constituent properties - ! ++++++++++++++++++++++++++++++++++ - - const_props => test_host_model_const_properties() - - ! Standard name: - call const_props(index)%standard_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get standard_name for specific_humidity, index = ", & - index, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'specific_humidity') then - write(6, *) "ERROR: standard name, '", trim(const_str), & - "' should be 'specific_humidity'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check standard name for a dynamic constituent - call const_props(index_dyn2)%standard_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get standard_name for dyn_const2, index = ", & - index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'dyn_const2_wrt_moist_air') then - write(6, *) "ERROR: standard name, '", trim(const_str), & - "' should be 'dyn_const2_wrt_moist_air'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Long name: - call const_props(index_liq)%long_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get long_name for cld_liq index = ", & - index_liq, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'Cloud liquid dry mixing ratio') then - write(6, *) "ERROR: long name, '", trim(const_str), & - "' should be 'Cloud liquid dry mixing ratio'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check long name for a dynamic constituent - call const_props(index_dyn1)%long_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get long_name for dyn_const1 index = ", & - index_dyn1, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'dyn const1') then - write(6, *) "ERROR: long name, '", trim(const_str), & - "' should be 'dyn const1'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Diagnostic name: - call const_props(index_liq)%diagnostic_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get diagnostic name for cld_liq index = ", & - index_liq, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'CLDLIQ') then - write(6, *) "ERROR: diagnostic name, '", trim(const_str), & - "' should be 'CLDLIQ'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check default diagnostic name is set correctly - call const_props(index_ice)%diagnostic_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get diagnostic name for cld_ice index = ", & - index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'cld_ice_array') then - write(6, *) "ERROR: diagnostic name, '", trim(const_str), & - "' should be 'cld_ice_array'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check diagnostic name of a dynamic constituent - call const_props(index_dyn2)%diagnostic_name(const_str, errflg, & - errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get diagnostic name for dyn_const2 index = ", & - index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'DYNCONST2') then - write(6, *) "ERROR: diagnostic name, '", trim(const_str), & - "' should be 'DYNCONST2'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Mass mixing ratio: - call const_props(index_ice)%is_mass_mixing_ratio(const_log, errflg, & - errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get mass mixing ratio prop for cld_ice index = ", & - index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if ( .not. const_log) then - write(6, *) "ERROR: cloud ice is not a mass mixing_ratio" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check mass mixing ratio for a dynamic constituent - call const_props(index_dyn2)%is_mass_mixing_ratio(const_log, errflg, & - errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get mass mixing ratio prop for dyn_const2 index = ", & - index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if ( .not. const_log) then - write(6, *) "ERROR: dyn_const2 is not a mass mixing_ratio" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Dry mixing ratio: - call const_props(index_ice)%is_dry(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get dry prop for cld_ice index = ", index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if ( .not. const_log) then - write(6, *) "ERROR: cloud ice mass_mixing_ratio is not dry" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check wet mixing ratio for dynamic constituent 1 - call const_props(index_dyn1)%is_dry(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get dry prop for dyn_const1 index = ", index_dyn1, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (const_log) then - write(6, *) "ERROR: dyn_const1 is dry and should be wet" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_dyn1)%is_wet(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get wet prop for dyn_const1 index = ", index_dyn1, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if ( .not. const_log) then - write(6, *) "ERROR: dyn_const1 is not wet but should be" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check moist mixing ratio for dynamic constituent 2 - call const_props(index_dyn2)%is_dry(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get dry prop for dyn_const2 index = ", index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (const_log) then - write(6, *) "ERROR: dyn_const2 is dry and should be moist" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_dyn2)%is_moist(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get moist prop for dyn_const2 index = ", index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if ( .not. const_log) then - write(6, *) "ERROR: dyn_const2 is not moist but should be" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check dry mixing ratio for dynamic constituent 3 - call const_props(index_dyn3)%is_dry(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get dry prop for dyn_const3 index = ", index_dyn3, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if ( .not. const_log) then - write(6, *) "ERROR: dyn_const3 is not dry and should be" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! ------------------- - - ! ------------------- - ! minimum value tests: - ! ------------------- - - ! Check that a constituent's minimum value defaults to zero: - call const_props(index_dyn2)%minimum(check_value, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get minimum value for dyn_const2 index = ", index_dyn2, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (check_value /= 0._kind_phys) then ! Should be zero - write(6, *) "ERROR: 'minimum' should default to zero for all ", & - "constituents unless set by host model or scheme metadata." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Check that a constituent instantiated with a specified minimum value - ! actually contains that minimum value property: - call const_props(index_dyn1)%minimum(check_value, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get minimum value for dyn_const1 index = ", index_dyn1, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (check_value /= 1000._kind_phys) then !Should be 1000 - write(6, *) "ERROR: 'minimum' should give a value of 1000 ", & - "for dyn_const1, as was set during instantiation." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Check that setting a constituent's minimum value works - ! as expected: - call const_props(index_dyn1)%set_minimum(1._kind_phys, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to set minimum value for dyn_const1 index = ", index_dyn1, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - call const_props(index_dyn1)%minimum(check_value, errflg, errmsg) + call test_host_ccpp_number_constituents(num_advected, errmsg=errmsg, & + errflg=errflg) + call check_errflg(subname//".num_advected", errflg, errmsg, errflg_final) + end if + if (num_advected /= 6) then + write(6, '(a,i0)') "ERROR: num advected constituents = ", num_advected + retval = .false. + return + end if + ! Initialize constituent data + call test_host_ccpp_initialize_constituents(ncols, pver, errflg, errmsg) + + ! Stop tests here if initialization failed (as all other tests will likely + ! fail as well: if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - " trying to get minimum value for dyn_const1 index = ", & - index_dyn1, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - end if - if (errflg == 0) then - if (check_value /= 1._kind_phys) then ! Should now be one - write(6, *) "ERROR: 'set_minimum' did not set constituent", & - " minimum value correctly." - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! ---------------------- - ! molecular weight tests: - ! ---------------------- - - ! Check that a constituent instantiated with a specified molecular - ! weight actually contains that molecular weight property value: - call const_props(index)%molar_mass(check_value, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get molecular weight for specific humidity index = ", & - index, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (check_value /= 2000._kind_phys) then ! Should be 2000 - write(6, *) "ERROR: 'molar_mass' should give a value of 2000 ", & - "for specific humidity, as was set during instantiation." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Check that setting a constituent's molecular weight works - ! as expected: - call const_props(index_ice)%set_molar_mass(1._kind_phys, errflg, & - errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to set molecular weight for cld_ice index = ", index_ice, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - call const_props(index_ice)%molar_mass(check_value, errflg, errmsg) + retval = .false. + return + end if + + ! Initialize our 'data' + const_ptr => test_host_constituents_array() + + ! Check if the specific humidity index can be found: + call test_host_const_get_index('specific_humidity', index, & + errflg, errmsg) + call check_errflg(subname//".index_specific_humidity", errflg, errmsg, & + errflg_final) + + ! Check if the cloud liquid index can be found: + call test_host_const_get_index('cloud_liquid_dry_mixing_ratio', & + index_liq, errflg, errmsg) + call check_errflg(subname//".index_cld_liq", errflg, errmsg, & + errflg_final) + + ! Check if the cloud ice index can be found: + call test_host_const_get_index('cloud_ice_dry_mixing_ratio', & + index_ice, errflg, errmsg) + call check_errflg(subname//".index_cld_ice", errflg, errmsg, & + errflg_final) + + ! Check if the dynamic constituents indices can be found + call test_host_const_get_index('dyn_const1', index_dyn1, errflg, errmsg) + call check_errflg(subname//".index_dyn_const1", errflg, errmsg, & + errflg_final) + call test_host_const_get_index('dyn_const2_wrt_moist_air', index_dyn2, errflg, errmsg) + call check_errflg(subname//".index_dyn_const2", errflg, errmsg, & + errflg_final) + call test_host_const_get_index('dyn_const3_wrt_moist_air_and_condensed_water', index_dyn3, errflg, errmsg) + call check_errflg(subname//".index_dyn_const3", errflg, errmsg, & + errflg_final) + + ! Load up the test array indices + call test_host_const_get_index(const_std_name, test_scalar_const_index, errflg, errmsg) + call check_errflg(subname//"."//const_std_name, errflg, errmsg, & + errflg_final) + do sind = 1, num_consts + call test_host_const_get_index(std_name_array(sind), & + test_const_indices(sind), errflg, errmsg) + call check_errflg(subname//"."//std_name_array(sind), errflg, errmsg, & + errflg_final) + end do + + ! Stop tests here if the index checks failed, as all other tests will + ! likely fail as well: + if (errflg_final /= 0) then + retval = .false. + return + end if + + call init_data(const_ptr, index, index_liq, index_ice, index_dyn3) + + ! Check some constituent properties + ! ++++++++++++++++++++++++++++++++++ + + const_props => test_host_model_const_properties() + + ! Standard name: + call const_props(index)%standard_name(const_str, errflg, errmsg) if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - " trying to get molecular weight for cld_ice index = ", & - index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - end if - if (errflg == 0) then - if (check_value /= 1._kind_phys) then ! Should be equal to one - write(6, *) "ERROR: 'set_molar_mass' did not set constituent", & - " molecular weight value correctly." - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! ------------------- - ! thermo-active tests: - ! ------------------- - - ! Check that being thermodynamically active defaults to False: - call const_props(index_ice)%is_thermo_active(check, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get thermo_active prop for cld_ice index = ", index_ice, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (check) then ! Should be False - write(6, *) "ERROR: 'is_thermo_active' should default to False ", & - "for all constituents unless set by host model." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Check that setting a constituent to be thermodynamically active works - ! as expected: - call const_props(index_ice)%set_thermo_active(.true., errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to set thermo_active prop for cld_ice index = ", index_ice, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - call const_props(index_ice)%is_thermo_active(check, errflg, errmsg) + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get standard_name for specific_humidity, index = ", & + index, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'specific_humidity') then + write(6, *) "ERROR: standard name, '", trim(const_str), & + "' should be 'specific_humidity'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check standard name for a dynamic constituent + call const_props(index_dyn2)%standard_name(const_str, errflg, errmsg) if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - " trying to get thermo_active prop for cld_ice index = ", & - index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - end if - if (errflg == 0) then - if ( .not. check) then ! Should now be True - write(6, *) "ERROR: 'set_thermo_active' did not set", & - " thermo_active constituent property correctly." - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! ------------------- - - ! ------------------- - ! water-species tests: - ! ------------------- - - ! Check that being a water species defaults to False: - call const_props(index_liq)%is_water_species(check, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get water_species prop for cld_liq index = ", index_liq, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (check) then ! Should be False - write(6, *) "ERROR: 'is_water_species' should default to False ", & - "for all constituents unless set by host model." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Check that setting a constituent to be a water species works - ! as expected: - call const_props(index_liq)%set_water_species(.true., errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to set water_species prop for cld_liq index = ", index_liq, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - call const_props(index_liq)%is_water_species(check, errflg, errmsg) + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get standard_name for dyn_const2, index = ", & + index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'dyn_const2_wrt_moist_air') then + write(6, *) "ERROR: standard name, '", trim(const_str), & + "' should be 'dyn_const2_wrt_moist_air'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + + ! Long name: + call const_props(index_liq)%long_name(const_str, errflg, errmsg) if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - " trying to get water_species prop for cld_liq index = ", & - index_liq, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - end if - if (errflg == 0) then - if ( .not. check) then ! Should now be True - write(6, *) "ERROR: 'set_water_species' did not set", & - " water_species constituent property correctly." - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Check that setting a constituent to be a water species via the - ! instantiate call works as expected - call const_props(index_dyn1)%is_water_species(check, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - "trying to get water_species prop for dyn_const1 index = ", & - index_dyn1, trim(errmsg) - end if - if (errflg == 0) then - if ( .not. check) then ! Should now be True - write(6, *) "ERROR: 'water_species=.true. did not set", & - " water_species constituent property correctly" - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_dyn2)%is_water_species(check, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - "trying to get water_species prop for dyn_const2 index = ", & - index_dyn2, trim(errmsg) - end if - if (errflg == 0) then - if (check) then ! Should now be False - write(6, *) "ERROR: 'water_species=.false. did not set", & - " water_species constituent property correctly" - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! ------------------- - - ! Check that setting a constituent's default value works as expected - call const_props(index_liq)%has_default(has_default, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to check for default for cld_liq index = ", index_liq, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (has_default) then - write(6, *) "ERROR: cloud liquid mass_mixing_ratio should not have default but does" - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_ice)%has_default(has_default, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to check for default for cld_ice index = ", index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if ( .not. has_default) then - write(6, *) "ERROR: cloud ice mass_mixing_ratio should have default but doesn't" - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_ice)%default_value(default_value, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to grab default for cld_ice index = ", index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (default_value /= 0.0_kind_phys) then - write(6, *) "ERROR: cloud ice mass_mixing_ratio default is ", default_value, & - " but should be 0.0" - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! ++++++++++++++++++++++++++++++++++ + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get long_name for cld_liq index = ", & + index_liq, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'Cloud liquid dry mixing ratio') then + write(6, *) "ERROR: long name, '", trim(const_str), & + "' should be 'Cloud liquid dry mixing ratio'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check long name for a dynamic constituent + call const_props(index_dyn1)%long_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get long_name for dyn_const1 index = ", & + index_dyn1, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'dyn const1') then + write(6, *) "ERROR: long name, '", trim(const_str), & + "' should be 'dyn const1'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if - ! Set error flag to the "final" value, because any error - ! above will likely result in a large number of failures - ! below: - errflg = errflg_final + ! Diagnostic name: + call const_props(index_liq)%diagnostic_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get diagnostic name for cld_liq index = ", & + index_liq, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'CLDLIQ') then + write(6, *) "ERROR: diagnostic name, '", trim(const_str), & + "' should be 'CLDLIQ'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check default diagnostic name is set correctly + call const_props(index_ice)%diagnostic_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get diagnostic name for cld_ice index = ", & + index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'cld_ice_array') then + write(6, *) "ERROR: diagnostic name, '", trim(const_str), & + "' should be 'cld_ice_array'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check diagnostic name of a dynamic constituent + call const_props(index_dyn2)%diagnostic_name(const_str, errflg, & + errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get diagnostic name for dyn_const2 index = ", & + index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'DYNCONST2') then + write(6, *) "ERROR: diagnostic name, '", trim(const_str), & + "' should be 'DYNCONST2'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if - ! Use the suite information to setup the run - do sind = 1, num_suites + ! Mass mixing ratio: + call const_props(index_ice)%is_mass_mixing_ratio(const_log, errflg, & + errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get mass mixing ratio prop for cld_ice index = ", & + index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if if (errflg == 0) then - 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) - exit - end if - end if - end do - - ! Check indices - call check_constituent_indices(test_scalar_const_index, test_const_indices, & - errmsg, errflg) - call check_errflg(subname // " check suite indices", errflg, errmsg, & - errflg_final) - - ! Loop over time steps - do time_step = 1, num_time_steps - ! Initialize the timestep - do sind = 1, num_suites - if (errflg == 0) then - call test_host_ccpp_physics_timestep_initial( & - test_suites(sind)%suite_name, errmsg, errflg) - if (errflg /= 0) then - write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(errmsg) - end if - end if - end do + if (.not. const_log) then + write(6, *) "ERROR: cloud ice is not a mass mixing_ratio" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check mass mixing ratio for a dynamic constituent + call const_props(index_dyn2)%is_mass_mixing_ratio(const_log, errflg, & + errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get mass mixing ratio prop for dyn_const2 index = ", & + index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (.not. const_log) then + write(6, *) "ERROR: dyn_const2 is not a mass mixing_ratio" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if - do col_start = 1, ncols, 5 - if (errflg /= 0) then - continue - end if - col_end = min(col_start + 4, ncols) - - do sind = 1, num_suites - do index = 1, size(test_suites(sind)%suite_parts) - 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) - 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 if - end do - end do - end do - ! Check indices - call check_constituent_indices(test_scalar_const_index, test_const_indices, & - errmsg, errflg) - call check_errflg(subname // " check suite indices", errflg, errmsg, & - errflg_final) + ! Dry mixing ratio: + call const_props(index_ice)%is_dry(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get dry prop for cld_ice index = ", index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (.not. const_log) then + write(6, *) "ERROR: cloud ice mass_mixing_ratio is not dry" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check wet mixing ratio for dynamic constituent 1 + call const_props(index_dyn1)%is_dry(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get dry prop for dyn_const1 index = ", index_dyn1, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (const_log) then + write(6, *) "ERROR: dyn_const1 is dry and should be wet" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_dyn1)%is_wet(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get wet prop for dyn_const1 index = ", index_dyn1, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (.not. const_log) then + write(6, *) "ERROR: dyn_const1 is not wet but should be" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check moist mixing ratio for dynamic constituent 2 + call const_props(index_dyn2)%is_dry(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get dry prop for dyn_const2 index = ", index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (const_log) then + write(6, *) "ERROR: dyn_const2 is dry and should be moist" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_dyn2)%is_moist(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get moist prop for dyn_const2 index = ", index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (.not. const_log) then + write(6, *) "ERROR: dyn_const2 is not moist but should be" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check dry mixing ratio for dynamic constituent 3 + call const_props(index_dyn3)%is_dry(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get dry prop for dyn_const3 index = ", index_dyn3, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (.not. const_log) then + write(6, *) "ERROR: dyn_const3 is not dry and should be" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if - do sind = 1, num_suites - 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), ': ', & + ! ------------------- + + ! ------------------- + ! minimum value tests: + ! ------------------- + + ! Check that a constituent's minimum value defaults to zero: + call const_props(index_dyn2)%minimum(check_value, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get minimum value for dyn_const2 index = ", index_dyn2, & trim(errmsg) - exit - end if - end do + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (check_value /= 0._kind_phys) then ! Should be zero + write(6, *) "ERROR: 'minimum' should default to zero for all ", & + "constituents unless set by host model or scheme metadata." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that a constituent instantiated with a specified minimum value + ! actually contains that minimum value property: + call const_props(index_dyn1)%minimum(check_value, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get minimum value for dyn_const1 index = ", index_dyn1, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (check_value /= 1000._kind_phys) then !Should be 1000 + write(6, *) "ERROR: 'minimum' should give a value of 1000 ", & + "for dyn_const1, as was set during instantiation." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that setting a constituent's minimum value works + ! as expected: + call const_props(index_dyn1)%set_minimum(1._kind_phys, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to set minimum value for dyn_const1 index = ", index_dyn1, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + call const_props(index_dyn1)%minimum(check_value, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + " trying to get minimum value for dyn_const1 index = ", & + index_dyn1, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + end if + if (errflg == 0) then + if (check_value /= 1._kind_phys) then ! Should now be one + write(6, *) "ERROR: 'set_minimum' did not set constituent", & + " minimum value correctly." + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! ---------------------- + ! molecular weight tests: + ! ---------------------- + + ! Check that a constituent instantiated with a specified molecular + ! weight actually contains that molecular weight property value: + call const_props(index)%molar_mass(check_value, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get molecular weight for specific humidity index = ", & + index, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (check_value /= 2000._kind_phys) then ! Should be 2000 + write(6, *) "ERROR: 'molar_mass' should give a value of 2000 ", & + "for specific humidity, as was set during instantiation." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that setting a constituent's molecular weight works + ! as expected: + call const_props(index_ice)%set_molar_mass(1._kind_phys, errflg, & + errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to set molecular weight for cld_ice index = ", index_ice, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + call const_props(index_ice)%molar_mass(check_value, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + " trying to get molecular weight for cld_ice index = ", & + index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + end if + if (errflg == 0) then + if (check_value /= 1._kind_phys) then ! Should be equal to one + write(6, *) "ERROR: 'set_molar_mass' did not set constituent", & + " molecular weight value correctly." + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! ------------------- + ! thermo-active tests: + ! ------------------- + + ! Check that being thermodynamically active defaults to False: + call const_props(index_ice)%is_thermo_active(check, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get thermo_active prop for cld_ice index = ", index_ice, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (check) then ! Should be False + write(6, *) "ERROR: 'is_thermo_active' should default to False ", & + "for all constituents unless set by host model." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if - ! Run "dycore" + ! Check that setting a constituent to be thermodynamically active works + ! as expected: + call const_props(index_ice)%set_thermo_active(.true., errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to set thermo_active prop for cld_ice index = ", index_ice, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + call const_props(index_ice)%is_thermo_active(check, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + " trying to get thermo_active prop for cld_ice index = ", & + index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + end if if (errflg == 0) then - call advect_constituents() + if (.not. check) then ! Should now be True + write(6, *) "ERROR: 'set_thermo_active' did not set", & + " thermo_active constituent property correctly." + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 end if - end do ! End time step loop + ! ------------------- - do sind = 1, num_suites + ! ------------------- + ! water-species tests: + ! ------------------- + + ! Check that being a water species defaults to False: + call const_props(index_liq)%is_water_species(check, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get water_species prop for cld_liq index = ", index_liq, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if if (errflg == 0) then - call test_host_ccpp_physics_finalize( & - test_suites(sind)%suite_name, errmsg, errflg) - if (errflg /= 0) then - write(6, '(3a)') test_suites(sind)%suite_parts(index), ': ', & + if (check) then ! Should be False + write(6, *) "ERROR: 'is_water_species' should default to False ", & + "for all constituents unless set by host model." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that setting a constituent to be a water species works + ! as expected: + call const_props(index_liq)%set_water_species(.true., errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to set water_species prop for cld_liq index = ", index_liq, & trim(errmsg) - write(6, '(2a)') 'An error occurred in ccpp_timestep_final, ', & - 'Exiting...' - exit - end if - end if - end do - - if (errflg == 0) then - ! Run finished without error, check answers - if (compare_data(num_advected)) then - write(6, *) 'Answers are correct!' - errflg = 0 + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + call const_props(index_liq)%is_water_species(check, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + " trying to get water_species prop for cld_liq index = ", & + index_liq, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + end if + if (errflg == 0) then + if (.not. check) then ! Should now be True + write(6, *) "ERROR: 'set_water_species' did not set", & + " water_species constituent property correctly." + errflg_final = -1 ! Notify test script that a failure occurred + end if else - write(6, *) 'Answers are not correct!' - errflg = -1 + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that setting a constituent to be a water species via the + ! instantiate call works as expected + call const_props(index_dyn1)%is_water_species(check, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + "trying to get water_species prop for dyn_const1 index = ", & + index_dyn1, trim(errmsg) + end if + if (errflg == 0) then + if (.not. check) then ! Should now be True + write(6,*) "ERROR: 'water_species=.true. did not set", & + " water_species constituent property correctly" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_dyn2)%is_water_species(check, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + "trying to get water_species prop for dyn_const2 index = ", & + index_dyn2, trim(errmsg) end if - end if + if (errflg == 0) then + if (check) then ! Should now be False + write(6,*) "ERROR: 'water_species=.false. did not set", & + " water_species constituent property correctly" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! ------------------- + + ! Check that setting a constituent's default value works as expected + call const_props(index_liq)%has_default(has_default, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to check for default for cld_liq index = ", index_liq, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (has_default) then + write(6, *) "ERROR: cloud liquid mass_mixing_ratio should not have default but does" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_ice)%has_default(has_default, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to check for default for cld_ice index = ", index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (.not. has_default) then + write(6, *) "ERROR: cloud ice mass_mixing_ratio should have default but doesn't" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_ice)%default_value(default_value, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to grab default for cld_ice index = ", index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (default_value /= 0.0_kind_phys) then + write(6, *) "ERROR: cloud ice mass_mixing_ratio default is ", default_value, & + " but should be 0.0" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! ++++++++++++++++++++++++++++++++++ + + ! Set error flag to the "final" value, because any error + ! above will likely result in a large number of failures + ! below: + errflg = errflg_final + + ! Use the suite information to setup the run + do sind = 1, num_suites + if (errflg == 0) then + 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) + exit + end if + end if + end do + + ! Check indices + call check_constituent_indices(test_scalar_const_index, test_const_indices, & + errmsg, errflg) + call check_errflg(subname//" check suite indices", errflg, errmsg, & + errflg_final) + + ! Loop over time steps + do time_step = 1, num_time_steps + ! Initialize the timestep + do sind = 1, num_suites + if (errflg == 0) then + call test_host_ccpp_physics_timestep_initial( & + test_suites(sind)%suite_name, errmsg, errflg) + if (errflg /= 0) then + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(errmsg) + end if + end if + end do + + do col_start = 1, ncols, 5 + if (errflg /= 0) then + continue + end if + col_end = MIN(col_start + 4, ncols) + + do sind = 1, num_suites + do index = 1, size(test_suites(sind)%suite_parts) + 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) + 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 if + end do + end do + end do + ! Check indices + call check_constituent_indices(test_scalar_const_index, test_const_indices, & + errmsg, errflg) + call check_errflg(subname//" check suite indices", errflg, errmsg, & + errflg_final) + + do sind = 1, num_suites + 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 + + ! Run "dycore" + if (errflg == 0) then + call advect_constituents() + end if + end do ! End time step loop + + do sind = 1, num_suites + if (errflg == 0) then + call test_host_ccpp_physics_finalize( & + test_suites(sind)%suite_name, errmsg, errflg) + 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 if + end do + + if (errflg == 0) then + ! Run finished without error, check answers + if (compare_data(num_advected)) then + write(6, *) 'Answers are correct!' + errflg = 0 + else + write(6, *) 'Answers are not correct!' + errflg = -1 + end if + end if - ! Make sure "final" flag is non-zero if "errflg" is: - if (errflg /= 0) then - errflg_final = -1 ! Notify test script that a failure occured - end if + ! Make sure "final" flag is non-zero if "errflg" is: + if (errflg /= 0) then + errflg_final = -1 ! Notify test script that a failure occured + end if - ! Set return value to False if any errors were found: - retval = errflg_final == 0 + ! Set return value to False if any errors were found: + retval = errflg_final == 0 - end subroutine test_host + end subroutine test_host -end module test_prog + end module test_prog diff --git a/test/advection_test/test_host_data.F90 b/test/advection_test/test_host_data.F90 index f360ad79..bbf0efdc 100644 --- a/test/advection_test/test_host_data.F90 +++ b/test/advection_test/test_host_data.F90 @@ -7,22 +7,22 @@ module test_host_data !> \section arg_table_physics_state Argument Table !! \htmlinclude arg_table_physics_state.html type physics_state - real(kind=kind_phys), allocatable :: ps(:) ! surface pressure - real(kind=kind_phys), allocatable :: temp(:, :) ! temperature - real(kind=kind_phys), dimension(:, :, :), pointer :: q => null() ! constituent array + real(kind_phys), allocatable :: ps(:) ! surface pressure + real(kind_phys), allocatable :: temp(:,:) ! temperature + real(kind_phys), dimension(:,:,:), pointer :: q => NULL() ! constituent array end type physics_state !> \section arg_table_test_host_data Argument Table !! \htmlinclude arg_table_test_host_data.html integer, public, parameter :: num_consts = 3 - character(len=32), public, parameter :: std_name_array(num_consts) = (/ & - 'specific_humidity ', & - 'cloud_liquid_dry_mixing_ratio', & - 'cloud_ice_dry_mixing_ratio ' /) + character(len=32), public, parameter :: std_name_array(num_consts) = (/ & + 'specific_humidity ', & + 'cloud_liquid_dry_mixing_ratio', & + 'cloud_ice_dry_mixing_ratio ' /) character(len=32), public, parameter :: const_std_name = std_name_array(1) - integer :: const_inds(num_consts) = -1 ! test array access from suite - integer :: const_index = -1 ! test scalar access from suite + integer :: const_inds(num_consts) = -1 ! test array access from suite + integer :: const_index = -1 ! test scalar access from suite public :: allocate_physics_state public :: check_constituent_indices @@ -30,63 +30,63 @@ module test_host_data contains subroutine check_constituent_indices(test_index, test_indices, errmsg, errflg) - ! Check constituent indices against what was found by suite - ! indices are passed in rather than looked up to avoid a dependency loop - ! Dummy arguments - integer, intent(in) :: test_index ! scalar const index from host - integer, intent(in) :: test_indices(:) ! array_test_indices from host - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variable - integer :: indx - integer :: emstrt - - errflg = 0 - errmsg = '' - if (test_index /= const_index) then - emstrt = len_trim(errmsg) + 1 - write(errmsg(emstrt:), '(2a,i0,a,i0)') 'const_index_check for ', & - const_std_name, test_index, ' /= ', const_index - errflg = errflg + 1 - end if - do indx = 1, num_consts - if (test_indices(indx) /= const_inds(indx)) then + ! Check constituent indices against what was found by suite + ! indices are passed in rather than looked up to avoid a dependency loop + ! Dummy arguments + integer, intent(in) :: test_index ! scalar const index from host + integer, intent(in) :: test_indices(:) ! array_test_indices from host + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variable + integer :: indx + integer :: emstrt + + errflg = 0 + errmsg = '' + if (test_index /= const_index) then emstrt = len_trim(errmsg) + 1 - if (len_trim(errmsg) > 0) then - write(errmsg(emstrt:), '(", ")') - emstrt = emstrt + 2 - end if - write(errmsg(emstrt:), '(2a,i0,a,i0)') 'const_indices_check for ', & - std_name_array(indx), test_indices(indx), ' /= ', const_inds(indx) + write(errmsg(emstrt:), '(2a,i0,a,i0)') 'const_index_check for ', & + const_std_name, test_index, ' /= ', const_index errflg = errflg + 1 - end if - end do + end if + do indx = 1, num_consts + if (test_indices(indx) /= const_inds(indx)) then + emstrt = len_trim(errmsg) + 1 + if (len_trim(errmsg) > 0) then + write(errmsg(emstrt:), '(", ")') + emstrt = emstrt + 2 + end if + write(errmsg(emstrt:), '(2a,i0,a,i0)') 'const_indices_check for ', & + std_name_array(indx), test_indices(indx), ' /= ', const_inds(indx) + errflg = errflg + 1 + end if + end do - ! Reset for next test - const_index = -1 - const_inds = -1 + ! Reset for next test + const_index = -1 + const_inds = -1 end subroutine check_constituent_indices subroutine allocate_physics_state(cols, levels, constituents, state) - integer, intent(in) :: cols - integer, intent(in) :: levels - real(kind=kind_phys), pointer :: constituents(:, :, :) + integer, intent(in) :: cols + integer, intent(in) :: levels + real(kind_phys), pointer :: constituents(:,:,:) type(physics_state), intent(out) :: state if (allocated(state%ps)) then - deallocate(state%ps) + deallocate(state%ps) end if allocate(state%ps(cols)) state%ps = 0.0_kind_phys if (allocated(state%temp)) then - deallocate(state%temp) + deallocate(state%temp) end if allocate(state%temp(cols, levels)) if (associated(state%q)) then - ! Do not deallocate (we do not own this array) - nullify(state%q) + ! Do not deallocate (we do not own this array) + nullify(state%q) end if ! Point to the advected constituents array state%q => constituents diff --git a/test/advection_test/test_host_mod.F90 b/test/advection_test/test_host_mod.F90 index c5f3bb26..50826f17 100644 --- a/test/advection_test/test_host_mod.F90 +++ b/test/advection_test/test_host_mod.F90 @@ -1,176 +1,175 @@ module test_host_mod - use ccpp_kinds, only: kind_phys - use test_host_data, only: physics_state, & - allocate_physics_state - - implicit none - public - - integer, parameter :: num_time_steps = 2 - real(kind=kind_phys), parameter :: tolerance = 1.0e-13_kind_phys - - !> \section arg_table_test_host_mod Argument Table - !! \htmlinclude arg_table_test_host_mod.html - !! - integer, parameter :: ncols = 10 - integer, parameter :: pver = 5 - integer, parameter :: pverp = pver + 1 - integer, protected :: ncnst = -1 - integer, protected :: index_qv = -1 - real(kind=kind_phys) :: dt - real(kind=kind_phys), parameter :: tfreeze = 273.15_kind_phys - type(physics_state) :: phys_state - integer :: num_model_times = -1 - integer, allocatable :: model_times(:) - - public :: init_data - public :: compare_data - public :: twist_array - - real(kind=kind_phys), private, allocatable :: check_vals(:, :, :) - real(kind=kind_phys), private :: check_temp(ncols, pver) - integer, private :: ind_liq = -1 - integer, private :: ind_ice = -1 + use ccpp_kinds, only: kind_phys + use test_host_data, only: physics_state, allocate_physics_state + + implicit none + public + + integer, parameter :: num_time_steps = 2 + real(kind_phys), parameter :: tolerance = 1.0e-13_kind_phys + + !> \section arg_table_test_host_mod Argument Table + !! \htmlinclude arg_table_test_host_mod.html + !! + integer, parameter :: ncols = 10 + integer, parameter :: pver = 5 + integer, parameter :: pverP = pver + 1 + integer, protected :: ncnst = -1 + integer, protected :: index_qv = -1 + real(kind_phys) :: dt + real(kind_phys), parameter :: tfreeze = 273.15_kind_phys + type(physics_state) :: phys_state + integer :: num_model_times = -1 + integer, allocatable :: model_times(:) + + public :: init_data + public :: compare_data + public :: twist_array + + real(kind_phys), private, allocatable :: check_vals(:,:,:) + real(kind_phys), private :: check_temp(ncols, pver) + integer, private :: ind_liq = -1 + integer, private :: ind_ice = -1 contains - subroutine init_data(constituent_array, index_qv_use, index_liq, index_ice, index_dyn) - - ! Dummy arguments - real(kind=kind_phys), pointer :: constituent_array(:, :, :) ! From host & suites - integer, intent(in) :: index_qv_use - integer, intent(in) :: index_liq - integer, intent(in) :: index_ice - integer, intent(in) :: index_dyn - - ! Local variables - integer :: col - integer :: lev - integer :: cind - integer :: itime - real(kind=kind_phys) :: qmax - real(kind=kind_phys), parameter :: inc = 0.1_kind_phys - - ! Allocate and initialize state - ! Temperature starts above freezing and decreases to -30C - ! water vapor is initialized in odd columns to different amounts - ncnst = size(constituent_array, 3) - call allocate_physics_state(ncols, pver, constituent_array, phys_state) - index_qv = index_qv_use - ind_liq = index_liq - ind_ice = index_ice - allocate(check_vals(ncols, pver, ncnst)) - check_vals(:, :, :) = 0.0_kind_phys - check_vals(:, :, index_dyn) = 1.0_kind_phys - do lev = 1, pver - phys_state%temp(:, lev) = tfreeze + (10.0_kind_phys * (lev - 3)) - qmax = real(lev, kind_phys) - do col = 1, ncols - if (mod(col, 2) == 1) then - phys_state%q(col, lev, index_qv) = qmax - else - phys_state%q(col, lev, index_qv) = 0.0_kind_phys - end if - end do - end do - check_vals(:, :, index_qv) = phys_state%q(:, :, index_qv) - check_temp(:, :) = phys_state%temp(:, :) - ! Do timestep 1 - do col = 1, ncols, 2 - check_temp(col, 1) = check_temp(col, 1) + 0.5_kind_phys - check_vals(col, 1, index_qv) = check_vals(col, 1, index_qv) - inc - check_vals(col, 1, ind_liq) = check_vals(col, 1, ind_liq) + inc - end do - do itime = 1, num_time_steps - do cind = 1, ncnst - call twist_array(check_vals(:, :, cind)) + subroutine init_data(constituent_array, index_qv_use, index_liq, index_ice, index_dyn) + + ! Dummy arguments + real(kind_phys), pointer :: constituent_array(:,:,:) ! From host & suites + integer, intent(in) :: index_qv_use + integer, intent(in) :: index_liq + integer, intent(in) :: index_ice + integer, intent(in) :: index_dyn + + ! Local variables + integer :: col + integer :: lev + integer :: cind + integer :: itime + real(kind_phys) :: qmax + real(kind_phys), parameter :: inc = 0.1_kind_phys + + ! Allocate and initialize state + ! Temperature starts above freezing and decreases to -30C + ! water vapor is initialized in odd columns to different amounts + ncnst = SIZE(constituent_array, 3) + call allocate_physics_state(ncols, pver, constituent_array, phys_state) + index_qv = index_qv_use + ind_liq = index_liq + ind_ice = index_ice + allocate(check_vals(ncols, pver, ncnst)) + check_vals(:,:,:) = 0.0_kind_phys + check_vals(:,:,index_dyn) = 1.0_kind_phys + do lev = 1, pver + phys_state%temp(:, lev) = tfreeze + (10.0_kind_phys * (lev - 3)) + qmax = real(lev, kind_phys) + do col = 1, ncols + if (mod(col, 2) == 1) then + phys_state%q(col, lev, index_qv) = qmax + else + phys_state%q(col, lev, index_qv) = 0.0_kind_phys + end if + end do end do - end do - - end subroutine init_data - - subroutine twist_array(array) - ! Dummy argument - real(kind=kind_phys), intent(inout) :: array(:, :) - - ! Local variables - integer :: icol, ilev ! Field coordinates - integer :: idir ! 'w' sign - integer :: levb, leve ! Starting and ending level indices - real(kind=kind_phys) :: last_val, next_val - - idir = 1 - leve = (pver * mod(ncols, 2)) + mod(ncols - 1, 2) - last_val = array(ncols, leve) - do icol = 1, ncols - levb = ((pver * (1 - idir)) + (1 + idir)) / 2 - leve = ((pver * (1 + idir)) + (1 - idir)) / 2 - do ilev = levb, leve, idir - next_val = array(icol, ilev) - array(icol, ilev) = last_val - last_val = next_val + check_vals(:,:,index_qv) = phys_state%q(:,:,index_qv) + check_temp(:,:) = phys_state%temp(:,:) + ! Do timestep 1 + do col = 1, ncols, 2 + check_temp(col, 1) = check_temp(col, 1) + 0.5_kind_phys + check_vals(col, 1, index_qv) = check_vals(col, 1, index_qv) - inc + check_vals(col, 1, ind_liq) = check_vals(col, 1, ind_liq) + inc end do - idir = -1 * idir - end do - - end subroutine twist_array - - logical function compare_data(ncnst) - - integer, intent(in) :: ncnst - - integer :: col - integer :: lev - integer :: cind - logical :: need_header - real(kind=kind_phys) :: check - real(kind=kind_phys) :: denom - - compare_data = .true. - - need_header = .true. - do lev = 1, pver - do col = 1, ncols - check = check_temp(col, lev) - if (abs((phys_state%temp(col, lev) - check) / check) > & - 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, & - phys_state%temp(col, lev), check - compare_data = .false. - end if + do itime = 1, num_time_steps + do cind = 1, ncnst + call twist_array(check_vals(:,:,cind)) + end do end do - end do - ! Check constituents - need_header = .true. - do cind = 1, ncnst + + end subroutine init_data + + subroutine twist_array(array) + ! Dummy argument + real(kind_phys), intent(inout) :: array(:,:) + + ! Local variables + integer :: icol, ilev ! Field coordinates + integer :: idir ! 'w' sign + integer :: levb, leve ! Starting and ending level indices + real(kind_phys) :: last_val, next_val + + idir = 1 + leve = (pver * mod(ncols, 2)) + mod(ncols-1, 2) + last_val = array(ncols, leve) + do icol = 1, ncols + levb = ((pver * (1 - idir)) + (1 + idir)) / 2 + leve = ((pver * (1 + idir)) + (1 - idir)) / 2 + do ilev = levb, leve, idir + next_val = array(icol, ilev) + array(icol, ilev) = last_val + last_val = next_val + end do + idir = -1 * idir + end do + + end subroutine twist_array + + logical function compare_data(ncnst) + + integer, intent(in) :: ncnst + + integer :: col + integer :: lev + integer :: cind + logical :: need_header + real(kind_phys) :: check + real(kind_phys) :: denom + + compare_data = .true. + + need_header = .true. do lev = 1, pver - do col = 1, ncols - check = check_vals(col, lev, cind) - if (check < tolerance) then - denom = 1.0_kind_phys - else - denom = check - end if - if (abs((phys_state%q(col, lev, cind) - check) / denom) > & - 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. + do col = 1, ncols + check = check_temp(col, lev) + if (abs((phys_state%temp(col, lev) - check) / check) > & + 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, & + phys_state%temp(col, lev), check + compare_data = .false. end if - write(6, '(3i5,2(3x,es15.7))') col, lev, cind, & - phys_state%q(col, lev, cind), check - compare_data = .false. - end if - end do + end do + end do + ! Check constituents + need_header = .true. + do cind = 1, ncnst + do lev = 1, pver + do col = 1, ncols + check = check_vals(col, lev, cind) + if (check < tolerance) then + denom = 1.0_kind_phys + else + denom = check + end if + if (abs((phys_state%q(col, lev, cind) - check) / denom) > & + 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), check + compare_data = .false. + end if + end do + end do end do - end do - end function compare_data + end function compare_data end module test_host_mod diff --git a/test/capgen_test/adjust/temp_kinds.F90 b/test/capgen_test/adjust/temp_kinds.F90 index 3fb4cca4..59e813e5 100644 --- a/test/capgen_test/adjust/temp_kinds.F90 +++ b/test/capgen_test/adjust/temp_kinds.F90 @@ -3,10 +3,10 @@ module temp_kinds - implicit none - private + implicit none + private - integer, public, parameter :: temp_r8 = selected_real_kind(12) !8-byte real - integer, public, parameter :: temp_i8 = selected_int_kind(13) !8-byte integer + integer, public, parameter :: temp_r8 = selected_real_kind(12) !8-byte real + integer, public, parameter :: temp_i8 = selected_int_kind (13) !8-byte integer end module temp_kinds diff --git a/test/capgen_test/source_dir1/environ_conditions.F90 b/test/capgen_test/source_dir1/environ_conditions.F90 index 2d63366e..62183012 100644 --- a/test/capgen_test/source_dir1/environ_conditions.F90 +++ b/test/capgen_test/source_dir1/environ_conditions.F90 @@ -1,51 +1,51 @@ -module environ_conditions +MODULE environ_conditions - use ccpp_kinds, only: kind_phys + USE ccpp_kinds, ONLY: kind_phys - implicit none - private + IMPLICIT NONE + PRIVATE - public :: environ_conditions_init - public :: environ_conditions_run - public :: environ_conditions_finalize + PUBLIC :: environ_conditions_init + PUBLIC :: environ_conditions_run + PUBLIC :: environ_conditions_finalize integer, parameter :: input_model_times = 3 integer, parameter :: input_model_values(input_model_times) = (/ 31, 37, 41 /) -contains +CONTAINS - !> \section arg_table_environ_conditions_run Argument Table - !! \htmlinclude arg_table_environ_conditions_run.html - !! +!> \section arg_table_environ_conditions_run Argument Table +!! \htmlinclude arg_table_environ_conditions_run.html +!! subroutine environ_conditions_run(psurf, errmsg, errflg) ! This routine currently does nothing -- should update values - real(kind=kind_phys), intent(in) :: psurf(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), intent(in) :: psurf(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 - end subroutine environ_conditions_run + END SUBROUTINE environ_conditions_run - !> \section arg_table_environ_conditions_init Argument Table - !! \htmlinclude arg_table_environ_conditions_init.html - !! - subroutine environ_conditions_init(nbox, o3, hno3, ntimes, model_times, & - errmsg, errflg) +!> \section arg_table_environ_conditions_init Argument Table +!! \htmlinclude arg_table_environ_conditions_init.html +!! + subroutine environ_conditions_init (nbox, O3, HNO3, ntimes, model_times, & + errmsg, errflg) - integer, intent(in) :: nbox - real(kind=kind_phys), intent(out) :: o3(:) - real(kind=kind_phys), intent(out) :: hno3(:) - integer, intent(out) :: ntimes - integer, allocatable, intent(out) :: model_times(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- + integer, intent(in) :: nbox + real(kind_phys), intent(out) :: O3(:) + real(kind_phys), intent(out) :: HNO3(:) + integer, intent(out) :: ntimes + integer, allocatable, intent(out) :: model_times(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg +!---------------------------------------------------------------- - integer :: i, j + integer :: i, j errmsg = '' errflg = 0 @@ -53,8 +53,8 @@ subroutine environ_conditions_init(nbox, o3, hno3, ntimes, model_times, & ! This may be replaced with MusicBox json environmental conditions reader??? do i = 1, nbox - o3(i) = real(i, kind_phys) * 1.e-6_kind_phys - hno3(i) = real(i, kind_phys) * 1.e-9_kind_phys + O3(i) = real(i, kind_phys) * 1.e-6_kind_phys + HNO3(i) = real(i, kind_phys) * 1.e-9_kind_phys end do ntimes = input_model_times @@ -63,34 +63,34 @@ subroutine environ_conditions_init(nbox, o3, hno3, ntimes, model_times, & end subroutine environ_conditions_init - !> \section arg_table_environ_conditions_finalize Argument Table - !! \htmlinclude arg_table_environ_conditions_finalize.html - !! - subroutine environ_conditions_finalize(ntimes, model_times, errmsg, errflg) +!> \section arg_table_environ_conditions_finalize Argument Table +!! \htmlinclude arg_table_environ_conditions_finalize.html +!! + subroutine environ_conditions_finalize (ntimes, model_times, errmsg, errflg) - integer, intent(in) :: ntimes - integer, intent(in) :: model_times(:) + integer, intent(in) :: ntimes + integer, intent(in) :: model_times(:) character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(out) :: errflg ! This routine checks the size and values of model_times if (ntimes /= input_model_times) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'ntimes mismatch, ', ntimes, ' should be ', & - input_model_times + errflg = 1 + write(errmsg, '(2(a,i0))') 'ntimes mismatch, ', ntimes, ' should be ', & + input_model_times else if (size(model_times) /= input_model_times) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'model_times size mismatch, ', & - size(model_times), ' should be ', input_model_times - else if (any(model_times /= input_model_values)) then - errflg = 1 - write(errmsg, *) 'model_times mismatch, ', & - model_times, ' should be ', input_model_values + errflg = 1 + write(errmsg, '(2(a,i0))') 'model_times size mismatch, ', & + size(model_times), ' should be ', input_model_times + else if (ANY(model_times /= input_model_values)) then + errflg = 1 + write(errmsg, *) 'model_times mismatch, ', & + model_times, ' should be ', input_model_values else - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 end if end subroutine environ_conditions_finalize -end module environ_conditions +END MODULE environ_conditions diff --git a/test/capgen_test/source_dir2/temp_set.F90 b/test/capgen_test/source_dir2/temp_set.F90 index da52cf68..0a0aa92c 100644 --- a/test/capgen_test/source_dir2/temp_set.F90 +++ b/test/capgen_test/source_dir2/temp_set.F90 @@ -1,84 +1,83 @@ !Test 3D parameterization ! -module temp_set - - use ccpp_kinds, only: kind_phys, & - kind_temp - - implicit none - private - - public :: temp_set_init - public :: temp_set_timestep_initialize - public :: temp_set_run - public :: temp_set_finalize - -contains - - !> \section arg_table_temp_set_run Argument Table - !! \htmlinclude arg_table_temp_set_run.html - !! - subroutine temp_set_run(ncol, lev, timestep, temp_level, temp_diag, temp, ps, & - to_promote, promote_pcnst, slev_lbound, soil_levs, var_array, errmsg, errflg) - !---------------------------------------------------------------- - implicit none - !---------------------------------------------------------------- - - integer, intent(in) :: ncol, lev, slev_lbound - real(kind=kind_phys), intent(out) :: temp(:, :) - real(kind=kind_phys), intent(in) :: timestep - real(kind=kind_phys), intent(in) :: ps(:) - real(kind=kind_phys), intent(inout) :: temp_level(:, :) - real(kind=kind_phys), intent(inout) :: temp_diag(:, :) - real(kind=kind_phys), intent(inout) :: soil_levs(slev_lbound:) - real(kind=kind_phys), intent(inout) :: var_array(:, :, :, :) - real(kind=kind_temp), intent(out) :: to_promote(:, :) - real(kind=kind_phys), intent(out) :: promote_pcnst(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - integer :: ilev - - integer :: col_index - integer :: lev_index - real(kind=kind_phys) :: internal_scalar_var +MODULE temp_set + + USE ccpp_kinds, ONLY: kind_phys, kind_temp + + IMPLICIT NONE + PRIVATE + + PUBLIC :: temp_set_init + PUBLIC :: temp_set_timestep_initialize + PUBLIC :: temp_set_run + PUBLIC :: temp_set_finalize + +CONTAINS + +!> \section arg_table_temp_set_run Argument Table +!! \htmlinclude arg_table_temp_set_run.html +!! + SUBROUTINE temp_set_run(ncol, lev, timestep, temp_level, temp_diag, temp, ps, & + to_promote, promote_pcnst, slev_lbound, soil_levs, var_array, errmsg, errflg) +!---------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------- + + integer, intent(in) :: ncol, lev, slev_lbound + REAL(kind_phys), intent(out) :: temp(:,:) + real(kind_phys), intent(in) :: timestep + real(kind_phys), intent(in) :: ps(:) + REAL(kind_phys), INTENT(inout) :: temp_level(:, :) + real(kind_phys), intent(inout) :: temp_diag(:,:) + real(kind_phys), intent(inout) :: soil_levs(slev_lbound:) + real(kind_phys), intent(inout) :: var_array(:,:,:,:) + real(kind_temp), intent(out) :: to_promote(:, :) + real(kind_phys), intent(out) :: promote_pcnst(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg +!---------------------------------------------------------------- + integer :: ilev + + integer :: col_index + integer :: lev_index + real(kind_phys) :: internal_scalar_var errmsg = '' errflg = 0 ilev = size(temp_level, 2) if (ilev /= (lev + 1)) then - errflg = 1 - errmsg = 'Invalid value for ilev, must be lev+1' - return + errflg = 1 + errmsg = 'Invalid value for ilev, must be lev+1' + return end if do col_index = 1, ncol - do lev_index = 1, lev - temp(col_index, lev_index) = (temp_level(col_index, lev_index) & - + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys - end do + do lev_index = 1, lev + temp(col_index, lev_index) = (temp_level(col_index, lev_index) & + + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys + end do end do - var_array(:, :, :, :) = 1._kind_phys + var_array(:,:,:,:) = 1._kind_phys ! internal_scalar_var = soil_levs(slev_lbound) internal_scalar_var = soil_levs(0) - end subroutine temp_set_run + END SUBROUTINE temp_set_run - !> \section arg_table_temp_set_init Argument Table - !! \htmlinclude arg_table_temp_set_init.html - !! +!> \section arg_table_temp_set_init Argument Table +!! \htmlinclude arg_table_temp_set_init.html +!! subroutine temp_set_init(temp_inc_in, fudge, temp_inc_set, errmsg, errflg) - real(kind=kind_phys), intent(in) :: temp_inc_in - real(kind=kind_phys), intent(in) :: fudge - real(kind=kind_phys), intent(out) :: temp_inc_set - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), intent(in) :: temp_inc_in + real(kind_phys), intent(in) :: fudge + real(kind_phys), intent(out) :: temp_inc_set + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg temp_inc_set = temp_inc_in @@ -87,17 +86,17 @@ subroutine temp_set_init(temp_inc_in, fudge, temp_inc_set, errmsg, errflg) end subroutine temp_set_init - !> \section arg_table_temp_set_timestep_initialize Argument Table - !! \htmlinclude arg_table_temp_set_timestep_initialize.html - !! - subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & - errmsg, errflg) +!> \section arg_table_temp_set_timestep_initialize Argument Table +!! \htmlinclude arg_table_temp_set_timestep_initialize.html +!! + subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & + errmsg, errflg) - integer, intent(in) :: ncol - real(kind=kind_phys), intent(in) :: temp_inc - real(kind=kind_phys), intent(inout) :: temp_level(:, :) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + real(kind_phys), intent(in) :: temp_inc + real(kind_phys), intent(inout) :: temp_level(:,:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 @@ -106,13 +105,13 @@ subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & end subroutine temp_set_timestep_initialize - !> \section arg_table_temp_set_finalize Argument Table - !! \htmlinclude arg_table_temp_set_finalize.html - !! +!> \section arg_table_temp_set_finalize Argument Table +!! \htmlinclude arg_table_temp_set_finalize.html +!! subroutine temp_set_finalize(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 @@ -121,4 +120,4 @@ subroutine temp_set_finalize(errmsg, errflg) end subroutine temp_set_finalize -end module temp_set +END MODULE temp_set diff --git a/test/capgen_test/temp_adjust.F90 b/test/capgen_test/temp_adjust.F90 index e645adfc..35c951e0 100644 --- a/test/capgen_test/temp_adjust.F90 +++ b/test/capgen_test/temp_adjust.F90 @@ -3,8 +3,7 @@ module temp_adjust - use ccpp_kinds, only: kind_phys, & - kind_temp + use ccpp_kinds, only: kind_phys, kind_temp implicit none private @@ -68,7 +67,7 @@ subroutine temp_adjust_run(foo, timestep, interstitial_var, temp_prev, temp_laye return end if - if ( .not. module_level_config) then + if (.not.module_level_config) then ! do nothing return end if diff --git a/test/capgen_test/test_capgen_host_integration.F90 b/test/capgen_test/test_capgen_host_integration.F90 index 4b1bd1d4..eb11f2f8 100644 --- a/test/capgen_test/test_capgen_host_integration.F90 +++ b/test/capgen_test/test_capgen_host_integration.F90 @@ -1,8 +1,5 @@ program test - use test_prog, only: test_host, & - suite_info, & - cm, & - cs + use test_prog, only: test_host, suite_info, cm, cs implicit none diff --git a/test/capgen_test/test_host.F90 b/test/capgen_test/test_host.F90 index c79d91ff..6e39c787 100644 --- a/test/capgen_test/test_host.F90 +++ b/test/capgen_test/test_host.F90 @@ -106,8 +106,7 @@ subroutine test_host(retval, test_suites) #ifdef _OPENMP use omp_lib #endif - use test_host_mod, only: ncols, & - num_time_steps + 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 @@ -115,9 +114,7 @@ subroutine test_host(retval, test_suites) 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_host_mod, only: init_data, compare_data, check_model_times use test_utils, only: check_list type(suite_info), intent(in) :: test_suites(:) @@ -159,7 +156,7 @@ subroutine test_host(retval, test_suites) end do end if !!! Return here if any check failed - if ( .not. retval) then + if (.not.retval) then return end if @@ -287,7 +284,7 @@ subroutine test_host(retval, test_suites) if (errflg == 0) then ! Run finished without error, check answers - if ( .not. check_model_times()) then + if (.not.check_model_times()) then write(6, *) 'Model times error!' errflg = -1 else if (compare_data()) then diff --git a/test/capgen_test/test_host_mod.F90 b/test/capgen_test/test_host_mod.F90 index b479d9a5..aecc5f15 100644 --- a/test/capgen_test/test_host_mod.F90 +++ b/test/capgen_test/test_host_mod.F90 @@ -1,8 +1,7 @@ module test_host_mod use ccpp_kinds, only: kind_phys - use test_host_data, only: physics_state, & - allocate_physics_state + use test_host_data, only: physics_state, allocate_physics_state implicit none public @@ -80,7 +79,7 @@ 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 + 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 diff --git a/test/ddthost_test/environ_conditions.F90 b/test/ddthost_test/environ_conditions.F90 index 2d63366e..b6816117 100644 --- a/test/ddthost_test/environ_conditions.F90 +++ b/test/ddthost_test/environ_conditions.F90 @@ -14,38 +14,38 @@ module environ_conditions contains - !> \section arg_table_environ_conditions_run Argument Table - !! \htmlinclude arg_table_environ_conditions_run.html - !! +!> \section arg_table_environ_conditions_run Argument Table +!! \htmlinclude arg_table_environ_conditions_run.html +!! subroutine environ_conditions_run(psurf, errmsg, errflg) ! This routine currently does nothing -- should update values - real(kind=kind_phys), intent(in) :: psurf(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), intent(in) :: psurf(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 end subroutine environ_conditions_run - !> \section arg_table_environ_conditions_init Argument Table - !! \htmlinclude arg_table_environ_conditions_init.html - !! - subroutine environ_conditions_init(nbox, o3, hno3, ntimes, model_times, & - errmsg, errflg) - - integer, intent(in) :: nbox - real(kind=kind_phys), intent(out) :: o3(:) - real(kind=kind_phys), intent(out) :: hno3(:) - integer, intent(out) :: ntimes - integer, allocatable, intent(out) :: model_times(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- +!> \section arg_table_environ_conditions_init Argument Table +!! \htmlinclude arg_table_environ_conditions_init.html +!! + subroutine environ_conditions_init (nbox, O3, HNO3, ntimes, model_times, & + errmsg, errflg) + + integer, intent(in) :: nbox + real(kind_phys), intent(out) :: O3(:) + real(kind_phys), intent(out) :: HNO3(:) + integer, intent(out) :: ntimes + integer, allocatable, intent(out) :: model_times(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg +!---------------------------------------------------------------- - integer :: i, j + integer :: i, j errmsg = '' errflg = 0 @@ -53,8 +53,8 @@ subroutine environ_conditions_init(nbox, o3, hno3, ntimes, model_times, & ! This may be replaced with MusicBox json environmental conditions reader??? do i = 1, nbox - o3(i) = real(i, kind_phys) * 1.e-6_kind_phys - hno3(i) = real(i, kind_phys) * 1.e-9_kind_phys + O3(i) = real(i, kind_phys) * 1.e-6_kind_phys + HNO3(i) = real(i, kind_phys) * 1.e-9_kind_phys end do ntimes = input_model_times @@ -63,32 +63,32 @@ subroutine environ_conditions_init(nbox, o3, hno3, ntimes, model_times, & end subroutine environ_conditions_init - !> \section arg_table_environ_conditions_finalize Argument Table - !! \htmlinclude arg_table_environ_conditions_finalize.html - !! - subroutine environ_conditions_finalize(ntimes, model_times, errmsg, errflg) +!> \section arg_table_environ_conditions_finalize Argument Table +!! \htmlinclude arg_table_environ_conditions_finalize.html +!! + subroutine environ_conditions_finalize (ntimes, model_times, errmsg, errflg) - integer, intent(in) :: ntimes - integer, intent(in) :: model_times(:) + integer, intent(in) :: ntimes + integer, intent(in) :: model_times(:) character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(out) :: errflg ! This routine checks the size and values of model_times if (ntimes /= input_model_times) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'ntimes mismatch, ', ntimes, ' should be ', & - input_model_times + errflg = 1 + write(errmsg, '(2(a,i0))') 'ntimes mismatch, ', ntimes, ' should be ', & + input_model_times else if (size(model_times) /= input_model_times) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'model_times size mismatch, ', & - size(model_times), ' should be ', input_model_times + errflg = 1 + write(errmsg, '(2(a,i0))') 'model_times size mismatch, ', & + size(model_times), ' should be ', input_model_times else if (any(model_times /= input_model_values)) then - errflg = 1 - write(errmsg, *) 'model_times mismatch, ', & - model_times, ' should be ', input_model_values + errflg = 1 + write(errmsg, *) 'model_times mismatch, ', & + model_times, ' should be ', input_model_values else - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 end if end subroutine environ_conditions_finalize diff --git a/test/ddthost_test/host_ccpp_ddt.F90 b/test/ddthost_test/host_ccpp_ddt.F90 index b60c81af..157f795f 100644 --- a/test/ddthost_test/host_ccpp_ddt.F90 +++ b/test/ddthost_test/host_ccpp_ddt.F90 @@ -1,16 +1,16 @@ module host_ccpp_ddt - implicit none - private + implicit none + private - !> \section arg_table_ccpp_info_t Argument Table - !! \htmlinclude arg_table_ccpp_info_t.html - !! - type, public :: ccpp_info_t - integer :: col_start ! horizontal_loop_begin - integer :: col_end ! horizontal_loop_end - character(len=512) :: errmsg ! ccpp_error_message - integer :: errflg ! ccpp_error_code - end type ccpp_info_t + !> \section arg_table_ccpp_info_t Argument Table + !! \htmlinclude arg_table_ccpp_info_t.html + !! + type, public :: ccpp_info_t + integer :: col_start ! horizontal_loop_begin + integer :: col_end ! horizontal_loop_end + character(len=512) :: errmsg ! ccpp_error_message + integer :: errflg ! ccpp_error_code + end type ccpp_info_t end module host_ccpp_ddt diff --git a/test/ddthost_test/make_ddt.F90 b/test/ddthost_test/make_ddt.F90 index a0de4177..c9d0832b 100644 --- a/test/ddthost_test/make_ddt.F90 +++ b/test/ddthost_test/make_ddt.F90 @@ -3,131 +3,132 @@ module make_ddt - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: make_ddt_init - public :: make_ddt_run - public :: make_ddt_timestep_final - public :: vmr_type + public :: make_ddt_init + public :: make_ddt_run + public :: make_ddt_timestep_final + public :: vmr_type + + !> \section arg_table_vmr_type Argument Table + !! \htmlinclude arg_table_vmr_type.html + !! + type vmr_type + integer :: nvmr + real(kind_phys), allocatable :: vmr_array(:,:) + end type vmr_type - !> \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(:, :) - 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 predecessor 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, ccpp_info, vmr, errmsg, errflg) - use host_ccpp_ddt, only: ccpp_info_t - - ! Dummy arguments - integer, intent(in) :: nbox - type(ccpp_info_t), intent(in) :: ccpp_info - 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 + !> \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 predecessor 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, ccpp_info, vmr, errmsg, errflg) + use host_ccpp_ddt, only: ccpp_info_t + + ! Dummy arguments + integer, intent(in) :: nbox + type(ccpp_info_t), intent(in) :: ccpp_info + 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 diff --git a/test/ddthost_test/setup_coeffs.F90 b/test/ddthost_test/setup_coeffs.F90 index 09c7fcc1..27918695 100644 --- a/test/ddthost_test/setup_coeffs.F90 +++ b/test/ddthost_test/setup_coeffs.F90 @@ -10,9 +10,9 @@ module setup_coeffs !! subroutine setup_coeffs_timestep_init(coeffs, errmsg, errflg) - real(kind=kind_phys), intent(inout) :: coeffs(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), intent(inout) :: coeffs(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 diff --git a/test/ddthost_test/temp_set.F90 b/test/ddthost_test/temp_set.F90 index ce1c32ed..27233e92 100644 --- a/test/ddthost_test/temp_set.F90 +++ b/test/ddthost_test/temp_set.F90 @@ -15,59 +15,59 @@ module temp_set contains - !> \section arg_table_temp_set_run Argument Table - !! \htmlinclude arg_table_temp_set_run.html - !! - subroutine temp_set_run(ncol, lev, timestep, temp_level, temp, ps, & - to_promote, promote_pcnst, errmsg, errflg) - !---------------------------------------------------------------- - implicit none - !---------------------------------------------------------------- - - integer, intent(in) :: ncol, lev - real(kind=kind_phys), intent(out) :: temp(:, :) - real(kind=kind_phys), intent(in) :: timestep - real(kind=kind_phys), intent(in) :: ps(:) - real(kind=kind_phys), intent(inout) :: temp_level(:, :) - real(kind=kind_phys), intent(out) :: to_promote(:, :) - real(kind=kind_phys), intent(out) :: promote_pcnst(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - integer :: ilev - - integer :: col_index - integer :: lev_index +!> \section arg_table_temp_set_run Argument Table +!! \htmlinclude arg_table_temp_set_run.html +!! + subroutine temp_set_run(ncol, lev, timestep, temp_level, temp, ps, & + to_promote, promote_pcnst, errmsg, errflg) +!---------------------------------------------------------------- + implicit none +!---------------------------------------------------------------- + + integer, intent(in) :: ncol, lev + real(kind_phys), intent(out) :: temp(:,:) + real(kind_phys), intent(in) :: timestep + real(kind_phys), intent(in) :: ps(:) + real(kind_phys), intent(inout) :: temp_level(:, :) + real(kind_phys), intent(out) :: to_promote(:, :) + real(kind_phys), intent(out) :: promote_pcnst(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg +!---------------------------------------------------------------- + integer :: ilev + + integer :: col_index + integer :: lev_index errmsg = '' errflg = 0 ilev = size(temp_level, 2) if (ilev /= (lev + 1)) then - errflg = 1 - errmsg = 'Invalid value for ilev, must be lev+1' - return + errflg = 1 + errmsg = 'Invalid value for ilev, must be lev+1' + return end if do col_index = 1, ncol - do lev_index = 1, lev - temp(col_index, lev_index) = (temp_level(col_index, lev_index) & - + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys - end do + do lev_index = 1, lev + temp(col_index, lev_index) = (temp_level(col_index, lev_index) & + + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys + end do end do end subroutine temp_set_run - !> \section arg_table_temp_set_init Argument Table - !! \htmlinclude arg_table_temp_set_init.html - !! +!> \section arg_table_temp_set_init Argument Table +!! \htmlinclude arg_table_temp_set_init.html +!! subroutine temp_set_init(temp_inc_in, fudge, temp_inc_set, errmsg, errflg) - real(kind=kind_phys), intent(in) :: temp_inc_in - real(kind=kind_phys), intent(in) :: fudge - real(kind=kind_phys), intent(out) :: temp_inc_set - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), intent(in) :: temp_inc_in + real(kind_phys), intent(in) :: fudge + real(kind_phys), intent(out) :: temp_inc_set + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg temp_inc_set = temp_inc_in @@ -76,17 +76,17 @@ subroutine temp_set_init(temp_inc_in, fudge, temp_inc_set, errmsg, errflg) end subroutine temp_set_init - !> \section arg_table_temp_set_timestep_initialize Argument Table - !! \htmlinclude arg_table_temp_set_timestep_initialize.html - !! - subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & - errmsg, errflg) +!> \section arg_table_temp_set_timestep_initialize Argument Table +!! \htmlinclude arg_table_temp_set_timestep_initialize.html +!! + subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & + errmsg, errflg) - integer, intent(in) :: ncol - real(kind=kind_phys), intent(in) :: temp_inc - real(kind=kind_phys), intent(inout) :: temp_level(:, :) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + real(kind_phys), intent(in) :: temp_inc + real(kind_phys), intent(inout) :: temp_level(:,:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 @@ -95,13 +95,13 @@ subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & end subroutine temp_set_timestep_initialize - !> \section arg_table_temp_set_finalize Argument Table - !! \htmlinclude arg_table_temp_set_finalize.html - !! +!> \section arg_table_temp_set_finalize Argument Table +!! \htmlinclude arg_table_temp_set_finalize.html +!! subroutine temp_set_finalize(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 diff --git a/test/ddthost_test/test_ddt_host_integration.F90 b/test/ddthost_test/test_ddt_host_integration.F90 index 3f383f0e..23a0e53c 100644 --- a/test/ddthost_test/test_ddt_host_integration.F90 +++ b/test/ddthost_test/test_ddt_host_integration.F90 @@ -1,82 +1,79 @@ 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(7) = (/ & - 'potential_temperature ', & - 'potential_temperature_at_interface ', & - 'coefficients_for_interpolation ', & - 'surface_air_pressure ', & - 'water_vapor_specific_humidity ', & - 'potential_temperature_increment ', & - 'time_step_for_physics ' /) - character(len=cm), target :: test_outvars1(7) = (/ & - 'potential_temperature ', & - 'potential_temperature_at_interface ', & - 'coefficients_for_interpolation ', & - 'surface_air_pressure ', & - 'water_vapor_specific_humidity ', & - 'ccpp_error_code ', & - 'ccpp_error_message ' /) - character(len=cm), target :: test_reqvars1(9) = (/ & - 'potential_temperature ', & - 'potential_temperature_at_interface ', & - 'coefficients_for_interpolation ', & - 'surface_air_pressure ', & - 'water_vapor_specific_humidity ', & - 'potential_temperature_increment ', & - 'time_step_for_physics ', & - 'ccpp_error_code ', & - 'ccpp_error_message ' /) + character(len=cs), target :: test_parts1(2) = (/ 'physics1 ', & + 'physics2 ' /) + character(len=cs), target :: test_parts2(1) = (/ 'data_prep ' /) + character(len=cm), target :: test_invars1(7) = (/ & + 'potential_temperature ', & + 'potential_temperature_at_interface ', & + 'coefficients_for_interpolation ', & + 'surface_air_pressure ', & + 'water_vapor_specific_humidity ', & + 'potential_temperature_increment ', & + 'time_step_for_physics ' /) + character(len=cm), target :: test_outvars1(7) = (/ & + 'potential_temperature ', & + 'potential_temperature_at_interface ', & + 'coefficients_for_interpolation ', & + 'surface_air_pressure ', & + 'water_vapor_specific_humidity ', & + 'ccpp_error_code ', & + 'ccpp_error_message ' /) + character(len=cm), target :: test_reqvars1(9) = (/ & + 'potential_temperature ', & + 'potential_temperature_at_interface ', & + 'coefficients_for_interpolation ', & + 'surface_air_pressure ', & + 'water_vapor_specific_humidity ', & + 'potential_temperature_increment ', & + 'time_step_for_physics ', & + 'ccpp_error_code ', & + 'ccpp_error_message ' /) - character(len=cm), target :: test_invars2(4) = (/ & - 'model_times ', & - 'number_of_model_times ', & - 'surface_air_pressure ', & - 'host_standard_ccpp_type ' /) + character(len=cm), target :: test_invars2(4) = (/ & + 'model_times ', & + 'number_of_model_times ', & + 'surface_air_pressure ', & + 'host_standard_ccpp_type ' /) - 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(6) = (/ & - 'model_times ', & - 'number_of_model_times ', & - 'surface_air_pressure ', & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'host_standard_ccpp_type ' /) - type(suite_info) :: test_suites(2) - logical :: run_okay + character(len=cm), target :: test_reqvars2(6) = (/ & + 'model_times ', & + 'number_of_model_times ', & + 'surface_air_pressure ', & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'host_standard_ccpp_type ' /) + 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/ddthost_test/test_host.F90 b/test/ddthost_test/test_host.F90 index 097567ac..c8213e20 100644 --- a/test/ddthost_test/test_host.F90 +++ b/test/ddthost_test/test_host.F90 @@ -1,273 +1,271 @@ 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 - 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) - use host_ccpp_ddt, only: ccpp_info_t - use test_host_mod, only: ncols, & - num_time_steps - 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 + !> \section arg_table_test_host Argument Table + !! \htmlinclude arg_table_test_host.html + !! + subroutine test_host(retval, test_suites) - type(suite_info), intent(in) :: test_suites(:) - logical, intent(out) :: retval + use host_ccpp_ddt, only: ccpp_info_t + use test_host_mod, only: ncols, num_time_steps + 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 - logical :: check - integer :: col_start - integer :: index, sind - integer :: time_step - integer :: num_suites - character(len=128), allocatable :: suite_names(:) - type(ccpp_info_t) :: ccpp_info + type(suite_info), intent(in) :: test_suites(:) + logical, intent(out) :: retval - ! Initialize our 'data' - call init_data() + logical :: check + integer :: col_start + integer :: index, sind + integer :: time_step + integer :: num_suites + character(len=128), allocatable :: suite_names(:) + type(ccpp_info_t) :: ccpp_info - ! 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 + ! Initialize our 'data' + call init_data() - ! Use the suite information to setup the run - do sind = 1, num_suites - call test_host_ccpp_physics_initialize(test_suites(sind)%suite_name, & - ccpp_info) - if (ccpp_info%errflg /= 0) then - write(6, '(4a)') 'ERROR in initialize of ', & - trim(test_suites(sind)%suite_name), ': ', trim(ccpp_info%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 (ccpp_info%errflg /= 0) then - exit - end if - if (ccpp_info%errflg == 0) then - call test_host_ccpp_physics_timestep_initial( & - test_suites(sind)%suite_name, ccpp_info) - end if - if (ccpp_info%errflg /= 0) then - write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(ccpp_info%errmsg) - exit - end if - if (ccpp_info%errflg /= 0) then - exit - end if - end do - - do col_start = 1, ncols, 5 - if (ccpp_info%errflg /= 0) then - exit - end if - ccpp_info%col_start = col_start - ccpp_info%col_end = min(col_start + 4, ncols) + ! 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 - do sind = 1, num_suites + ! Use the suite information to setup the run + do sind = 1, num_suites + call test_host_ccpp_physics_initialize(test_suites(sind)%suite_name, & + ccpp_info) if (ccpp_info%errflg /= 0) then - exit + write(6, '(4a)') 'ERROR in initialize of ', & + trim(test_suites(sind)%suite_name), ': ', trim(ccpp_info%errmsg) end if - do index = 1, size(test_suites(sind)%suite_parts) - if (ccpp_info%errflg /= 0) then - exit - end if - if (ccpp_info%errflg == 0) then - call test_host_ccpp_physics_run( & - test_suites(sind)%suite_name, & - test_suites(sind)%suite_parts(index), & - ccpp_info) - end if - if (ccpp_info%errflg /= 0) then - write(6, '(5a)') trim(test_suites(sind)%suite_name), & - '/', trim(test_suites(sind)%suite_parts(index)), & - ': ', trim(ccpp_info%errmsg) - exit - end if + end do + ! Loop over time steps + do time_step = 1, num_time_steps + ! Initialize the timestep + do sind = 1, num_suites + if (ccpp_info%errflg /= 0) then + exit + end if + if (ccpp_info%errflg == 0) then + call test_host_ccpp_physics_timestep_initial( & + test_suites(sind)%suite_name, ccpp_info) + end if + if (ccpp_info%errflg /= 0) then + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(ccpp_info%errmsg) + exit + end if + if (ccpp_info%errflg /= 0) then + exit + end if end do - end do - end do - do sind = 1, num_suites - if (ccpp_info%errflg /= 0) then - exit - end if - if (ccpp_info%errflg == 0) then - call test_host_ccpp_physics_timestep_final( & - test_suites(sind)%suite_name, ccpp_info) - end if - if (ccpp_info%errflg /= 0) then - write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(ccpp_info%errmsg) - exit - end if - end do - end do ! End time step loop + do col_start = 1, ncols, 5 + if (ccpp_info%errflg /= 0) then + exit + end if + ccpp_info%col_start = col_start + ccpp_info%col_end = MIN(col_start + 4, ncols) - do sind = 1, num_suites - if (ccpp_info%errflg /= 0) then - exit - end if - if (ccpp_info%errflg == 0) then - call test_host_ccpp_physics_finalize( & - test_suites(sind)%suite_name, ccpp_info) - end if - if (ccpp_info%errflg /= 0) then - write(6, '(3a)') test_suites(sind)%suite_parts(index), ': ', & - trim(ccpp_info%errmsg) - write(6, '(2a)') 'An error occurred in ccpp_timestep_final, ', & - 'Exiting...' - exit - end if - end do + do sind = 1, num_suites + if (ccpp_info%errflg /= 0) then + exit + end if + do index = 1, size(test_suites(sind)%suite_parts) + if (ccpp_info%errflg /= 0) then + exit + end if + if (ccpp_info%errflg == 0) then + call test_host_ccpp_physics_run( & + test_suites(sind)%suite_name, & + test_suites(sind)%suite_parts(index), & + ccpp_info) + end if + if (ccpp_info%errflg /= 0) then + write(6, '(5a)') trim(test_suites(sind)%suite_name), & + '/', trim(test_suites(sind)%suite_parts(index)), & + ': ', trim(ccpp_info%errmsg) + exit + end if + end do + end do + end do - if (ccpp_info%errflg == 0) then - ! Run finished without error, check answers - if ( .not. check_model_times()) then - write(6, *) 'Model times error!' - ccpp_info%errflg = -1 - else if (compare_data()) then - write(6, *) 'Answers are correct!' - ccpp_info%errflg = 0 - else - write(6, *) 'Answers are not correct!' - ccpp_info%errflg = -1 - end if - end if + do sind = 1, num_suites + if (ccpp_info%errflg /= 0) then + exit + end if + if (ccpp_info%errflg == 0) then + call test_host_ccpp_physics_timestep_final( & + test_suites(sind)%suite_name, ccpp_info) + end if + if (ccpp_info%errflg /= 0) then + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(ccpp_info%errmsg) + exit + end if + end do + end do ! End time step loop + + do sind = 1, num_suites + if (ccpp_info%errflg /= 0) then + exit + end if + if (ccpp_info%errflg == 0) then + call test_host_ccpp_physics_finalize( & + test_suites(sind)%suite_name,ccpp_info) + end if + if (ccpp_info%errflg /= 0) then + write(6, '(3a)') test_suites(sind)%suite_parts(index), ': ', & + trim(ccpp_info%errmsg) + write(6,'(2a)') 'An error occurred in ccpp_timestep_final, ', & + 'Exiting...' + exit + end if + end do + + if (ccpp_info%errflg == 0) then + ! Run finished without error, check answers + if (.not. check_model_times()) then + write(6, *) 'Model times error!' + ccpp_info%errflg = -1 + else if (compare_data()) then + write(6, *) 'Answers are correct!' + ccpp_info%errflg = 0 + else + write(6, *) 'Answers are not correct!' + ccpp_info%errflg = -1 + end if + end if - retval = ccpp_info%errflg == 0 + retval = ccpp_info%errflg == 0 - end subroutine test_host + end subroutine test_host -end module test_prog + end module test_prog diff --git a/test/ddthost_test/test_host_data.F90 b/test/ddthost_test/test_host_data.F90 index 88812719..7a651fca 100644 --- a/test/ddthost_test/test_host_data.F90 +++ b/test/ddthost_test/test_host_data.F90 @@ -5,15 +5,15 @@ module test_host_data !> \section arg_table_physics_state Argument Table !! \htmlinclude arg_table_physics_state.html type physics_state - real(kind=kind_phys), dimension(:), allocatable :: & - ps ! surface pressure - 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) + real(kind_phys), dimension(:), allocatable :: & + ps ! surface pressure + 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) end type physics_state public allocate_physics_state @@ -21,29 +21,29 @@ module test_host_data contains subroutine allocate_physics_state(cols, levels, constituents, state) - integer, intent(in) :: cols - integer, intent(in) :: levels - integer, intent(in) :: constituents + integer, intent(in) :: cols + integer, intent(in) :: levels + integer, intent(in) :: constituents 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)) diff --git a/test/ddthost_test/test_host_mod.F90 b/test/ddthost_test/test_host_mod.F90 index 1387a0c4..43be333a 100644 --- a/test/ddthost_test/test_host_mod.F90 +++ b/test/ddthost_test/test_host_mod.F90 @@ -1,40 +1,39 @@ 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 :: diagdimstart = 2 - integer, parameter :: index_qv = 1 - real(kind=kind_phys), allocatable :: temp_midpoints(:, :) - real(kind=kind_phys) :: temp_interfaces(ncols, pverp) - real(kind=kind_phys) :: coeffs(ncols) - 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 + 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 :: DiagDimStart = 2 + integer, parameter :: index_qv = 1 + real(kind_phys), allocatable :: temp_midpoints(:,:) + real(kind_phys) :: temp_interfaces(ncols, pverP) + real(kind_phys) :: coeffs(ncols) + 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 contains @@ -48,22 +47,22 @@ 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 + 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, 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 @@ -72,68 +71,68 @@ 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=kind_phys) :: avg + integer :: col + integer :: lev + integer :: cind + integer :: offsize + logical :: need_header + real(kind_phys) :: avg integer, parameter :: cincrements(pcnst) = (/ 1, 0 /) compare_data = .true. 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. + 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. end if - write(6, '(2i5,2(3x,es15.7))') col, lev, & - temp_midpoints(col, lev), avg - compare_data = .false. - end if - end do + 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) + 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 end function compare_data diff --git a/test/hash_table_tests/test_hash.F90 b/test/hash_table_tests/test_hash.F90 index 56686ce4..35536cdd 100644 --- a/test/hash_table_tests/test_hash.F90 +++ b/test/hash_table_tests/test_hash.F90 @@ -1,218 +1,215 @@ module test_hash_utils - use ccpp_hashable, only: ccpp_hashable_char_t - - implicit none - private - - public :: test_table - - integer, parameter, public :: max_terrs = 16 - - type, public :: hash_object_t - type(ccpp_hashable_char_t), pointer :: item => null() - end type hash_object_t - - private add_error - -contains - - subroutine add_error(msg, num_errs, errors) - ! Dummy arguments - character(len=*), intent(in) :: msg - integer, intent(inout) :: num_errs - character(len=*), intent(inout) :: errors(:) - - if (num_errs < max_terrs) then - num_errs = num_errs + 1 - write(errors(num_errs), *) trim(msg) - end if - - end subroutine add_error - - subroutine test_table(hash_table, table_size, num_tests, num_errs, errors) - use ccpp_hash_table, only: ccpp_hash_table_t, & - ccpp_hash_iterator_t - use ccpp_hashable, only: ccpp_hashable_t, & - new_hashable_char - - ! Dummy arguments - type(ccpp_hash_table_t), target, intent(inout) :: hash_table - integer, intent(in) :: table_size - integer, intent(out) :: num_tests - integer, intent(out) :: num_errs - character(len=*), intent(inout) :: errors(:) - ! Local variables - integer, parameter :: num_test_entries = 4 - integer, parameter :: key_len = 10 - character(len=key_len) :: hash_names(num_test_entries) = (/ & - 'foo ', 'bar ', 'foobar ', 'big daddy ' /) - logical :: hash_found(num_test_entries) - - type(hash_object_t) :: hash_chars(num_test_entries) - class(ccpp_hashable_t), pointer :: test_ptr => null() - type(ccpp_hash_iterator_t) :: hash_iter - character(len=key_len) :: test_key - character(len=len(errors(1))) :: errmsg - integer :: index - - write(6, '(a,i0)') "Testing hash table, size = ", table_size - num_tests = 0 - num_errs = 0 - ! Make sure hash table is *not* initialized - if (hash_table%is_initialized()) then - call add_error("Error: hash table initialized too early", & - num_errs, errors) - end if - num_tests = num_tests + 1 - ! Initialize hash table - call hash_table%initialize(table_size) - ! Make sure hash table is *is* initialized - if ( .not. hash_table%is_initialized()) then - call add_error("Error: hash table *not* initialized", num_errs, errors) - end if - num_tests = num_tests + 1 - do index = 1, num_test_entries - call new_hashable_char(hash_names(index), hash_chars(index)%item) - call hash_table%add_hash_key(hash_chars(index)%item, & - errmsg=errors(num_errs + 1)) - if (len_trim(errors(num_errs + 1)) > 0) then - num_errs = num_errs + 1 - end if - if (num_errs > max_terrs) then - exit + use ccpp_hashable, only: ccpp_hashable_char_t + + implicit none + private + + public :: test_table + + integer, parameter, public :: max_terrs = 16 + + type, public :: hash_object_t + type(ccpp_hashable_char_t), pointer :: item => NULL() + end type hash_object_t + + private add_error + +CONTAINS + + subroutine add_error(msg, num_errs, errors) + ! Dummy arguments + character(len=*), intent(in) :: msg + integer, intent(inout) :: num_errs + character(len=*), intent(inout) :: errors(:) + + if (num_errs < max_terrs) then + num_errs = num_errs + 1 + write(errors(num_errs), *) trim(msg) end if - end do - if (num_errs == 0) then - ! We have populated the table, let's do some tests - ! First, make sure we can find existing entries - do index = 1, num_test_entries - test_ptr => hash_table%table_value(hash_names(index), & - errmsg=errors(num_errs + 1)) - if (len_trim(errors(num_errs + 1)) > 0) then - num_errs = num_errs + 1 - else if (trim(test_ptr%key()) /= trim(hash_names(index))) then - num_errs = num_errs + 1 - write(errmsg, *) "ERROR: Found '", trim(test_ptr%key()), & - "', expected '", trim(hash_names(index)), "'" - call add_error(trim(errmsg), num_errs, errors) - end if - if (num_errs > max_terrs) then - exit - end if - end do - num_tests = num_tests + 1 - ! Next, make sure we do not find a non-existent entry - test_ptr => hash_table%table_value(trim(hash_names(1)) // '_oops', & - errmsg=errors(num_errs + 1)) - if (len_trim(errors(num_errs + 1)) == 0) then - write(errmsg, *) "ERROR: Found an entry for '", & - trim(hash_names(1)) // '_oops', "'" - call add_error(trim(errmsg), num_errs, errors) + end subroutine add_error + + subroutine test_table(hash_table, table_size, num_tests, num_errs, errors) + use ccpp_hash_table, only: ccpp_hash_table_t, ccpp_hash_iterator_t + use ccpp_hashable, only: ccpp_hashable_t, new_hashable_char + + ! Dummy arguments + type(ccpp_hash_table_t), target, intent(inout) :: hash_table + integer, intent(in) :: table_size + integer, intent(out) :: num_tests + integer, intent(out) :: num_errs + character(len=*), intent(inout) :: errors(:) + ! Local variables + integer, parameter :: num_test_entries = 4 + integer, parameter :: key_len = 10 + character(len=key_len) :: hash_names(num_test_entries) = (/ & + 'foo ', 'bar ', 'foobar ', 'big daddy ' /) + logical :: hash_found(num_test_entries) + + type(hash_object_t) :: hash_chars(num_test_entries) + class(ccpp_hashable_t), pointer :: test_ptr => NULL() + type(ccpp_hash_iterator_t) :: hash_iter + character(len=key_len) :: test_key + character(len=len(errors(1))) :: errmsg + integer :: index + + write(6, '(a,i0)') "Testing hash table, size = ", table_size + num_tests = 0 + num_errs = 0 + ! Make sure hash table is *not* initialized + if (hash_table%is_initialized()) then + call add_error("Error: hash table initialized too early", & + num_errs, errors) end if num_tests = num_tests + 1 - ! Make sure we get an error if we try to add a duplicate key - call hash_table%add_hash_key(hash_chars(2)%item, & - errmsg=errors(num_errs + 1)) - if (len_trim(errors(num_errs + 1)) == 0) then - num_errs = num_errs + 1 - write(errors(num_errs), *) & - "ERROR: Allowed duplicate entry for '", & - hash_chars(2)%item%key(), "'" + ! Initialize hash table + call hash_table%initialize(table_size) + ! Make sure hash table is *is* initialized + if (.not. hash_table%is_initialized()) then + call add_error("Error: hash table *not* initialized", num_errs, errors) end if num_tests = num_tests + 1 - ! Check that the total number of table entries is correct - if (hash_table%num_values() /= num_test_entries) then - write(errmsg, '(2(a,i0))') "ERROR: Wrong table value count, ", & - hash_table%num_values(), ', should be ', num_test_entries - call add_error(errmsg, num_errs, errors) + do index = 1, num_test_entries + call new_hashable_char(hash_names(index), hash_chars(index)%item) + call hash_table%add_hash_key(hash_chars(index)%item, & + errmsg=errors(num_errs + 1)) + if (len_trim(errors(num_errs + 1)) > 0) then + num_errs = num_errs + 1 + end if + if (num_errs > max_terrs) then + exit + end if + end do + + if (num_errs == 0) then + ! We have populated the table, let's do some tests + ! First, make sure we can find existing entries + do index = 1, num_test_entries + test_ptr => hash_table%table_value(hash_names(index), & + errmsg=errors(num_errs + 1)) + if (len_trim(errors(num_errs + 1)) > 0) then + num_errs = num_errs + 1 + else if (trim(test_ptr%key()) /= trim(hash_names(index))) then + num_errs = num_errs + 1 + write(errmsg, *) "ERROR: Found '", trim(test_ptr%key()), & + "', expected '", trim(hash_names(index)), "'" + call add_error(trim(errmsg), num_errs, errors) + end if + if (num_errs > max_terrs) then + exit + end if + end do + num_tests = num_tests + 1 + ! Next, make sure we do not find a non-existent entry + test_ptr => hash_table%table_value(trim(hash_names(1))//'_oops', & + errmsg=errors(num_errs + 1)) + if (len_trim(errors(num_errs + 1)) == 0) then + write(errmsg, *) "ERROR: Found an entry for '", & + trim(hash_names(1))//'_oops', "'" + call add_error(trim(errmsg), num_errs, errors) + end if + num_tests = num_tests + 1 + ! Make sure we get an error if we try to add a duplicate key + call hash_table%add_hash_key(hash_chars(2)%item, & + errmsg=errors(num_errs + 1)) + if (len_trim(errors(num_errs + 1)) == 0) then + num_errs = num_errs + 1 + write(errors(num_errs), *) & + "ERROR: Allowed duplicate entry for '", & + hash_chars(2)%item%key(), "'" + end if + num_tests = num_tests + 1 + ! Check that the total number of table entries is correct + if (hash_table%num_values() /= num_test_entries) then + write(errmsg, '(2(a,i0))') "ERROR: Wrong table value count, ", & + hash_table%num_values(), ', should be ', num_test_entries + call add_error(errmsg, num_errs, errors) + end if + num_tests = num_tests + 1 + ! Test iteration through hash table + hash_found(:) = .false. + call hash_iter%initialize(hash_table) + num_tests = num_tests + 1 + do + if (hash_iter%valid()) then + test_key = hash_iter%key() + index = 1 + do + if (trim(test_key) == trim(hash_names(index))) then + hash_found(index) = .true. + exit + else if (index >= num_test_entries) then + write(errmsg, '(3a)') & + "ERROR: Unexpected table entry, '", & + trim(test_key), "'" + call add_error(errmsg, num_errs, errors) + end if + index = index + 1 + end do + call hash_iter%next() + else + exit + end if + end do + call hash_iter%finalize() + if (ANY(.not. hash_found)) then + write(errmsg, '(a,i0,a)') "ERROR: ", & + COUNT(.not. hash_found), " test keys not found in table." + call add_error(errmsg, num_errs, errors) + end if + end if + ! Finally, clear the hash table (should deallocate everything) + call hash_table%clear() + ! Make sure hash table is *not* initialized + if (hash_table%is_initialized()) then + call add_error("Error: hash table initialized after clear", & + num_errs, errors) end if num_tests = num_tests + 1 - ! Test iteration through hash table - hash_found(:) = .false. - call hash_iter%initialize(hash_table) - num_tests = num_tests + 1 - do - if (hash_iter%valid()) then - test_key = hash_iter%key() - index = 1 - do - if (trim(test_key) == trim(hash_names(index))) then - hash_found(index) = .true. - exit - else if (index >= num_test_entries) then - write(errmsg, '(3a)') & - "ERROR: Unexpected table entry, '", & - trim(test_key), "'" - call add_error(errmsg, num_errs, errors) - end if - index = index + 1 - end do - call hash_iter%next() - else - exit - end if + ! Cleanup + do index = 1, num_test_entries + deallocate(hash_chars(index)%item) end do - call hash_iter%finalize() - if (any( .not. hash_found)) then - write(errmsg, '(a,i0,a)') "ERROR: ", & - count( .not. hash_found), " test keys not found in table." - call add_error(errmsg, num_errs, errors) - end if - end if - ! Finally, clear the hash table (should deallocate everything) - call hash_table%clear() - ! Make sure hash table is *not* initialized - if (hash_table%is_initialized()) then - call add_error("Error: hash table initialized after clear", & - num_errs, errors) - end if - num_tests = num_tests + 1 - ! Cleanup - do index = 1, num_test_entries - deallocate(hash_chars(index)%item) - end do - - end subroutine test_table + + end subroutine test_table end module test_hash_utils program test_hash - use ccpp_hash_table, only: ccpp_hash_table_t - use test_hash_utils, only: test_table, & - max_terrs - - integer, parameter :: num_table_sizes = 5 - integer, parameter :: max_errs = max_terrs * num_table_sizes - integer, parameter :: err_size = 128 - integer, parameter :: test_sizes(num_table_sizes) = (/ & - 0, 1, 2, 4, 20 /) - - type(ccpp_hash_table_t), target :: hash_table - integer :: index - integer :: errcnt = 0 - integer :: num_tests = 0 - integer :: total_errcnt = 0 - integer :: total_tests = 0 - character(len=err_size) :: errors(max_errs) - - errors = '' - do index = 1, num_table_sizes - call test_table(hash_table, test_sizes(index), num_tests, errcnt, & - errors(total_errcnt + 1:)) - total_tests = total_tests + num_tests - total_errcnt = total_errcnt + errcnt - end do - - if (total_errcnt > 0) then - write(6, '(a,i0,a)') 'FAIL, ', total_errcnt, ' errors found' - do index = 1, total_errcnt - write(6, *) trim(errors(index)) - end do - stop 1 - else - write(6, '(a,i0,a)') "All ", total_tests, " hash table tests passed!" - stop 0 - end if + use ccpp_hash_table, only: ccpp_hash_table_t + use test_hash_utils, only: test_table, max_terrs + + integer, parameter :: num_table_sizes = 5 + integer, parameter :: max_errs = max_terrs * num_table_sizes + integer, parameter :: err_size = 128 + integer, parameter :: test_sizes(num_table_sizes) = (/ & + 0, 1, 2, 4, 20 /) + + type(ccpp_hash_table_t), target :: hash_table + integer :: index + integer :: errcnt = 0 + integer :: num_tests = 0 + integer :: total_errcnt = 0 + integer :: total_tests = 0 + character(len=err_size) :: errors(max_errs) + + errors = '' + do index = 1, num_table_sizes + call test_table(hash_table, test_sizes(index), num_tests, errcnt, & + errors(total_errcnt+1:)) + total_tests = total_tests + num_tests + total_errcnt = total_errcnt + errcnt + end do + + if (total_errcnt > 0) then + write(6, '(a,i0,a)') 'FAIL, ', total_errcnt, ' errors found' + do index = 1, total_errcnt + write(6, *) trim(errors(index)) + end do + STOP 1 + else + write(6, '(a,i0,a)') "All ", total_tests, " hash table tests passed!" + STOP 0 + end if end program test_hash diff --git a/test/nested_suite_test/ccpp_kinds.F90 b/test/nested_suite_test/ccpp_kinds.F90 index 2eed03c9..b2923935 100644 --- a/test/nested_suite_test/ccpp_kinds.F90 +++ b/test/nested_suite_test/ccpp_kinds.F90 @@ -10,18 +10,18 @@ ! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + !> !! @brief Auto-generated kinds for CCPP !! ! module ccpp_kinds - use iso_fortran_env, only: & - kind_phys => real64 + use ISO_FORTRAN_ENV, only: kind_phys => REAL64 - implicit none - private + implicit none + private - public :: kind_phys + public :: kind_phys end module ccpp_kinds diff --git a/test/nested_suite_test/effr_calc.F90 b/test/nested_suite_test/effr_calc.F90 index b8fc43ed..0b626c16 100644 --- a/test/nested_suite_test/effr_calc.F90 +++ b/test/nested_suite_test/effr_calc.F90 @@ -3,82 +3,82 @@ module effr_calc - use ccpp_kinds, only: kind_phys - - implicit none - private - - public :: effr_calc_run, effr_calc_init - -contains - !> \section arg_table_effr_calc_init Argument Table - !! \htmlinclude arg_table_effr_calc_init.html - !! - subroutine effr_calc_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order /= 2) then - errflg = 1 - errmsg = 'ERROR: effr_calc_init() needs to be called second' - return - else - scheme_order = scheme_order + 1 - end if - - end subroutine effr_calc_init - - !> \section arg_table_effr_calc_run Argument Table - !! \htmlinclude arg_table_effr_calc_run.html - !! - subroutine effr_calc_run(ncol, nlev, effrr_in, effrg_in, ncg_in, nci_out, & - effrl_inout, effri_out, effrs_inout, ncl_out, & - has_graupel, scalar_var, tke_inout, tke2_inout, & - errmsg, errflg) - - integer, intent(in) :: ncol - integer, intent(in) :: nlev - real(kind=kind_phys), intent(in) :: effrr_in(:, :) - real(kind=kind_phys), intent(in), optional :: effrg_in(:, :) - real(kind=kind_phys), intent(in), optional :: ncg_in(:, :) - real(kind=kind_phys), intent(out), optional :: nci_out(:, :) - real(kind=kind_phys), intent(inout) :: effrl_inout(:, :) - real(kind=kind_phys), intent(out), optional :: effri_out(:, :) - real(kind=8), intent(inout) :: effrs_inout(:, :) - logical, intent(in) :: has_graupel - real(kind=kind_phys), intent(inout) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - real(kind=kind_phys), intent(out), optional :: ncl_out(:, :) - real(kind=kind_phys), intent(inout) :: tke_inout - real(kind=kind_phys), intent(inout) :: tke2_inout - - !---------------------------------------------------------------- - - real(kind=kind_phys), parameter :: re_qc_min = 2.5 ! microns - real(kind=kind_phys), parameter :: re_qc_max = 50. ! microns - real(kind=kind_phys), parameter :: re_qi_avg = 75. ! microns - real(kind=kind_phys) :: effrr_local(ncol, nlev) - real(kind=kind_phys) :: effrg_local(ncol, nlev) - real(kind=kind_phys) :: ncg_in_local(ncol, nlev) - real(kind=kind_phys) :: nci_out_local(ncol, nlev) - - errmsg = '' - errflg = 0 - - effrr_local = effrr_in - if (present(effrg_in)) effrg_local = effrg_in - if (present(ncg_in)) ncg_in_local = ncg_in - if (present(nci_out)) nci_out_local = nci_out - effrl_inout = min(max(effrl_inout, re_qc_min), re_qc_max) - if (present(effri_out)) effri_out = re_qi_avg - effrs_inout = effrs_inout + (10.0 / 6.0) ! in micrometer - scalar_var = 2.0 ! in km - - end subroutine effr_calc_run + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: effr_calc_run, effr_calc_init + + contains + !> \section arg_table_effr_calc_init Argument Table + !! \htmlinclude arg_table_effr_calc_init.html + !! + subroutine effr_calc_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order .ne. 2) then + errflg = 1 + errmsg = 'ERROR: effr_calc_init() needs to be called second' + return + else + scheme_order = scheme_order + 1 + endif + + end subroutine effr_calc_init + + !> \section arg_table_effr_calc_run Argument Table + !! \htmlinclude arg_table_effr_calc_run.html + !! + subroutine effr_calc_run(ncol, nlev, effrr_in, effrg_in, ncg_in, nci_out, & + effrl_inout, effri_out, effrs_inout, ncl_out, & + has_graupel, scalar_var, tke_inout, tke2_inout, & + errmsg, errflg) + + integer, intent(in) :: ncol + integer, intent(in) :: nlev + real(kind_phys), intent(in) :: effrr_in(:,:) + real(kind_phys), intent(in),optional :: effrg_in(:,:) + real(kind_phys), intent(in),optional :: ncg_in(:,:) + real(kind_phys), intent(out),optional :: nci_out(:,:) + real(kind_phys), intent(inout) :: effrl_inout(:,:) + real(kind_phys), intent(out),optional :: effri_out(:,:) + real(8),intent(inout) :: effrs_inout(:,:) + logical, intent(in) :: has_graupel + real(kind_phys), intent(inout) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind_phys), intent(out),optional :: ncl_out(:,:) + real(kind_phys), intent(inout) :: tke_inout + real(kind_phys), intent(inout) :: tke2_inout + + !---------------------------------------------------------------- + + real(kind_phys), parameter :: re_qc_min = 2.5 ! microns + real(kind_phys), parameter :: re_qc_max = 50. ! microns + real(kind_phys), parameter :: re_qi_avg = 75. ! microns + real(kind_phys) :: effrr_local(ncol,nlev) + real(kind_phys) :: effrg_local(ncol,nlev) + real(kind_phys) :: ncg_in_local(ncol,nlev) + real(kind_phys) :: nci_out_local(ncol,nlev) + + errmsg = '' + errflg = 0 + + effrr_local = effrr_in + if (present(effrg_in)) effrg_local = effrg_in + if (present(ncg_in)) ncg_in_local = ncg_in + if (present(nci_out)) nci_out_local = nci_out + effrl_inout = min(max(effrl_inout,re_qc_min),re_qc_max) + if (present(effri_out)) effri_out = re_qi_avg + effrs_inout = effrs_inout + (10.0 / 6.0) ! in micrometer + scalar_var = 2.0 ! in km + + end subroutine effr_calc_run end module effr_calc diff --git a/test/nested_suite_test/effr_diag.F90 b/test/nested_suite_test/effr_diag.F90 index 75da29c7..409ff2f9 100644 --- a/test/nested_suite_test/effr_diag.F90 +++ b/test/nested_suite_test/effr_diag.F90 @@ -3,12 +3,12 @@ module effr_diag - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_diag_run, effr_diag_init + public :: effr_diag_run, effr_diag_init contains @@ -16,53 +16,53 @@ module effr_diag !! \htmlinclude arg_table_effr_diag_init.html !! subroutine effr_diag_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + errmsg = '' errflg = 0 - if (scheme_order /= 4) then - errflg = 1 - errmsg = 'ERROR: effr_diag_init() needs to be called fourth' - return - else - scheme_order = scheme_order + 1 - end if + if (scheme_order .ne. 4) then + errflg = 1 + errmsg = 'ERROR: effr_diag_init() needs to be called fourth' + return + else + scheme_order = scheme_order + 1 + endif end subroutine effr_diag_init - !> \section arg_table_effr_diag_run Argument Table - !! \htmlinclude arg_table_effr_diag_run.html - !! - subroutine effr_diag_run(effrr_in, scalar_var, errmsg, errflg) - - real(kind=kind_phys), intent(in) :: effrr_in(:, :) - integer, intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind=kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - call cmp_effr_diag(effrr_in, effrr_min, effrr_max) - - if (scalar_var /= 380) then - errmsg = 'ERROR: effr_diag_run(): scalar_var should be 380' - errflg = 1 - end if - end subroutine effr_diag_run - - subroutine cmp_effr_diag(effr, effr_min, effr_max) - real(kind=kind_phys), intent(in) :: effr(:, :) - real(kind=kind_phys), intent(out) :: effr_min, effr_max - - ! Do some diagnostic calcualtions... - effr_min = minval(effr) - effr_max = maxval(effr) - - end subroutine cmp_effr_diag + !> \section arg_table_effr_diag_run Argument Table + !! \htmlinclude arg_table_effr_diag_run.html + !! + subroutine effr_diag_run( effrr_in, scalar_var, errmsg, errflg) + + real(kind_phys), intent(in) :: effrr_in(:,:) + integer, intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + call cmp_effr_diag(effrr_in, effrr_min, effrr_max) + + if (scalar_var .ne. 380) then + errmsg = 'ERROR: effr_diag_run(): scalar_var should be 380' + errflg = 1 + endif + end subroutine effr_diag_run + + subroutine cmp_effr_diag(effr, effr_min, effr_max) + real(kind_phys), intent(in) :: effr(:,:) + real(kind_phys), intent(out) :: effr_min, effr_max + + ! Do some diagnostic calcualtions... + effr_min = minval(effr) + effr_max = maxval(effr) + + end subroutine cmp_effr_diag end module effr_diag diff --git a/test/nested_suite_test/effr_post.F90 b/test/nested_suite_test/effr_post.F90 index 01357350..d42a574c 100644 --- a/test/nested_suite_test/effr_post.F90 +++ b/test/nested_suite_test/effr_post.F90 @@ -3,59 +3,59 @@ module effr_post - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_post_run, effr_post_init + public :: effr_post_run, effr_post_init contains - !> \section arg_table_effr_post_init Argument Table - !! \htmlinclude arg_table_effr_post_init.html - !! - subroutine effr_post_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order /= 3) then - errflg = 1 - errmsg = 'ERROR: effr_post_init() needs to be called third' - return - else - scheme_order = scheme_order + 1 - end if - - end subroutine effr_post_init - - !> \section arg_table_effr_post_run Argument Table - !! \htmlinclude arg_table_effr_post_run.html - !! - subroutine effr_post_run(effrr_inout, scalar_var, errmsg, errflg) - - real(kind=kind_phys), intent(inout) :: effrr_inout(:, :) - real(kind=kind_phys), intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind=kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - ! Do some post-processing on effrr... - effrr_inout(:, :) = effrr_inout(:, :) * 1._kind_phys - - if (scalar_var /= 1013.0) then - errmsg = 'ERROR: effr_post_run(): scalar_var should be 1013.0' - errflg = 1 - end if - - end subroutine effr_post_run - -end module effr_post + !> \section arg_table_effr_post_init Argument Table + !! \htmlinclude arg_table_effr_post_init.html + !! + subroutine effr_post_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order .ne. 3) then + errflg = 1 + errmsg = 'ERROR: effr_post_init() needs to be called third' + return + else + scheme_order = scheme_order + 1 + endif + + end subroutine effr_post_init + + !> \section arg_table_effr_post_run Argument Table + !! \htmlinclude arg_table_effr_post_run.html + !! + subroutine effr_post_run( effrr_inout, scalar_var, errmsg, errflg) + + real(kind_phys), intent(inout) :: effrr_inout(:,:) + real(kind_phys), intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + ! Do some post-processing on effrr... + effrr_inout(:,:) = effrr_inout(:,:)*1._kind_phys + + if (scalar_var .ne. 1013.0) then + errmsg = 'ERROR: effr_post_run(): scalar_var should be 1013.0' + errflg = 1 + endif + + end subroutine effr_post_run + + end module effr_post diff --git a/test/nested_suite_test/effr_pre.F90 b/test/nested_suite_test/effr_pre.F90 index a2fe2f5c..17a3b187 100644 --- a/test/nested_suite_test/effr_pre.F90 +++ b/test/nested_suite_test/effr_pre.F90 @@ -3,58 +3,58 @@ module mod_effr_pre - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_pre_run, effr_pre_init + public :: effr_pre_run, effr_pre_init contains - !> \section arg_table_effr_pre_init Argument Table - !! \htmlinclude arg_table_effr_pre_init.html - !! - subroutine effr_pre_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order /= 1) then - errflg = 1 - errmsg = 'ERROR: effr_pre_init() needs to be called first' - return - else - scheme_order = scheme_order + 1 - end if - - end subroutine effr_pre_init - - !> \section arg_table_effr_pre_run Argument Table - !! \htmlinclude arg_table_effr_pre_run.html - !! - subroutine effr_pre_run(effrr_inout, scalar_var, errmsg, errflg) - - real(kind=kind_phys), intent(inout) :: effrr_inout(:, :) - real(kind=kind_phys), intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind=kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - ! Do some pre-processing on effrr... - effrr_inout(:, :) = effrr_inout(:, :) * 1._kind_phys - - if (scalar_var /= 273.15) then - errmsg = 'ERROR: effr_pre_run(): scalar_var should be 273.15' - errflg = 1 - end if - - end subroutine effr_pre_run + !> \section arg_table_effr_pre_init Argument Table + !! \htmlinclude arg_table_effr_pre_init.html + !! + subroutine effr_pre_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order .ne. 1) then + errflg = 1 + errmsg = 'ERROR: effr_pre_init() needs to be called first' + return + else + scheme_order = scheme_order + 1 + endif + + end subroutine effr_pre_init + + !> \section arg_table_effr_pre_run Argument Table + !! \htmlinclude arg_table_effr_pre_run.html + !! + subroutine effr_pre_run( effrr_inout, scalar_var, errmsg, errflg) + + real(kind_phys), intent(inout) :: effrr_inout(:,:) + real(kind_phys), intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + ! Do some pre-processing on effrr... + effrr_inout(:,:) = effrr_inout(:,:)*1._kind_phys + + if (scalar_var .ne. 273.15) then + errmsg = 'ERROR: effr_pre_run(): scalar_var should be 273.15' + errflg = 1 + endif + + end subroutine effr_pre_run end module mod_effr_pre diff --git a/test/nested_suite_test/effrs_calc.F90 b/test/nested_suite_test/effrs_calc.F90 index 3aa8d196..e9266905 100644 --- a/test/nested_suite_test/effrs_calc.F90 +++ b/test/nested_suite_test/effrs_calc.F90 @@ -3,30 +3,30 @@ module effrs_calc - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effrs_calc_run + public :: effrs_calc_run -contains - !> \section arg_table_effrs_calc_run Argument Table - !! \htmlinclude arg_table_effrs_calc_run.html - !! - subroutine effrs_calc_run(effrs_inout, errmsg, errflg) + contains + !> \section arg_table_effrs_calc_run Argument Table + !! \htmlinclude arg_table_effrs_calc_run.html + !! + subroutine effrs_calc_run(effrs_inout, errmsg, errflg) - real(kind=kind_phys), intent(inout) :: effrs_inout(:, :) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), intent(inout) :: effrs_inout(:,:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - !---------------------------------------------------------------- + !---------------------------------------------------------------- - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 - effrs_inout = effrs_inout + (10.E-6_kind_phys / 3._kind_phys) ! in meters + effrs_inout = effrs_inout + (10.E-6_kind_phys / 3._kind_phys) ! in meters - end subroutine effrs_calc_run + end subroutine effrs_calc_run end module effrs_calc diff --git a/test/nested_suite_test/module_rad_ddt.F90 b/test/nested_suite_test/module_rad_ddt.F90 index 6e992250..21a1a0ec 100644 --- a/test/nested_suite_test/module_rad_ddt.F90 +++ b/test/nested_suite_test/module_rad_ddt.F90 @@ -1,5 +1,5 @@ module mod_rad_ddt - use ccpp_kinds, only: kind_phys + USE ccpp_kinds, ONLY: kind_phys implicit none public ty_rad_lw, ty_rad_sw @@ -8,16 +8,16 @@ module mod_rad_ddt !! \htmlinclude arg_table_ty_rad_lw.html !! type ty_rad_lw - real(kind=kind_phys) :: sfc_up_lw - real(kind=kind_phys) :: sfc_down_lw + real(kind_phys) :: sfc_up_lw + real(kind_phys) :: sfc_down_lw end type ty_rad_lw !> \section arg_table_ty_rad_sw Argument Table !! \htmlinclude arg_table_ty_rad_sw.html !! type ty_rad_sw - real(kind=kind_phys), pointer :: sfc_up_sw(:) => null() - real(kind=kind_phys), pointer :: sfc_down_sw(:) => null() + real(kind_phys), pointer :: sfc_up_sw(:) => null() + real(kind_phys), pointer :: sfc_down_sw(:) => null() end type ty_rad_sw end module mod_rad_ddt diff --git a/test/nested_suite_test/rad_lw.F90 b/test/nested_suite_test/rad_lw.F90 index ded4861f..5859f8bf 100644 --- a/test/nested_suite_test/rad_lw.F90 +++ b/test/nested_suite_test/rad_lw.F90 @@ -12,12 +12,12 @@ module rad_lw !> \section arg_table_rad_lw_run Argument Table !! \htmlinclude arg_table_rad_lw_run.html !! - subroutine rad_lw_run(ncol, fluxlw, errmsg, errflg) + subroutine rad_lw_run(ncol, fluxLW, errmsg, errflg) - integer, intent(in) :: ncol - type(ty_rad_lw), intent(inout) :: fluxlw(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + type(ty_rad_lw), intent(inout) :: fluxLW(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg ! Locals integer :: icol @@ -25,10 +25,10 @@ subroutine rad_lw_run(ncol, fluxlw, errmsg, errflg) errmsg = '' errflg = 0 - do icol = 1, ncol - fluxlw(icol)%sfc_up_lw = 300._kind_phys - fluxlw(icol)%sfc_down_lw = 50._kind_phys - end do + do icol=1,ncol + fluxLW(icol)%sfc_up_lw = 300._kind_phys + fluxLW(icol)%sfc_down_lw = 50._kind_phys + enddo end subroutine rad_lw_run diff --git a/test/nested_suite_test/rad_sw.F90 b/test/nested_suite_test/rad_sw.F90 index 64756217..ddf35224 100644 --- a/test/nested_suite_test/rad_sw.F90 +++ b/test/nested_suite_test/rad_sw.F90 @@ -13,11 +13,11 @@ module rad_sw !! subroutine rad_sw_run(ncol, sfc_up_sw, sfc_down_sw, errmsg, errflg) - integer, intent(in) :: ncol - real(kind=kind_phys), intent(inout) :: sfc_up_sw(:) - real(kind=kind_phys), intent(inout) :: sfc_down_sw(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + real(kind_phys), intent(inout) :: sfc_up_sw(:) + real(kind_phys), intent(inout) :: sfc_down_sw(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg ! Locals integer :: icol @@ -25,10 +25,10 @@ subroutine rad_sw_run(ncol, sfc_up_sw, sfc_down_sw, errmsg, errflg) errmsg = '' errflg = 0 - do icol = 1, ncol - sfc_up_sw(icol) = 100._kind_phys - sfc_down_sw(icol) = 400._kind_phys - end do + do icol=1,ncol + sfc_up_sw(icol) = 100._kind_phys + sfc_down_sw(icol) = 400._kind_phys + enddo end subroutine rad_sw_run diff --git a/test/nested_suite_test/test_host.F90 b/test/nested_suite_test/test_host.F90 index 5d165305..f3a389e8 100644 --- a/test/nested_suite_test/test_host.F90 +++ b/test/nested_suite_test/test_host.F90 @@ -1,264 +1,264 @@ 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 = 32 - integer, public, parameter :: cm = 60 + ! Public data and interfaces + integer, public, parameter :: cs = 32 + integer, public, parameter :: cm = 60 - !> \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) - use test_host_mod, only: ncols - 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 - use test_utils, only: check_list + !> \section arg_table_test_host Argument Table + !! \htmlinclude arg_table_test_host.html + !! + subroutine test_host(retval, test_suites) - type(suite_info), intent(in) :: test_suites(:) - logical, intent(out) :: retval + use test_host_mod, only: ncols + 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 + use test_utils, only: check_list - logical :: check - integer :: col_start, col_end - integer :: index, sind - integer :: num_suites - character(len=128), allocatable :: suite_names(:) - character(len=512) :: errmsg - integer :: errflg + type(suite_info), intent(in) :: test_suites(:) + logical, intent(out) :: retval - ! Initialize our 'data' - call init_data() + logical :: check + integer :: col_start, col_end + integer :: index, sind + integer :: num_suites + character(len=128), allocatable :: suite_names(:) + character(len=512) :: errmsg + integer :: errflg - ! 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 + ! Initialize our 'data' + call init_data() - ! 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 + ! 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 - ! 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 - - do col_start = 1, ncols, 5 - if (errflg /= 0) then - exit - end if - col_end = min(col_start + 4, ncols) + ! 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 - do sind = 1, num_suites - if (errflg /= 0) then - exit - end if - do index = 1, size(test_suites(sind)%suite_parts) + ! Initialize the timestep + do sind = 1, num_suites if (errflg /= 0) then - exit + 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) + call test_host_ccpp_physics_timestep_initial( & + test_suites(sind)%suite_name, 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 + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(errmsg) + exit end if - end do - end do - end do + if (errflg /= 0) then + 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 + 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 + 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_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 - 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_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 (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 (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/nested_suite_test/test_host_data.F90 b/test/nested_suite_test/test_host_data.F90 index 5389590f..c46bbfff 100644 --- a/test/nested_suite_test/test_host_data.F90 +++ b/test/nested_suite_test/test_host_data.F90 @@ -1,33 +1,32 @@ module test_host_data - use ccpp_kinds, only: kind_phys - use mod_rad_ddt, only: ty_rad_lw, & - ty_rad_sw + use ccpp_kinds, only: kind_phys + use mod_rad_ddt, only: ty_rad_lw, ty_rad_sw - implicit none - private + implicit none + private !> \section arg_table_physics_state Argument Table !! \htmlinclude arg_table_physics_state.html type physics_state - real(kind=kind_phys), dimension(:, :), allocatable :: & - effrr, & ! effective radius of cloud rain - effrl, & ! effective radius of cloud liquid water - effri, & ! effective radius of cloud ice - effrg, & ! effective radius of cloud graupel - ncg, & ! number concentration of cloud graupel - nci ! number concentration of cloud ice - real(kind=kind_phys) :: scalar_var - type(ty_rad_lw), dimension(:), allocatable :: & - fluxlw ! Longwave radiation fluxes - type(ty_rad_sw) :: & - fluxsw ! Shortwave radiation fluxes - real(kind=kind_phys) :: scalar_vara - real(kind=kind_phys) :: scalar_varb - real(kind=kind_phys) :: tke, tke2 - integer :: scalar_varc - integer :: scheme_order - integer :: num_subcycles + real(kind_phys), dimension(:,:), allocatable :: & + effrr, & ! effective radius of cloud rain + effrl, & ! effective radius of cloud liquid water + effri, & ! effective radius of cloud ice + effrg, & ! effective radius of cloud graupel + ncg, & ! number concentration of cloud graupel + nci ! number concentration of cloud ice + real(kind_phys) :: scalar_var + type(ty_rad_lw), dimension(:), allocatable :: & + fluxLW ! Longwave radiation fluxes + type(ty_rad_sw) :: & + fluxSW ! Shortwave radiation fluxes + real(kind_phys) :: scalar_varA + real(kind_phys) :: scalar_varB + real(kind_phys) :: tke, tke2 + integer :: scalar_varC + integer :: scheme_order + integer :: num_subcycles end type physics_state public :: physics_state @@ -36,62 +35,62 @@ module test_host_data contains subroutine allocate_physics_state(cols, levels, state, has_graupel, has_ice) - integer, intent(in) :: cols - integer, intent(in) :: levels + integer, intent(in) :: cols + integer, intent(in) :: levels type(physics_state), intent(out) :: state - logical, intent(in) :: has_graupel - logical, intent(in) :: has_ice + logical, intent(in) :: has_graupel + logical, intent(in) :: has_ice if (allocated(state%effrr)) then - deallocate(state%effrr) + deallocate(state%effrr) end if allocate(state%effrr(cols, levels)) if (allocated(state%effrl)) then - deallocate(state%effrl) + deallocate(state%effrl) end if allocate(state%effrl(cols, levels)) if (has_ice) then - if (allocated(state%effri)) then - deallocate(state%effri) - end if - allocate(state%effri(cols, levels)) - end if + if (allocated(state%effri)) then + deallocate(state%effri) + end if + allocate(state%effri(cols, levels)) + endif if (has_graupel) then - if (allocated(state%effrg)) then - deallocate(state%effrg) - end if - allocate(state%effrg(cols, levels)) - - if (allocated(state%ncg)) then - deallocate(state%ncg) - end if - allocate(state%ncg(cols, levels)) - end if + if (allocated(state%effrg)) then + deallocate(state%effrg) + end if + allocate(state%effrg(cols, levels)) - if (has_ice) then - if (allocated(state%nci)) then - deallocate(state%nci) - end if - allocate(state%nci(cols, levels)) - end if + if (allocated(state%ncg)) then + deallocate(state%ncg) + end if + allocate(state%ncg(cols, levels)) + endif - if (allocated(state%fluxlw)) then - deallocate(state%fluxlw) + if (has_ice) then + if (allocated(state%nci)) then + deallocate(state%nci) + end if + allocate(state%nci(cols, levels)) + endif + + if (allocated(state%fluxLW)) then + deallocate(state%fluxLW) end if - allocate(state%fluxlw(cols)) + allocate(state%fluxLW(cols)) - if (associated(state%fluxsw%sfc_up_sw)) then - nullify(state%fluxsw%sfc_up_sw) + if (associated(state%fluxSW%sfc_up_sw)) then + nullify(state%fluxSW%sfc_up_sw) end if - allocate(state%fluxsw%sfc_up_sw(cols)) + allocate(state%fluxSW%sfc_up_sw(cols)) - if (associated(state%fluxsw%sfc_down_sw)) then - nullify(state%fluxsw%sfc_down_sw) + if (associated(state%fluxSW%sfc_down_sw)) then + nullify(state%fluxSW%sfc_down_sw) end if - allocate(state%fluxsw%sfc_down_sw(cols)) + allocate(state%fluxSW%sfc_down_sw(cols)) ! Initialize scheme counter. state%scheme_order = 1 diff --git a/test/nested_suite_test/test_host_mod.F90 b/test/nested_suite_test/test_host_mod.F90 index 33e4a858..09d1fdb5 100644 --- a/test/nested_suite_test/test_host_mod.F90 +++ b/test/nested_suite_test/test_host_mod.F90 @@ -1,24 +1,23 @@ 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 = 12 - integer, parameter :: pver = 4 - type(physics_state) :: phys_state - real(kind=kind_phys) :: effrs(ncols, pver) - logical, parameter :: has_ice = .true. - logical, parameter :: has_graupel = .true. - - public :: init_data - public :: compare_data + 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 = 12 + integer, parameter :: pver = 4 + type(physics_state) :: phys_state + real(kind_phys) :: effrs(ncols, pver) + logical, parameter :: has_ice = .true. + logical, parameter :: has_graupel = .true. + + public :: init_data + public :: compare_data contains @@ -28,19 +27,19 @@ subroutine init_data() call allocate_physics_state(ncols, pver, phys_state, has_graupel, has_ice) phys_state%effrr = 1.0E-3 ! 1000 microns, in meter phys_state%effrl = 1.0E-4 ! 100 microns, in meter - phys_state%scalar_var = 1.0 ! in m - phys_state%scalar_vara = 273.15 ! in K - phys_state%scalar_varb = 1013.0 ! in mb - phys_state%scalar_varc = 380 ! in ppmv - effrs = 5.0E-4 ! 500 microns, in meter + phys_state%scalar_var = 1.0 ! in m + phys_state%scalar_varA = 273.15 ! in K + phys_state%scalar_varB = 1013.0 ! in mb + phys_state%scalar_varC = 380 ! in ppmv + effrs = 5.0E-4 ! 500 microns, in meter if (has_graupel) then - phys_state%effrg = 2.5E-4 ! 250 microns, in meter - phys_state%ncg = 40 - end if + phys_state%effrg = 2.5E-4 ! 250 microns, in meter + phys_state%ncg = 40 + endif if (has_ice) then - phys_state%effri = 5.0E-5 ! 50 microns, in meter - phys_state%nci = 80 - end if + phys_state%effri = 5.0E-5 ! 50 microns, in meter + phys_state%nci = 80 + endif phys_state%tke = 10.0 !J kg-1 phys_state%tke2 = 42.0 !J kg-1 @@ -48,85 +47,80 @@ end subroutine init_data logical function compare_data() - real(kind=kind_phys), parameter :: effrr_expected = 1.0E-3 ! 1000 microns, in meter - real(kind=kind_phys), parameter :: effrl_expected = 5.0E-5 ! 50 microns, in meter - real(kind=kind_phys), parameter :: effri_expected = 7.5E-5 ! 75 microns, in meter - real(kind=kind_phys), parameter :: effrs_expected = 5.3E-4 ! 530 microns, in meter - real(kind=kind_phys), parameter :: scalar_expected = 2.0E3 ! 2 km, in meter - real(kind=kind_phys), parameter :: tke_expected = 10.0 ! 10 J kg-1 - real(kind=kind_phys), parameter :: tolerance = 1.0E-6 ! used as scaling factor for expected value - real(kind=kind_phys), parameter :: sfc_up_sw_expected = 100. ! W/m2 - real(kind=kind_phys), parameter :: sfc_down_sw_expected = 400. ! W/m2 - real(kind=kind_phys), parameter :: sfc_up_lw_expected = 300. ! W/m2 - real(kind=kind_phys), parameter :: sfc_down_lw_expected = 50. ! W/m2 + real(kind_phys), parameter :: effrr_expected = 1.0E-3 ! 1000 microns, in meter + real(kind_phys), parameter :: effrl_expected = 5.0E-5 ! 50 microns, in meter + real(kind_phys), parameter :: effri_expected = 7.5E-5 ! 75 microns, in meter + real(kind_phys), parameter :: effrs_expected = 5.3E-4 ! 530 microns, in meter + real(kind_phys), parameter :: scalar_expected = 2.0E3 ! 2 km, in meter + real(kind_phys), parameter :: tke_expected = 10.0 ! 10 J kg-1 + real(kind_phys), parameter :: tolerance = 1.0E-6 ! used as scaling factor for expected value + real(kind_phys), parameter :: sfc_up_sw_expected = 100. ! W/m2 + real(kind_phys), parameter :: sfc_down_sw_expected = 400. ! W/m2 + real(kind_phys), parameter :: sfc_up_lw_expected = 300. ! W/m2 + real(kind_phys), parameter :: sfc_down_lw_expected = 50. ! W/m2 compare_data = .true. - if (maxval(abs(phys_state%effrr - effrr_expected)) > tolerance * effrr_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrr from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effrr - effrr_expected)), ' > ', tolerance * effrr_expected - compare_data = .false. - end if - - if (maxval(abs(phys_state%effrl - effrl_expected)) > tolerance * effrl_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrl from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effrl - effrl_expected)), ' > ', tolerance * effrl_expected - compare_data = .false. - end if - - if (maxval(abs(phys_state%effri - effri_expected)) > tolerance * effri_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effri from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effri - effri_expected)), ' > ', tolerance * effri_expected - compare_data = .false. - end if - - if (maxval(abs(effrs - effrs_expected)) > tolerance * effrs_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of effrs from expected value exceeds tolerance: ', & - maxval(abs(effrs - effrs_expected)), ' > ', tolerance * effrs_expected - compare_data = .false. - end if - - if (abs(phys_state%scalar_var - scalar_expected) > tolerance * scalar_expected) then - write(6, '(a,e16.7,a,e16.7)') & - 'Error: max diff of scalar_var from expected value exceeds tolerance: ', & - abs(phys_state%scalar_var - scalar_expected), ' > ', tolerance * scalar_expected - compare_data = .false. + if (maxval(abs(phys_state%effrr - effrr_expected)) > tolerance*effrr_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrr from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effrr - effrr_expected)), ' > ', tolerance*effrr_expected + compare_data = .false. end if - if (abs(phys_state%tke - tke_expected) > tolerance * tke_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of tke from expected value exceeds tolerance: ', & - abs(phys_state%tke - tke_expected), ' > ', tolerance * tke_expected - compare_data = .false. + if (maxval(abs(phys_state%effrl - effrl_expected)) > tolerance*effrl_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrl from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effrl - effrl_expected)), ' > ', tolerance*effrl_expected + compare_data = .false. end if - if (maxval(abs(phys_state%fluxsw%sfc_up_sw - sfc_up_sw_expected)) > tolerance * sfc_up_sw_expected) then - write(6, '(a,e16.7,a,e16.7)') & - 'Error: max diff of sfc_up_sw from expected value exceeds tolerance: ', & - abs(phys_state%fluxsw%sfc_up_sw - sfc_up_sw_expected), ' > ', tolerance * sfc_up_sw_expected - compare_data = .false. + if (maxval(abs(phys_state%effri - effri_expected)) > tolerance*effri_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effri from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effri - effri_expected)), ' > ', tolerance*effri_expected + compare_data = .false. end if - if (maxval(abs(phys_state%fluxsw%sfc_down_sw - sfc_down_sw_expected)) > tolerance * sfc_down_sw_expected) then - write(6, '(a,e16.7,a,e16.7)') & - 'Error: max diff of sfc_down_sw from expected value exceeds tolerance: ', & - abs(phys_state%fluxsw%sfc_down_sw - sfc_down_sw_expected), ' > ', tolerance * sfc_down_sw_expected - compare_data = .false. + if (maxval(abs( effrs - effrs_expected)) > tolerance*effrs_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of effrs from expected value exceeds tolerance: ', & + maxval(abs( effrs - effrs_expected)), ' > ', tolerance*effrs_expected + compare_data = .false. end if - if (maxval(abs(phys_state%fluxlw%sfc_up_lw - sfc_up_lw_expected)) > tolerance * sfc_up_lw_expected) then - write(6, '(a,e16.7,a,e16.7)') & - 'Error: max diff of sfc_up_lw from expected value exceeds tolerance: ', & - abs(phys_state%fluxlw%sfc_up_lw - sfc_up_lw_expected), ' > ', tolerance * sfc_up_lw_expected - compare_data = .false. + if (abs( phys_state%scalar_var - scalar_expected) > tolerance*scalar_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of scalar_var from expected value exceeds tolerance: ', & + abs( phys_state%scalar_var - scalar_expected), ' > ', tolerance*scalar_expected + compare_data = .false. end if - if (maxval(abs(phys_state%fluxlw%sfc_down_lw - sfc_down_lw_expected)) > tolerance * sfc_down_lw_expected) then - write(6, '(a,e16.7,a,e16.7)') & - 'Error: max diff of sfc_down_lw from expected value exceeds tolerance: ', & - abs(phys_state%fluxlw%sfc_down_lw - sfc_down_lw_expected), ' > ', tolerance * sfc_down_lw_expected - compare_data = .false. + if (abs( phys_state%tke - tke_expected) > tolerance*tke_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of tke from expected value exceeds tolerance: ', & + abs( phys_state%tke - tke_expected), ' > ', tolerance*tke_expected + compare_data = .false. end if + if (maxval(abs( phys_state%fluxSW%sfc_up_sw - sfc_up_sw_expected)) > tolerance*sfc_up_sw_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_up_sw from expected value exceeds tolerance: ', & + abs( phys_state%fluxSW%sfc_up_sw - sfc_up_sw_expected), ' > ', tolerance*sfc_up_sw_expected + compare_data = .false. + end if + + if (maxval(abs( phys_state%fluxSW%sfc_down_sw - sfc_down_sw_expected)) > tolerance*sfc_down_sw_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_down_sw from expected value exceeds tolerance: ', & + abs( phys_state%fluxSW%sfc_down_sw - sfc_down_sw_expected), ' > ', tolerance*sfc_down_sw_expected + compare_data = .false. + end if + + if (maxval(abs( phys_state%fluxLW%sfc_up_lw - sfc_up_lw_expected)) > tolerance*sfc_up_lw_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_up_lw from expected value exceeds tolerance: ', & + abs( phys_state%fluxLW%sfc_up_lw - sfc_up_lw_expected), ' > ', tolerance*sfc_up_lw_expected + compare_data = .false. + end if + + if (maxval(abs( phys_state%fluxLW%sfc_down_lw - sfc_down_lw_expected)) > tolerance*sfc_down_lw_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_down_lw from expected value exceeds tolerance: ', & + abs( phys_state%fluxLW%sfc_down_lw - sfc_down_lw_expected), ' > ', tolerance*sfc_down_lw_expected + compare_data = .false. + end if + end function compare_data end module test_host_mod diff --git a/test/nested_suite_test/test_nested_suite_integration.F90 b/test/nested_suite_test/test_nested_suite_integration.F90 index 55fa471d..09dfea10 100644 --- a/test/nested_suite_test/test_nested_suite_integration.F90 +++ b/test/nested_suite_test/test_nested_suite_integration.F90 @@ -1,91 +1,88 @@ program test_nested_suite_integration - 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(3) = (/ & - 'radiation1 ', & - 'rad_lw_group ', & - 'rad_sw_group '/) + character(len=cs), target :: test_parts1(3) = (/ & + 'radiation1 ', & + 'rad_lw_group ', & + 'rad_sw_group '/) - character(len=cm), target :: test_invars1(18) = (/ & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'effective_radius_of_stratiform_cloud_graupel ', & - 'cloud_graupel_number_concentration ', & - 'scalar_variable_for_testing ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'scalar_variable_for_testing_a ', & - 'scalar_variable_for_testing_b ', & - 'scalar_variable_for_testing_c ', & - 'scheme_order_in_suite ', & - 'num_subcycles_for_effr ', & - 'flag_indicating_cloud_microphysics_has_graupel ', & - 'flag_indicating_cloud_microphysics_has_ice ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_invars1(18) = (/ & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'effective_radius_of_stratiform_cloud_graupel ', & + 'cloud_graupel_number_concentration ', & + 'scalar_variable_for_testing ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'scalar_variable_for_testing_a ', & + 'scalar_variable_for_testing_b ', & + 'scalar_variable_for_testing_c ', & + 'scheme_order_in_suite ', & + 'num_subcycles_for_effr ', & + 'flag_indicating_cloud_microphysics_has_graupel ', & + 'flag_indicating_cloud_microphysics_has_ice ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'longwave_radiation_fluxes '/) - character(len=cm), target :: test_outvars1(14) = (/ & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'effective_radius_of_stratiform_cloud_ice_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'cloud_ice_number_concentration ', & - 'scalar_variable_for_testing ', & - 'scheme_order_in_suite ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_outvars1(14) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'effective_radius_of_stratiform_cloud_ice_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'cloud_ice_number_concentration ', & + 'scalar_variable_for_testing ', & + 'scheme_order_in_suite ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'longwave_radiation_fluxes '/) - character(len=cm), target :: test_reqvars1(22) = (/ & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_ice_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'effective_radius_of_stratiform_cloud_graupel ', & - 'cloud_graupel_number_concentration ', & - 'cloud_ice_number_concentration ', & - 'scalar_variable_for_testing ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'scalar_variable_for_testing_a ', & - 'scalar_variable_for_testing_b ', & - 'scalar_variable_for_testing_c ', & - 'scheme_order_in_suite ', & - 'num_subcycles_for_effr ', & - 'flag_indicating_cloud_microphysics_has_graupel ', & - 'flag_indicating_cloud_microphysics_has_ice ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_reqvars1(22) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_ice_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'effective_radius_of_stratiform_cloud_graupel ', & + 'cloud_graupel_number_concentration ', & + 'cloud_ice_number_concentration ', & + 'scalar_variable_for_testing ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'scalar_variable_for_testing_a ', & + 'scalar_variable_for_testing_b ', & + 'scalar_variable_for_testing_c ', & + 'scheme_order_in_suite ', & + 'num_subcycles_for_effr ', & + 'flag_indicating_cloud_microphysics_has_graupel ', & + 'flag_indicating_cloud_microphysics_has_ice ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'longwave_radiation_fluxes '/) - type(suite_info) :: test_suites(1) - logical :: run_okay + type(suite_info) :: test_suites(1) + logical :: run_okay - ! Setup expected test suite info - test_suites(1)%suite_name = 'main_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 + ! Setup expected test suite info + test_suites(1)%suite_name = 'main_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 - 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_nested_suite_integration diff --git a/test/unit_tests/sample_files/test_fortran_to_metadata.F90 b/test/unit_tests/sample_files/test_fortran_to_metadata.F90 index 2d08d1e3..ff4542c4 100644 --- a/test/unit_tests/sample_files/test_fortran_to_metadata.F90 +++ b/test/unit_tests/sample_files/test_fortran_to_metadata.F90 @@ -1,28 +1,28 @@ module dme_adjust - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none + implicit none contains - !=============================================================================== - !> \section arg_table_do_stuff_run Argument Table - !! \htmlinclude do_stuff_run.html - !! +!=============================================================================== +!> \section arg_table_do_stuff_run Argument Table +!! \htmlinclude do_stuff_run.html +!! subroutine do_stuff_run(const_props, twilight_zone, errmsg, errflg) ! ! Arguments ! - type(ccpp_constituent_prop_ptr_t), intent(in) :: const_props(:) - type(serling_t), intent(inout) :: twilight_zone + type(ccpp_constituent_prop_ptr_t), intent(in) :: const_props(:) + type(serling_t), intent(inout) :: twilight_zone - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = ' ' errflg = 0 twilight_zone('adjust_set') - end subroutine do_stuff_run + end subroutine dme_adjust_run end module dme_adjust diff --git a/test/unit_tests/sample_host_files/data1_mod.F90 b/test/unit_tests/sample_host_files/data1_mod.F90 index 031d8fbf..b85db315 100644 --- a/test/unit_tests/sample_host_files/data1_mod.F90 +++ b/test/unit_tests/sample_host_files/data1_mod.F90 @@ -1,11 +1,11 @@ module data1_mod - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - !> \section arg_table_data1_mod Argument Table - !! \htmlinclude arg_table_data1_mod.html - real(kind=kind_phys) :: ps1 - real(kind=kind_phys), allocatable :: xbox(:, :) - real(kind=kind_phys), allocatable :: switch(:, :) + !> \section arg_table_data1_mod Argument Table + !! \htmlinclude arg_table_data1_mod.html + real(kind_phys) :: ps1 + real(kind_phys), allocatable :: xbox(:,:) + real(kind_phys), allocatable :: switch(:,:) end module data1_mod diff --git a/test/unit_tests/sample_host_files/ddt1.F90 b/test/unit_tests/sample_host_files/ddt1.F90 index 1fef089e..71b22b4f 100644 --- a/test/unit_tests/sample_host_files/ddt1.F90 +++ b/test/unit_tests/sample_host_files/ddt1.F90 @@ -1,17 +1,17 @@ module ddt1 - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - private - implicit none + private + implicit none - !! \section arg_table_ddt1_t - !! \htmlinclude ddt1_t.html - !! - type, public :: ddt1_t - integer, public :: num_vars = 0 - real(kind=kind_phys), allocatable :: vars(:, :, :) + !! \section arg_table_ddt1_t + !! \htmlinclude ddt1_t.html + !! + type, public :: ddt1_t + integer, public :: num_vars = 0 + real(kind_phys), allocatable :: vars(:,:,:) - end type ddt1_t + end type ddt1_t end module ddt1 diff --git a/test/unit_tests/sample_host_files/ddt2.F90 b/test/unit_tests/sample_host_files/ddt2.F90 index 77653d7d..22d5af0e 100644 --- a/test/unit_tests/sample_host_files/ddt2.F90 +++ b/test/unit_tests/sample_host_files/ddt2.F90 @@ -1,24 +1,24 @@ module ddt2 - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - private - implicit none + private + implicit none - !! \section arg_table_ddt1_t - !! \htmlinclude ddt1_t.html - !! - type, public :: ddt1_t - real, pointer :: undocumented_array(:) => null() - end type ddt1_t + !! \section arg_table_ddt1_t + !! \htmlinclude ddt1_t.html + !! + type, public :: ddt1_t + real, pointer :: undocumented_array(:) => NULL() + end type ddt1_t - !! \section arg_table_ddt2_t - !! \htmlinclude ddt2_t.html - !! - type, public :: ddt2_t - integer, public :: num_vars = 0 - real(kind=kind_phys), allocatable :: vars(:, :, :) + !! \section arg_table_ddt2_t + !! \htmlinclude ddt2_t.html + !! + type, public :: ddt2_t + integer, public :: num_vars = 0 + real(kind_phys), allocatable :: vars(:,:,:) - end type ddt2_t + end type ddt2_t end module ddt2 diff --git a/test/unit_tests/sample_host_files/ddt2_extra_var.F90 b/test/unit_tests/sample_host_files/ddt2_extra_var.F90 index 460e33d2..00b4c170 100644 --- a/test/unit_tests/sample_host_files/ddt2_extra_var.F90 +++ b/test/unit_tests/sample_host_files/ddt2_extra_var.F90 @@ -1,34 +1,34 @@ module ddt2_extra_var - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - private - implicit none + private + implicit none - !! \section arg_table_ddt1_t - !! \htmlinclude ddt1_t.html - !! - type, public :: ddt1_t - real, pointer :: undocumented_array(:) => null() - end type ddt1_t + !! \section arg_table_ddt1_t + !! \htmlinclude ddt1_t.html + !! + type, public :: ddt1_t + real, pointer :: undocumented_array(:) => NULL() + end type ddt1_t - !! \section arg_table_ddt2_t - !! \htmlinclude ddt2_t.html - !! - type, public :: ddt2_t - integer, public :: num_vars = 0 - real(kind=kind_phys), allocatable :: vars(:, :, :) - contains - procedure :: get_num_vars - end type ddt2_t + !! \section arg_table_ddt2_t + !! \htmlinclude ddt2_t.html + !! + type, public :: ddt2_t + integer, public :: num_vars = 0 + real(kind_phys), allocatable :: vars(:,:,:) + contains + procedure :: get_num_vars + end type ddt2_t -contains +CONTAINS - integer function get_num_vars(this) - class(ddt2_t), intent(in) :: this + integer function get_num_vars(this) + class(ddt2_t), intent(in) :: this - get_num_vars = this%num_vars + get_num_vars = this%num_vars - end function get_num_vars + end function get_num_vars end module ddt2_extra_var diff --git a/test/unit_tests/sample_host_files/ddt_data1_mod.F90 b/test/unit_tests/sample_host_files/ddt_data1_mod.F90 index 4c4ffb16..5efe0845 100644 --- a/test/unit_tests/sample_host_files/ddt_data1_mod.F90 +++ b/test/unit_tests/sample_host_files/ddt_data1_mod.F90 @@ -1,30 +1,30 @@ module ddt_data1_mod - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - private - implicit none + private + implicit none - !! \section arg_table_ddt1_t - !! \htmlinclude ddt1_t.html - !! - type, public :: ddt1_t - real, pointer :: undocumented_array(:) => null() - end type ddt1_t + !! \section arg_table_ddt1_t + !! \htmlinclude ddt1_t.html + !! + type, public :: ddt1_t + real, pointer :: undocumented_array(:) => NULL() + end type ddt1_t - !! \section arg_table_ddt2_t - !! \htmlinclude ddt2_t.html - !! - type, public :: ddt2_t - integer, public :: num_vars = 0 - real(kind=kind_phys), allocatable :: vars(:, :, :) + !! \section arg_table_ddt2_t + !! \htmlinclude ddt2_t.html + !! + type, public :: ddt2_t + integer, public :: num_vars = 0 + real(kind_phys), allocatable :: vars(:,:,:) - end type ddt2_t + end type ddt2_t - !> \section arg_table_ddt_data1_mod Argument Table - !! \htmlinclude arg_table_ddt_data1_mod.html - real(kind=kind_phys) :: ps1 - real(kind=kind_phys), allocatable :: xbox(:, :) - real(kind=kind_phys), allocatable :: switch(:, :) + !> \section arg_table_ddt_data1_mod Argument Table + !! \htmlinclude arg_table_ddt_data1_mod.html + real(kind_phys) :: ps1 + real(kind_phys), allocatable :: xbox(:,:) + real(kind_phys), allocatable :: switch(:,:) end module ddt_data1_mod diff --git a/test/unit_tests/sample_host_files/mismatch_hdim_mod.F90 b/test/unit_tests/sample_host_files/mismatch_hdim_mod.F90 index f7540a92..b3ebe52b 100644 --- a/test/unit_tests/sample_host_files/mismatch_hdim_mod.F90 +++ b/test/unit_tests/sample_host_files/mismatch_hdim_mod.F90 @@ -1,11 +1,11 @@ module mismatch_hdim_mod - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - !> \section arg_table_mismatch_hdim_mod Argument Table - !! \htmlinclude arg_table_mismatch_hdim_mod.html - real(kind=kind_phys) :: ps1 - real(kind=kind_phys), allocatable :: xbox(:, :) - real(kind=kind_phys), allocatable :: switch(:, :) + !> \section arg_table_mismatch_hdim_mod Argument Table + !! \htmlinclude arg_table_mismatch_hdim_mod.html + real(kind_phys) :: ps1 + real(kind_phys), allocatable :: xbox(:,:) + real(kind_phys), allocatable :: switch(:,:) end module mismatch_hdim_mod diff --git a/test/unit_tests/sample_scheme_files/invalid_dummy_arg.F90 b/test/unit_tests/sample_scheme_files/invalid_dummy_arg.F90 index 4d4bf029..16f93864 100644 --- a/test/unit_tests/sample_scheme_files/invalid_dummy_arg.F90 +++ b/test/unit_tests/sample_scheme_files/invalid_dummy_arg.F90 @@ -1,31 +1,31 @@ ! Test parameterization with no vertical level ! -module invalid_dummy_arg +MODULE invalid_dummy_arg - use ccpp_kinds, only: kind_phys + USE ccpp_kinds, ONLY: kind_phys - implicit none - private + IMPLICIT NONE + PRIVATE - public :: invalid_dummy_arg_run + PUBLIC :: invalid_dummy_arg_run -contains +CONTAINS !> \section arg_table_invalid_dummy_arg_run Argument Table !! \htmlinclude arg_table_invalid_dummy_arg_run.html !! - subroutine invalid_dummy_arg_run(foo, timestep, temp_prev, temp_layer, qv, ps, & - errmsg, errflg) - - integer, intent(in) :: foo - real(kind=kind_phys), intent(in) :: timestep - real(kind=kind_phys), intent(inout) :: qv(:) - real(kind=kind_phys), intent(inout) :: ps(:) - real(kind=kind_phys), intent(in) :: woohoo(:) - real(kind=kind_phys), intent(inout) :: temp_layer(foo) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + subroutine invalid_dummy_arg_run(foo, timestep, temp_prev, temp_layer, qv, ps, & + errmsg, errflg) + + integer, intent(in) :: foo + real(kind_phys), intent(in) :: timestep + real(kind_phys), intent(inout) :: qv(:) + real(kind_phys), intent(inout) :: ps(:) + REAL(kind_phys), intent(in) :: woohoo(:) + REAL(kind_phys), intent(inout) :: temp_layer(foo) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg !---------------------------------------------------------------- integer :: col_index @@ -34,10 +34,10 @@ subroutine invalid_dummy_arg_run(foo, timestep, temp_prev, temp_layer, qv, ps, & errflg = 0 do col_index = 1, foo - temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) - qv(col_index) = qv(col_index) + 1.0_kind_phys + temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) + qv(col_index) = qv(col_index) + 1.0_kind_phys end do - end subroutine invalid_dummy_arg_run + END SUBROUTINE invalid_dummy_arg_run -end module invalid_dummy_arg +END MODULE invalid_dummy_arg diff --git a/test/unit_tests/sample_scheme_files/invalid_subr_stmnt.F90 b/test/unit_tests/sample_scheme_files/invalid_subr_stmnt.F90 index bd928bf4..98100553 100644 --- a/test/unit_tests/sample_scheme_files/invalid_subr_stmnt.F90 +++ b/test/unit_tests/sample_scheme_files/invalid_subr_stmnt.F90 @@ -1,24 +1,24 @@ ! Test parameterization with no vertical level ! -module invalid_subr_stmnt +MODULE invalid_subr_stmnt - use ccpp_kinds, only: kind_phys + USE ccpp_kinds, ONLY: kind_phys - implicit none - private + IMPLICIT NONE + PRIVATE - public :: invalid_subr_stmnt_init + PUBLIC :: invalid_subr_stmnt_init -contains +CONTAINS !> \section arg_table_invalid_subr_stmnt_init Argument Table !! \htmlinclude arg_table_invalid_subr_stmnt_init.html !! - subroutine invalid_subr_stmnt_init(woohoo, errflg) + subroutine invalid_subr_stmnt_init (woohoo, 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 @@ -27,4 +27,4 @@ subroutine invalid_subr_stmnt_init(woohoo, errflg) end subroutine invalid_subr_stmnt_init -end module invalid_subr_stmnt +END MODULE invalid_subr_stmnt diff --git a/test/unit_tests/sample_scheme_files/mismatch_hdim.F90 b/test/unit_tests/sample_scheme_files/mismatch_hdim.F90 index 0a70acc1..67680917 100644 --- a/test/unit_tests/sample_scheme_files/mismatch_hdim.F90 +++ b/test/unit_tests/sample_scheme_files/mismatch_hdim.F90 @@ -1,48 +1,48 @@ ! Test parameterization with no vertical level ! -module mismatch_hdim +MODULE mismatch_hdim - use ccpp_kinds, only: kind_phys + USE ccpp_kinds, ONLY: kind_phys - implicit none - private + IMPLICIT NONE + PRIVATE - public :: mismatch_hdim_init - public :: mismatch_hdim_run + PUBLIC :: mismatch_hdim_init + PUBLIC :: mismatch_hdim_run -contains +CONTAINS !> \section arg_table_mismatch_hdim_run Argument Table !! \htmlinclude arg_table_mismatch_hdim_run.html !! subroutine mismatch_hdim_run(tsfc, errmsg, errflg) - real(kind=kind_phys), intent(inout) :: tsfc(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), intent(inout) :: tsfc(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 - tsfc = tsfc - 1.0_kind_phys + tsfc = tsfc-1.0_kind_phys - end subroutine mismatch_hdim_run + END SUBROUTINE mismatch_hdim_run !> \section arg_table_mismatch_hdim_init Argument Table !! \htmlinclude arg_table_mismatch_hdim_init.html !! - subroutine mismatch_hdim_init(tsfc, errmsg, errflg) + subroutine mismatch_hdim_init (tsfc, errmsg, errflg) - real(kind=kind_phys), intent(inout) :: tsfc(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), intent(inout) :: tsfc(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - tsfc = tsfc + 1.0_kind_phys + tsfc = tsfc+1.0_kind_phys errmsg = '' errflg = 0 end subroutine mismatch_hdim_init -end module mismatch_hdim +END MODULE mismatch_hdim diff --git a/test/unit_tests/sample_scheme_files/mismatch_intent.F90 b/test/unit_tests/sample_scheme_files/mismatch_intent.F90 index 7dee5298..abcf7bc0 100644 --- a/test/unit_tests/sample_scheme_files/mismatch_intent.F90 +++ b/test/unit_tests/sample_scheme_files/mismatch_intent.F90 @@ -1,33 +1,33 @@ ! Test parameterization with no vertical level ! -module mismatch_intent +MODULE mismatch_intent - use ccpp_kinds, only: kind_phys + USE ccpp_kinds, ONLY: kind_phys - implicit none - private + IMPLICIT NONE + PRIVATE - public :: mismatch_intent_init - public :: mismatch_intent_run - public :: mismatch_intent_finalize + PUBLIC :: mismatch_intent_init + PUBLIC :: mismatch_intent_run + PUBLIC :: mismatch_intent_finalize -contains +CONTAINS !> \section arg_table_mismatch_intent_run Argument Table !! \htmlinclude arg_table_mismatch_intent_run.html !! - subroutine mismatch_intent_run(foo, timestep, temp_prev, temp_layer, qv, ps, & - errmsg, errflg) - - integer, intent(in) :: foo - real(kind=kind_phys), intent(in) :: timestep - real(kind=kind_phys), intent(inout) :: qv(:) - real(kind=kind_phys), intent(inout) :: ps(:) - real(kind=kind_phys), intent(in) :: temp_prev(:) - real(kind=kind_phys), intent(inout) :: temp_layer(foo) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + subroutine mismatch_intent_run(foo, timestep, temp_prev, temp_layer, qv, ps, & + errmsg, errflg) + + integer, intent(in) :: foo + real(kind_phys), intent(in) :: timestep + real(kind_phys), intent(inout) :: qv(:) + real(kind_phys), intent(inout) :: ps(:) + REAL(kind_phys), intent(in) :: temp_prev(:) + REAL(kind_phys), intent(inout) :: temp_layer(foo) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg !---------------------------------------------------------------- integer :: col_index @@ -36,19 +36,19 @@ subroutine mismatch_intent_run(foo, timestep, temp_prev, temp_layer, qv, ps, & errflg = 0 do col_index = 1, foo - temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) - qv(col_index) = qv(col_index) + 1.0_kind_phys + temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) + qv(col_index) = qv(col_index) + 1.0_kind_phys end do - end subroutine mismatch_intent_run + END SUBROUTINE mismatch_intent_run !> \section arg_table_mismatch_intent_init Argument Table !! \htmlinclude arg_table_mismatch_intent_init.html !! - subroutine mismatch_intent_init(errmsg, errflg) + subroutine mismatch_intent_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 @@ -60,10 +60,10 @@ end subroutine mismatch_intent_init !> \section arg_table_mismatch_intent_finalize Argument Table !! \htmlinclude arg_table_mismatch_intent_finalize.html !! - subroutine mismatch_intent_finalize(errmsg, errflg) + subroutine mismatch_intent_finalize (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 @@ -72,4 +72,4 @@ subroutine mismatch_intent_finalize(errmsg, errflg) end subroutine mismatch_intent_finalize -end module mismatch_intent +END MODULE mismatch_intent diff --git a/test/unit_tests/sample_scheme_files/missing_arg_table.F90 b/test/unit_tests/sample_scheme_files/missing_arg_table.F90 index cd4915f8..9d0a02af 100644 --- a/test/unit_tests/sample_scheme_files/missing_arg_table.F90 +++ b/test/unit_tests/sample_scheme_files/missing_arg_table.F90 @@ -1,33 +1,33 @@ ! Test parameterization with no vertical level ! -module missing_arg_table +MODULE missing_arg_table - use ccpp_kinds, only: kind_phys + USE ccpp_kinds, ONLY: kind_phys - implicit none - private + IMPLICIT NONE + PRIVATE - public :: missing_arg_table_init - public :: missing_arg_table_run - public :: missing_arg_table_finalize + PUBLIC :: missing_arg_table_init + PUBLIC :: missing_arg_table_run + PUBLIC :: missing_arg_table_finalize -contains +CONTAINS !> \section arg_table_missing_arg_table_run Argument Table !! \htmlinclude arg_table_missing_arg_table_run.html !! - subroutine missing_arg_table_run(foo, timestep, temp_prev, temp_layer, qv, ps, & - errmsg, errflg) - - integer, intent(in) :: foo - real(kind=kind_phys), intent(in) :: timestep - real(kind=kind_phys), intent(inout) :: qv(:) - real(kind=kind_phys), intent(inout) :: ps(:) - real(kind=kind_phys), intent(in) :: temp_prev(:) - real(kind=kind_phys), intent(inout) :: temp_layer(foo) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + subroutine missing_arg_table_run(foo, timestep, temp_prev, temp_layer, qv, ps, & + errmsg, errflg) + + integer, intent(in) :: foo + real(kind_phys), intent(in) :: timestep + real(kind_phys), intent(inout) :: qv(:) + real(kind_phys), intent(inout) :: ps(:) + REAL(kind_phys), intent(in) :: temp_prev(:) + REAL(kind_phys), intent(inout) :: temp_layer(foo) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg !---------------------------------------------------------------- integer :: col_index @@ -36,19 +36,19 @@ subroutine missing_arg_table_run(foo, timestep, temp_prev, temp_layer, qv, ps, & errflg = 0 do col_index = 1, foo - temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) - qv(col_index) = qv(col_index) + 1.0_kind_phys + temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) + qv(col_index) = qv(col_index) + 1.0_kind_phys end do - end subroutine missing_arg_table_run + END SUBROUTINE missing_arg_table_run !> \section arg_table_missing_arg_table_init Argument Table !! \htmlinclude arg_table_missing_arg_table_init.html !! - subroutine missing_arg_table_init(errmsg, errflg) + subroutine missing_arg_table_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 @@ -60,10 +60,10 @@ end subroutine missing_arg_table_init !> \section arg_table_missing_arg_table_finalize Argument Table !! \htmlinclude arg_table_missing_arg_table_finalize.html !! - subroutine missing_arg_table_finalize(errmsg, errflg) + subroutine missing_arg_table_finalize (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 @@ -72,4 +72,4 @@ subroutine missing_arg_table_finalize(errmsg, errflg) end subroutine missing_arg_table_finalize -end module missing_arg_table +END MODULE missing_arg_table diff --git a/test/unit_tests/sample_scheme_files/missing_fort_header.F90 b/test/unit_tests/sample_scheme_files/missing_fort_header.F90 index ee6e2ae5..92981eb5 100644 --- a/test/unit_tests/sample_scheme_files/missing_fort_header.F90 +++ b/test/unit_tests/sample_scheme_files/missing_fort_header.F90 @@ -1,33 +1,33 @@ ! Test parameterization with no vertical level ! -module missing_fort_header +MODULE missing_fort_header - use ccpp_kinds, only: kind_phys + USE ccpp_kinds, ONLY: kind_phys - implicit none - private + IMPLICIT NONE + PRIVATE - public :: missing_fort_header_init - public :: missing_fort_header_run - public :: missing_fort_header_finalize + PUBLIC :: missing_fort_header_init + PUBLIC :: missing_fort_header_run + PUBLIC :: missing_fort_header_finalize -contains +CONTAINS !> \section fort_header_missing_arg_table_run Argument Table !! \htmlinclude fort_header_missing_arg_table_run.html !! - subroutine missing_fort_header_run(foo, timestep, temp_prev, temp_layer, qv, ps, & - errmsg, errflg) - - integer, intent(in) :: foo - real(kind=kind_phys), intent(in) :: timestep - real(kind=kind_phys), intent(inout) :: qv(:) - real(kind=kind_phys), intent(inout) :: ps(:) - real(kind=kind_phys), intent(in) :: temp_prev(:) - real(kind=kind_phys), intent(inout) :: temp_layer(foo) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + subroutine missing_fort_header_run(foo, timestep, temp_prev, temp_layer, qv, ps, & + errmsg, errflg) + + integer, intent(in) :: foo + real(kind_phys), intent(in) :: timestep + real(kind_phys), intent(inout) :: qv(:) + real(kind_phys), intent(inout) :: ps(:) + REAL(kind_phys), intent(in) :: temp_prev(:) + REAL(kind_phys), intent(inout) :: temp_layer(foo) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg !---------------------------------------------------------------- integer :: col_index @@ -36,19 +36,19 @@ subroutine missing_fort_header_run(foo, timestep, temp_prev, temp_layer, qv, ps, errflg = 0 do col_index = 1, foo - temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) - qv(col_index) = qv(col_index) + 1.0_kind_phys + temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) + qv(col_index) = qv(col_index) + 1.0_kind_phys end do - end subroutine missing_fort_header_run + END SUBROUTINE missing_fort_header_run !> \section fort_header_missing_arg_table_init Argument Table !! \htmlinclude fort_header_missing_arg_table_init.html !! - subroutine missing_fort_header_init(errmsg, errflg) + subroutine missing_fort_header_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 @@ -58,10 +58,10 @@ subroutine missing_fort_header_init(errmsg, errflg) end subroutine missing_fort_header_init !! - subroutine missing_fort_header_finalize(errmsg, errflg) + subroutine missing_fort_header_finalize (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 @@ -70,4 +70,4 @@ subroutine missing_fort_header_finalize(errmsg, errflg) end subroutine missing_fort_header_finalize -end module missing_fort_header +END MODULE missing_fort_header diff --git a/test/unit_tests/sample_scheme_files/reorder.F90 b/test/unit_tests/sample_scheme_files/reorder.F90 index 61151975..d3c92530 100644 --- a/test/unit_tests/sample_scheme_files/reorder.F90 +++ b/test/unit_tests/sample_scheme_files/reorder.F90 @@ -1,30 +1,30 @@ -module reorder +MODULE reorder - use ccpp_kinds, only: kind_phys + USE ccpp_kinds, ONLY: kind_phys - implicit none - private + IMPLICIT NONE + PRIVATE - public :: reorder_init - public :: reorder_run - public :: reorder_finalize + PUBLIC :: reorder_init + PUBLIC :: reorder_run + PUBLIC :: reorder_finalize -contains +CONTAINS !> \section arg_table_reorder_run Argument Table !! \htmlinclude arg_table_reorder_run.html !! - subroutine reorder_run(foo, timestep, temp_prev, temp_layer, qv, ps, & - errmsg, errflg) - - integer, intent(in) :: foo - real(kind=kind_phys), intent(in) :: timestep - real(kind=kind_phys), intent(inout) :: qv(:) - real(kind=kind_phys), intent(inout) :: ps(:) - real(kind=kind_phys), intent(in) :: temp_prev(:) - real(kind=kind_phys), intent(inout) :: temp_layer(foo) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + subroutine reorder_run(foo, timestep, temp_prev, temp_layer, qv, ps, & + errmsg, errflg) + + integer, intent(in) :: foo + real(kind_phys), intent(in) :: timestep + real(kind_phys), intent(inout) :: qv(:) + real(kind_phys), intent(inout) :: ps(:) + REAL(kind_phys), intent(in) :: temp_prev(:) + REAL(kind_phys), intent(inout) :: temp_layer(foo) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg !---------------------------------------------------------------- integer :: col_index @@ -33,19 +33,19 @@ subroutine reorder_run(foo, timestep, temp_prev, temp_layer, qv, ps, & errflg = 0 do col_index = 1, foo - temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) - qv(col_index) = qv(col_index) + 1.0_kind_phys + temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) + qv(col_index) = qv(col_index) + 1.0_kind_phys end do - end subroutine reorder_run + END SUBROUTINE reorder_run !> \section arg_table_reorder_init Argument Table !! \htmlinclude arg_table_reorder_init.html !! - subroutine reorder_init(errmsg, errflg) + subroutine reorder_init (errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 @@ -55,14 +55,14 @@ end subroutine reorder_init !> \section arg_table_reorder_finalize Argument Table !! \htmlinclude arg_table_reorder_finalize.html !! - subroutine reorder_finalize(errmsg, errflg) + subroutine reorder_finalize (errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 end subroutine reorder_finalize -end module reorder +END MODULE reorder diff --git a/test/unit_tests/sample_scheme_files/temp_adjust.F90 b/test/unit_tests/sample_scheme_files/temp_adjust.F90 index 0ebaf0f8..70613ba1 100644 --- a/test/unit_tests/sample_scheme_files/temp_adjust.F90 +++ b/test/unit_tests/sample_scheme_files/temp_adjust.F90 @@ -1,54 +1,54 @@ ! Test parameterization with no vertical level ! -module temp_adjust +MODULE temp_adjust - use ccpp_kinds, only: kind_phys + USE ccpp_kinds, ONLY: kind_phys - implicit none - private + IMPLICIT NONE + PRIVATE - public :: temp_adjust_init - public :: temp_adjust_run - public :: temp_adjust_finalize + PUBLIC :: temp_adjust_init + PUBLIC :: temp_adjust_run + PUBLIC :: temp_adjust_finalize -contains +CONTAINS !> \section arg_table_temp_adjust_register Argument Table !! \htmlinclude arg_table_temp_adjust_register.html !! subroutine temp_adjust_register(config_var, dyn_const, errflg, errmsg) - logical, intent(in) :: config_var - type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + logical, intent(in) :: config_var + type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - if ( .not. config_var) then - return - end if + if (.not. config_var) then + return + end if - allocate(dyn_const(1)) - call dyn_const(1)%instantiate(std_name="dyn_const", long_name='dyn const', & - diag_name='DYNCONST', units='kg kg-1', default_value=1._kind_phys, & - vertical_dim='vertical_layer_dimension', advected=.true., & - errcode=errflg, errmsg=errmsg) + allocate(dyn_const(1)) + call dyn_const(1)%instantiate(std_name="dyn_const", long_name='dyn const', & + diag_name='DYNCONST', units='kg kg-1', default_value=1._kind_phys, & + vertical_dim='vertical_layer_dimension', advected=.true., & + errcode=errflg, errmsg=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, temp_prev, temp_layer, qv, ps, & - errmsg, errflg) - - integer, intent(in) :: foo - real(kind=kind_phys), intent(in) :: timestep - real(kind=kind_phys), intent(inout) :: qv(:) - real(kind=kind_phys), intent(inout) :: ps(:) - real(kind=kind_phys), intent(in) :: temp_prev(:) - real(kind=kind_phys), intent(inout) :: temp_layer(foo) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + subroutine temp_adjust_run(foo, timestep, temp_prev, temp_layer, qv, ps, & + errmsg, errflg) + + integer, intent(in) :: foo + real(kind_phys), intent(in) :: timestep + real(kind_phys), intent(inout) :: qv(:) + real(kind_phys), intent(inout) :: ps(:) + REAL(kind_phys), intent(in) :: temp_prev(:) + REAL(kind_phys), intent(inout) :: temp_layer(foo) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg !---------------------------------------------------------------- integer :: col_index @@ -57,19 +57,19 @@ subroutine temp_adjust_run(foo, timestep, temp_prev, temp_layer, qv, ps, & errflg = 0 do col_index = 1, foo - temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) - qv(col_index) = qv(col_index) + 1.0_kind_phys + temp_layer(col_index) = temp_layer(col_index) + temp_prev(col_index) + qv(col_index) = qv(col_index) + 1.0_kind_phys end do - 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 @@ -81,10 +81,10 @@ end subroutine temp_adjust_init !> \section arg_table_temp_adjust_finalize Argument Table !! \htmlinclude arg_table_temp_adjust_finalize.html !! - subroutine temp_adjust_finalize(errmsg, errflg) + subroutine temp_adjust_finalize (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 @@ -93,4 +93,4 @@ subroutine temp_adjust_finalize(errmsg, errflg) end subroutine temp_adjust_finalize -end module temp_adjust +END MODULE temp_adjust diff --git a/test/utils/test_utils.F90 b/test/utils/test_utils.F90 index 0f87db5e..088c347d 100644 --- a/test/utils/test_utils.F90 +++ b/test/utils/test_utils.F90 @@ -1,88 +1,88 @@ module test_utils - public :: check_list + public :: check_list contains - logical function check_list(test_list, chk_list, list_desc, suite_name) + logical function check_list(test_list, chk_list, list_desc, suite_name) ! Check a list () against its expected value () - ! Dummy arguments - character(len=*), intent(in) :: test_list(:) - character(len=*), intent(in) :: chk_list(:) - character(len=*), intent(in) :: list_desc - character(len=*), optional, intent(in) :: suite_name + ! Dummy arguments + character(len=*), intent(in) :: test_list(:) + character(len=*), intent(in) :: chk_list(:) + character(len=*), intent(in) :: list_desc + character(len=*), optional, intent(in) :: suite_name - ! Local variables - logical :: found - integer :: num_items - integer :: lindex, tindex - integer, allocatable :: check_unique(:) - character(len=2) :: sep - character(len=256) :: errmsg + ! Local variables + logical :: found + integer :: num_items + integer :: lindex, tindex + integer, allocatable :: check_unique(:) + character(len=2) :: sep + character(len=256) :: errmsg - check_list = .true. - errmsg = '' - - ! Check the list size - num_items = size(chk_list) - if (size(test_list) /= num_items) then - write(errmsg, '(a,i0,2a)') 'ERROR: Found ', size(test_list), & - ' ', trim(list_desc) - if (present(suite_name)) then - write(errmsg(len_trim(errmsg) + 1:), '(2a)') ' for suite, ', & - trim(suite_name) - end if - write(errmsg(len_trim(errmsg) + 1:), '(a,i0)') ', should be ', num_items - write(6, *) trim(errmsg) - errmsg = '' - check_list = .false. - end if + check_list = .true. + errmsg = '' - ! Now, check the list contents for 1-1 correspondence - if (check_list) then - allocate(check_unique(num_items)) - check_unique = -1 - do lindex = 1, num_items - found = .false. - do tindex = 1, num_items - if (trim(test_list(lindex)) == trim(chk_list(tindex))) then - check_unique(tindex) = lindex - found = .true. - exit - end if - end do - if ( .not. found) then - check_list = .false. - write(errmsg, '(5a)') 'ERROR: ', trim(list_desc), ' item, ', & - trim(test_list(lindex)), ', was not found' - if (present(suite_name)) then - write(errmsg(len_trim(errmsg) + 1:), '(2a)') ' in suite, ', & - trim(suite_name) - end if - write(6, *) trim(errmsg) - errmsg = '' + ! Check the list size + num_items = size(chk_list) + if (size(test_list) /= num_items) then + write(errmsg, '(a,i0,2a)') 'ERROR: Found ', size(test_list), & + ' ', trim(list_desc) + if (present(suite_name)) then + write(errmsg(len_trim(errmsg)+1:), '(2a)') ' for suite, ', & + trim(suite_name) + end if + write(errmsg(len_trim(errmsg)+1:), '(a,i0)') ', should be ', num_items + write(6, *) trim(errmsg) + errmsg = '' + check_list = .false. end if - end do - if (check_list .and. any(check_unique < 0)) then - check_list = .false. - write(errmsg, '(3a)') 'ERROR: The following ', trim(list_desc), & - ' items were not found' - if (present(suite_name)) then - write(errmsg(len_trim(errmsg) + 1:), '(2a)') ' in suite, ', & - trim(suite_name) + + ! Now, check the list contents for 1-1 correspondence + if (check_list) then + allocate(check_unique(num_items)) + check_unique = -1 + do lindex = 1, num_items + found = .false. + do tindex = 1, num_items + if (trim(test_list(lindex)) == trim(chk_list(tindex))) then + check_unique(tindex) = lindex + found = .true. + exit + end if + end do + if (.not. found) then + check_list = .false. + write(errmsg, '(5a)') 'ERROR: ', trim(list_desc), ' item, ', & + trim(test_list(lindex)), ', was not found' + if (present(suite_name)) then + write(errmsg(len_trim(errmsg)+1:), '(2a)') ' in suite, ', & + trim(suite_name) + end if + write(6, *) trim(errmsg) + errmsg = '' + end if + end do + if (check_list .and. any(check_unique < 0)) then + check_list = .false. + write(errmsg, '(3a)') 'ERROR: The following ', trim(list_desc), & + ' items were not found' + if (present(suite_name)) then + write(errmsg(len_trim(errmsg)+1:), '(2a)') ' in suite, ', & + trim(suite_name) + end if + sep = '; ' + do lindex = 1, num_items + if (check_unique(lindex) < 0) then + write(errmsg(len_trim(errmsg)+1:), '(2a)') sep, & + trim(chk_list(lindex)) + sep = ', ' + end if + end do + write(6, *) trim(errmsg) + errmsg = '' + end if end if - sep = '; ' - do lindex = 1, num_items - if (check_unique(lindex) < 0) then - write(errmsg(len_trim(errmsg) + 1:), '(2a)') sep, & - trim(chk_list(lindex)) - sep = ', ' - end if - end do - write(6, *) trim(errmsg) - errmsg = '' - end if - end if - end function check_list + end function check_list end module test_utils diff --git a/test/var_compatibility_test/effr_calc.F90 b/test/var_compatibility_test/effr_calc.F90 index b8fc43ed..0b626c16 100644 --- a/test/var_compatibility_test/effr_calc.F90 +++ b/test/var_compatibility_test/effr_calc.F90 @@ -3,82 +3,82 @@ module effr_calc - use ccpp_kinds, only: kind_phys - - implicit none - private - - public :: effr_calc_run, effr_calc_init - -contains - !> \section arg_table_effr_calc_init Argument Table - !! \htmlinclude arg_table_effr_calc_init.html - !! - subroutine effr_calc_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order /= 2) then - errflg = 1 - errmsg = 'ERROR: effr_calc_init() needs to be called second' - return - else - scheme_order = scheme_order + 1 - end if - - end subroutine effr_calc_init - - !> \section arg_table_effr_calc_run Argument Table - !! \htmlinclude arg_table_effr_calc_run.html - !! - subroutine effr_calc_run(ncol, nlev, effrr_in, effrg_in, ncg_in, nci_out, & - effrl_inout, effri_out, effrs_inout, ncl_out, & - has_graupel, scalar_var, tke_inout, tke2_inout, & - errmsg, errflg) - - integer, intent(in) :: ncol - integer, intent(in) :: nlev - real(kind=kind_phys), intent(in) :: effrr_in(:, :) - real(kind=kind_phys), intent(in), optional :: effrg_in(:, :) - real(kind=kind_phys), intent(in), optional :: ncg_in(:, :) - real(kind=kind_phys), intent(out), optional :: nci_out(:, :) - real(kind=kind_phys), intent(inout) :: effrl_inout(:, :) - real(kind=kind_phys), intent(out), optional :: effri_out(:, :) - real(kind=8), intent(inout) :: effrs_inout(:, :) - logical, intent(in) :: has_graupel - real(kind=kind_phys), intent(inout) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - real(kind=kind_phys), intent(out), optional :: ncl_out(:, :) - real(kind=kind_phys), intent(inout) :: tke_inout - real(kind=kind_phys), intent(inout) :: tke2_inout - - !---------------------------------------------------------------- - - real(kind=kind_phys), parameter :: re_qc_min = 2.5 ! microns - real(kind=kind_phys), parameter :: re_qc_max = 50. ! microns - real(kind=kind_phys), parameter :: re_qi_avg = 75. ! microns - real(kind=kind_phys) :: effrr_local(ncol, nlev) - real(kind=kind_phys) :: effrg_local(ncol, nlev) - real(kind=kind_phys) :: ncg_in_local(ncol, nlev) - real(kind=kind_phys) :: nci_out_local(ncol, nlev) - - errmsg = '' - errflg = 0 - - effrr_local = effrr_in - if (present(effrg_in)) effrg_local = effrg_in - if (present(ncg_in)) ncg_in_local = ncg_in - if (present(nci_out)) nci_out_local = nci_out - effrl_inout = min(max(effrl_inout, re_qc_min), re_qc_max) - if (present(effri_out)) effri_out = re_qi_avg - effrs_inout = effrs_inout + (10.0 / 6.0) ! in micrometer - scalar_var = 2.0 ! in km - - end subroutine effr_calc_run + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: effr_calc_run, effr_calc_init + + contains + !> \section arg_table_effr_calc_init Argument Table + !! \htmlinclude arg_table_effr_calc_init.html + !! + subroutine effr_calc_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order .ne. 2) then + errflg = 1 + errmsg = 'ERROR: effr_calc_init() needs to be called second' + return + else + scheme_order = scheme_order + 1 + endif + + end subroutine effr_calc_init + + !> \section arg_table_effr_calc_run Argument Table + !! \htmlinclude arg_table_effr_calc_run.html + !! + subroutine effr_calc_run(ncol, nlev, effrr_in, effrg_in, ncg_in, nci_out, & + effrl_inout, effri_out, effrs_inout, ncl_out, & + has_graupel, scalar_var, tke_inout, tke2_inout, & + errmsg, errflg) + + integer, intent(in) :: ncol + integer, intent(in) :: nlev + real(kind_phys), intent(in) :: effrr_in(:,:) + real(kind_phys), intent(in),optional :: effrg_in(:,:) + real(kind_phys), intent(in),optional :: ncg_in(:,:) + real(kind_phys), intent(out),optional :: nci_out(:,:) + real(kind_phys), intent(inout) :: effrl_inout(:,:) + real(kind_phys), intent(out),optional :: effri_out(:,:) + real(8),intent(inout) :: effrs_inout(:,:) + logical, intent(in) :: has_graupel + real(kind_phys), intent(inout) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind_phys), intent(out),optional :: ncl_out(:,:) + real(kind_phys), intent(inout) :: tke_inout + real(kind_phys), intent(inout) :: tke2_inout + + !---------------------------------------------------------------- + + real(kind_phys), parameter :: re_qc_min = 2.5 ! microns + real(kind_phys), parameter :: re_qc_max = 50. ! microns + real(kind_phys), parameter :: re_qi_avg = 75. ! microns + real(kind_phys) :: effrr_local(ncol,nlev) + real(kind_phys) :: effrg_local(ncol,nlev) + real(kind_phys) :: ncg_in_local(ncol,nlev) + real(kind_phys) :: nci_out_local(ncol,nlev) + + errmsg = '' + errflg = 0 + + effrr_local = effrr_in + if (present(effrg_in)) effrg_local = effrg_in + if (present(ncg_in)) ncg_in_local = ncg_in + if (present(nci_out)) nci_out_local = nci_out + effrl_inout = min(max(effrl_inout,re_qc_min),re_qc_max) + if (present(effri_out)) effri_out = re_qi_avg + effrs_inout = effrs_inout + (10.0 / 6.0) ! in micrometer + scalar_var = 2.0 ! in km + + end subroutine effr_calc_run end module effr_calc diff --git a/test/var_compatibility_test/effr_diag.F90 b/test/var_compatibility_test/effr_diag.F90 index 75da29c7..409ff2f9 100644 --- a/test/var_compatibility_test/effr_diag.F90 +++ b/test/var_compatibility_test/effr_diag.F90 @@ -3,12 +3,12 @@ module effr_diag - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_diag_run, effr_diag_init + public :: effr_diag_run, effr_diag_init contains @@ -16,53 +16,53 @@ module effr_diag !! \htmlinclude arg_table_effr_diag_init.html !! subroutine effr_diag_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + errmsg = '' errflg = 0 - if (scheme_order /= 4) then - errflg = 1 - errmsg = 'ERROR: effr_diag_init() needs to be called fourth' - return - else - scheme_order = scheme_order + 1 - end if + if (scheme_order .ne. 4) then + errflg = 1 + errmsg = 'ERROR: effr_diag_init() needs to be called fourth' + return + else + scheme_order = scheme_order + 1 + endif end subroutine effr_diag_init - !> \section arg_table_effr_diag_run Argument Table - !! \htmlinclude arg_table_effr_diag_run.html - !! - subroutine effr_diag_run(effrr_in, scalar_var, errmsg, errflg) - - real(kind=kind_phys), intent(in) :: effrr_in(:, :) - integer, intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind=kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - call cmp_effr_diag(effrr_in, effrr_min, effrr_max) - - if (scalar_var /= 380) then - errmsg = 'ERROR: effr_diag_run(): scalar_var should be 380' - errflg = 1 - end if - end subroutine effr_diag_run - - subroutine cmp_effr_diag(effr, effr_min, effr_max) - real(kind=kind_phys), intent(in) :: effr(:, :) - real(kind=kind_phys), intent(out) :: effr_min, effr_max - - ! Do some diagnostic calcualtions... - effr_min = minval(effr) - effr_max = maxval(effr) - - end subroutine cmp_effr_diag + !> \section arg_table_effr_diag_run Argument Table + !! \htmlinclude arg_table_effr_diag_run.html + !! + subroutine effr_diag_run( effrr_in, scalar_var, errmsg, errflg) + + real(kind_phys), intent(in) :: effrr_in(:,:) + integer, intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + call cmp_effr_diag(effrr_in, effrr_min, effrr_max) + + if (scalar_var .ne. 380) then + errmsg = 'ERROR: effr_diag_run(): scalar_var should be 380' + errflg = 1 + endif + end subroutine effr_diag_run + + subroutine cmp_effr_diag(effr, effr_min, effr_max) + real(kind_phys), intent(in) :: effr(:,:) + real(kind_phys), intent(out) :: effr_min, effr_max + + ! Do some diagnostic calcualtions... + effr_min = minval(effr) + effr_max = maxval(effr) + + end subroutine cmp_effr_diag end module effr_diag diff --git a/test/var_compatibility_test/effr_post.F90 b/test/var_compatibility_test/effr_post.F90 index 01357350..d42a574c 100644 --- a/test/var_compatibility_test/effr_post.F90 +++ b/test/var_compatibility_test/effr_post.F90 @@ -3,59 +3,59 @@ module effr_post - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_post_run, effr_post_init + public :: effr_post_run, effr_post_init contains - !> \section arg_table_effr_post_init Argument Table - !! \htmlinclude arg_table_effr_post_init.html - !! - subroutine effr_post_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order /= 3) then - errflg = 1 - errmsg = 'ERROR: effr_post_init() needs to be called third' - return - else - scheme_order = scheme_order + 1 - end if - - end subroutine effr_post_init - - !> \section arg_table_effr_post_run Argument Table - !! \htmlinclude arg_table_effr_post_run.html - !! - subroutine effr_post_run(effrr_inout, scalar_var, errmsg, errflg) - - real(kind=kind_phys), intent(inout) :: effrr_inout(:, :) - real(kind=kind_phys), intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind=kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - ! Do some post-processing on effrr... - effrr_inout(:, :) = effrr_inout(:, :) * 1._kind_phys - - if (scalar_var /= 1013.0) then - errmsg = 'ERROR: effr_post_run(): scalar_var should be 1013.0' - errflg = 1 - end if - - end subroutine effr_post_run - -end module effr_post + !> \section arg_table_effr_post_init Argument Table + !! \htmlinclude arg_table_effr_post_init.html + !! + subroutine effr_post_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order .ne. 3) then + errflg = 1 + errmsg = 'ERROR: effr_post_init() needs to be called third' + return + else + scheme_order = scheme_order + 1 + endif + + end subroutine effr_post_init + + !> \section arg_table_effr_post_run Argument Table + !! \htmlinclude arg_table_effr_post_run.html + !! + subroutine effr_post_run( effrr_inout, scalar_var, errmsg, errflg) + + real(kind_phys), intent(inout) :: effrr_inout(:,:) + real(kind_phys), intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + ! Do some post-processing on effrr... + effrr_inout(:,:) = effrr_inout(:,:)*1._kind_phys + + if (scalar_var .ne. 1013.0) then + errmsg = 'ERROR: effr_post_run(): scalar_var should be 1013.0' + errflg = 1 + endif + + end subroutine effr_post_run + + end module effr_post diff --git a/test/var_compatibility_test/effr_pre.F90 b/test/var_compatibility_test/effr_pre.F90 index a2fe2f5c..17a3b187 100644 --- a/test/var_compatibility_test/effr_pre.F90 +++ b/test/var_compatibility_test/effr_pre.F90 @@ -3,58 +3,58 @@ module mod_effr_pre - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_pre_run, effr_pre_init + public :: effr_pre_run, effr_pre_init contains - !> \section arg_table_effr_pre_init Argument Table - !! \htmlinclude arg_table_effr_pre_init.html - !! - subroutine effr_pre_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order /= 1) then - errflg = 1 - errmsg = 'ERROR: effr_pre_init() needs to be called first' - return - else - scheme_order = scheme_order + 1 - end if - - end subroutine effr_pre_init - - !> \section arg_table_effr_pre_run Argument Table - !! \htmlinclude arg_table_effr_pre_run.html - !! - subroutine effr_pre_run(effrr_inout, scalar_var, errmsg, errflg) - - real(kind=kind_phys), intent(inout) :: effrr_inout(:, :) - real(kind=kind_phys), intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind=kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - ! Do some pre-processing on effrr... - effrr_inout(:, :) = effrr_inout(:, :) * 1._kind_phys - - if (scalar_var /= 273.15) then - errmsg = 'ERROR: effr_pre_run(): scalar_var should be 273.15' - errflg = 1 - end if - - end subroutine effr_pre_run + !> \section arg_table_effr_pre_init Argument Table + !! \htmlinclude arg_table_effr_pre_init.html + !! + subroutine effr_pre_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order .ne. 1) then + errflg = 1 + errmsg = 'ERROR: effr_pre_init() needs to be called first' + return + else + scheme_order = scheme_order + 1 + endif + + end subroutine effr_pre_init + + !> \section arg_table_effr_pre_run Argument Table + !! \htmlinclude arg_table_effr_pre_run.html + !! + subroutine effr_pre_run( effrr_inout, scalar_var, errmsg, errflg) + + real(kind_phys), intent(inout) :: effrr_inout(:,:) + real(kind_phys), intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + ! Do some pre-processing on effrr... + effrr_inout(:,:) = effrr_inout(:,:)*1._kind_phys + + if (scalar_var .ne. 273.15) then + errmsg = 'ERROR: effr_pre_run(): scalar_var should be 273.15' + errflg = 1 + endif + + end subroutine effr_pre_run end module mod_effr_pre diff --git a/test/var_compatibility_test/effrs_calc.F90 b/test/var_compatibility_test/effrs_calc.F90 index 3aa8d196..e9266905 100644 --- a/test/var_compatibility_test/effrs_calc.F90 +++ b/test/var_compatibility_test/effrs_calc.F90 @@ -3,30 +3,30 @@ module effrs_calc - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effrs_calc_run + public :: effrs_calc_run -contains - !> \section arg_table_effrs_calc_run Argument Table - !! \htmlinclude arg_table_effrs_calc_run.html - !! - subroutine effrs_calc_run(effrs_inout, errmsg, errflg) + contains + !> \section arg_table_effrs_calc_run Argument Table + !! \htmlinclude arg_table_effrs_calc_run.html + !! + subroutine effrs_calc_run(effrs_inout, errmsg, errflg) - real(kind=kind_phys), intent(inout) :: effrs_inout(:, :) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), intent(inout) :: effrs_inout(:,:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - !---------------------------------------------------------------- + !---------------------------------------------------------------- - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 - effrs_inout = effrs_inout + (10.E-6_kind_phys / 3._kind_phys) ! in meters + effrs_inout = effrs_inout + (10.E-6_kind_phys / 3._kind_phys) ! in meters - end subroutine effrs_calc_run + end subroutine effrs_calc_run end module effrs_calc diff --git a/test/var_compatibility_test/module_rad_ddt.F90 b/test/var_compatibility_test/module_rad_ddt.F90 index 6e992250..21a1a0ec 100644 --- a/test/var_compatibility_test/module_rad_ddt.F90 +++ b/test/var_compatibility_test/module_rad_ddt.F90 @@ -1,5 +1,5 @@ module mod_rad_ddt - use ccpp_kinds, only: kind_phys + USE ccpp_kinds, ONLY: kind_phys implicit none public ty_rad_lw, ty_rad_sw @@ -8,16 +8,16 @@ module mod_rad_ddt !! \htmlinclude arg_table_ty_rad_lw.html !! type ty_rad_lw - real(kind=kind_phys) :: sfc_up_lw - real(kind=kind_phys) :: sfc_down_lw + real(kind_phys) :: sfc_up_lw + real(kind_phys) :: sfc_down_lw end type ty_rad_lw !> \section arg_table_ty_rad_sw Argument Table !! \htmlinclude arg_table_ty_rad_sw.html !! type ty_rad_sw - real(kind=kind_phys), pointer :: sfc_up_sw(:) => null() - real(kind=kind_phys), pointer :: sfc_down_sw(:) => null() + real(kind_phys), pointer :: sfc_up_sw(:) => null() + real(kind_phys), pointer :: sfc_down_sw(:) => null() end type ty_rad_sw end module mod_rad_ddt diff --git a/test/var_compatibility_test/rad_lw.F90 b/test/var_compatibility_test/rad_lw.F90 index ded4861f..5859f8bf 100644 --- a/test/var_compatibility_test/rad_lw.F90 +++ b/test/var_compatibility_test/rad_lw.F90 @@ -12,12 +12,12 @@ module rad_lw !> \section arg_table_rad_lw_run Argument Table !! \htmlinclude arg_table_rad_lw_run.html !! - subroutine rad_lw_run(ncol, fluxlw, errmsg, errflg) + subroutine rad_lw_run(ncol, fluxLW, errmsg, errflg) - integer, intent(in) :: ncol - type(ty_rad_lw), intent(inout) :: fluxlw(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + type(ty_rad_lw), intent(inout) :: fluxLW(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg ! Locals integer :: icol @@ -25,10 +25,10 @@ subroutine rad_lw_run(ncol, fluxlw, errmsg, errflg) errmsg = '' errflg = 0 - do icol = 1, ncol - fluxlw(icol)%sfc_up_lw = 300._kind_phys - fluxlw(icol)%sfc_down_lw = 50._kind_phys - end do + do icol=1,ncol + fluxLW(icol)%sfc_up_lw = 300._kind_phys + fluxLW(icol)%sfc_down_lw = 50._kind_phys + enddo end subroutine rad_lw_run diff --git a/test/var_compatibility_test/rad_sw.F90 b/test/var_compatibility_test/rad_sw.F90 index 64756217..ddf35224 100644 --- a/test/var_compatibility_test/rad_sw.F90 +++ b/test/var_compatibility_test/rad_sw.F90 @@ -13,11 +13,11 @@ module rad_sw !! subroutine rad_sw_run(ncol, sfc_up_sw, sfc_down_sw, errmsg, errflg) - integer, intent(in) :: ncol - real(kind=kind_phys), intent(inout) :: sfc_up_sw(:) - real(kind=kind_phys), intent(inout) :: sfc_down_sw(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + real(kind_phys), intent(inout) :: sfc_up_sw(:) + real(kind_phys), intent(inout) :: sfc_down_sw(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg ! Locals integer :: icol @@ -25,10 +25,10 @@ subroutine rad_sw_run(ncol, sfc_up_sw, sfc_down_sw, errmsg, errflg) errmsg = '' errflg = 0 - do icol = 1, ncol - sfc_up_sw(icol) = 100._kind_phys - sfc_down_sw(icol) = 400._kind_phys - end do + do icol=1,ncol + sfc_up_sw(icol) = 100._kind_phys + sfc_down_sw(icol) = 400._kind_phys + enddo end subroutine rad_sw_run diff --git a/test/var_compatibility_test/test_host.F90 b/test/var_compatibility_test/test_host.F90 index 5d165305..f3a389e8 100644 --- a/test/var_compatibility_test/test_host.F90 +++ b/test/var_compatibility_test/test_host.F90 @@ -1,264 +1,264 @@ 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 = 32 - integer, public, parameter :: cm = 60 + ! Public data and interfaces + integer, public, parameter :: cs = 32 + integer, public, parameter :: cm = 60 - !> \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) - use test_host_mod, only: ncols - 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 - use test_utils, only: check_list + !> \section arg_table_test_host Argument Table + !! \htmlinclude arg_table_test_host.html + !! + subroutine test_host(retval, test_suites) - type(suite_info), intent(in) :: test_suites(:) - logical, intent(out) :: retval + use test_host_mod, only: ncols + 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 + use test_utils, only: check_list - logical :: check - integer :: col_start, col_end - integer :: index, sind - integer :: num_suites - character(len=128), allocatable :: suite_names(:) - character(len=512) :: errmsg - integer :: errflg + type(suite_info), intent(in) :: test_suites(:) + logical, intent(out) :: retval - ! Initialize our 'data' - call init_data() + logical :: check + integer :: col_start, col_end + integer :: index, sind + integer :: num_suites + character(len=128), allocatable :: suite_names(:) + character(len=512) :: errmsg + integer :: errflg - ! 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 + ! Initialize our 'data' + call init_data() - ! 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 + ! 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 - ! 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 - - do col_start = 1, ncols, 5 - if (errflg /= 0) then - exit - end if - col_end = min(col_start + 4, ncols) + ! 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 - do sind = 1, num_suites - if (errflg /= 0) then - exit - end if - do index = 1, size(test_suites(sind)%suite_parts) + ! Initialize the timestep + do sind = 1, num_suites if (errflg /= 0) then - exit + 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) + call test_host_ccpp_physics_timestep_initial( & + test_suites(sind)%suite_name, 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 + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(errmsg) + exit end if - end do - end do - end do + if (errflg /= 0) then + 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 + 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 + 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_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 - 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_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 (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 (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/var_compatibility_test/test_host_data.F90 b/test/var_compatibility_test/test_host_data.F90 index 5389590f..c46bbfff 100644 --- a/test/var_compatibility_test/test_host_data.F90 +++ b/test/var_compatibility_test/test_host_data.F90 @@ -1,33 +1,32 @@ module test_host_data - use ccpp_kinds, only: kind_phys - use mod_rad_ddt, only: ty_rad_lw, & - ty_rad_sw + use ccpp_kinds, only: kind_phys + use mod_rad_ddt, only: ty_rad_lw, ty_rad_sw - implicit none - private + implicit none + private !> \section arg_table_physics_state Argument Table !! \htmlinclude arg_table_physics_state.html type physics_state - real(kind=kind_phys), dimension(:, :), allocatable :: & - effrr, & ! effective radius of cloud rain - effrl, & ! effective radius of cloud liquid water - effri, & ! effective radius of cloud ice - effrg, & ! effective radius of cloud graupel - ncg, & ! number concentration of cloud graupel - nci ! number concentration of cloud ice - real(kind=kind_phys) :: scalar_var - type(ty_rad_lw), dimension(:), allocatable :: & - fluxlw ! Longwave radiation fluxes - type(ty_rad_sw) :: & - fluxsw ! Shortwave radiation fluxes - real(kind=kind_phys) :: scalar_vara - real(kind=kind_phys) :: scalar_varb - real(kind=kind_phys) :: tke, tke2 - integer :: scalar_varc - integer :: scheme_order - integer :: num_subcycles + real(kind_phys), dimension(:,:), allocatable :: & + effrr, & ! effective radius of cloud rain + effrl, & ! effective radius of cloud liquid water + effri, & ! effective radius of cloud ice + effrg, & ! effective radius of cloud graupel + ncg, & ! number concentration of cloud graupel + nci ! number concentration of cloud ice + real(kind_phys) :: scalar_var + type(ty_rad_lw), dimension(:), allocatable :: & + fluxLW ! Longwave radiation fluxes + type(ty_rad_sw) :: & + fluxSW ! Shortwave radiation fluxes + real(kind_phys) :: scalar_varA + real(kind_phys) :: scalar_varB + real(kind_phys) :: tke, tke2 + integer :: scalar_varC + integer :: scheme_order + integer :: num_subcycles end type physics_state public :: physics_state @@ -36,62 +35,62 @@ module test_host_data contains subroutine allocate_physics_state(cols, levels, state, has_graupel, has_ice) - integer, intent(in) :: cols - integer, intent(in) :: levels + integer, intent(in) :: cols + integer, intent(in) :: levels type(physics_state), intent(out) :: state - logical, intent(in) :: has_graupel - logical, intent(in) :: has_ice + logical, intent(in) :: has_graupel + logical, intent(in) :: has_ice if (allocated(state%effrr)) then - deallocate(state%effrr) + deallocate(state%effrr) end if allocate(state%effrr(cols, levels)) if (allocated(state%effrl)) then - deallocate(state%effrl) + deallocate(state%effrl) end if allocate(state%effrl(cols, levels)) if (has_ice) then - if (allocated(state%effri)) then - deallocate(state%effri) - end if - allocate(state%effri(cols, levels)) - end if + if (allocated(state%effri)) then + deallocate(state%effri) + end if + allocate(state%effri(cols, levels)) + endif if (has_graupel) then - if (allocated(state%effrg)) then - deallocate(state%effrg) - end if - allocate(state%effrg(cols, levels)) - - if (allocated(state%ncg)) then - deallocate(state%ncg) - end if - allocate(state%ncg(cols, levels)) - end if + if (allocated(state%effrg)) then + deallocate(state%effrg) + end if + allocate(state%effrg(cols, levels)) - if (has_ice) then - if (allocated(state%nci)) then - deallocate(state%nci) - end if - allocate(state%nci(cols, levels)) - end if + if (allocated(state%ncg)) then + deallocate(state%ncg) + end if + allocate(state%ncg(cols, levels)) + endif - if (allocated(state%fluxlw)) then - deallocate(state%fluxlw) + if (has_ice) then + if (allocated(state%nci)) then + deallocate(state%nci) + end if + allocate(state%nci(cols, levels)) + endif + + if (allocated(state%fluxLW)) then + deallocate(state%fluxLW) end if - allocate(state%fluxlw(cols)) + allocate(state%fluxLW(cols)) - if (associated(state%fluxsw%sfc_up_sw)) then - nullify(state%fluxsw%sfc_up_sw) + if (associated(state%fluxSW%sfc_up_sw)) then + nullify(state%fluxSW%sfc_up_sw) end if - allocate(state%fluxsw%sfc_up_sw(cols)) + allocate(state%fluxSW%sfc_up_sw(cols)) - if (associated(state%fluxsw%sfc_down_sw)) then - nullify(state%fluxsw%sfc_down_sw) + if (associated(state%fluxSW%sfc_down_sw)) then + nullify(state%fluxSW%sfc_down_sw) end if - allocate(state%fluxsw%sfc_down_sw(cols)) + allocate(state%fluxSW%sfc_down_sw(cols)) ! Initialize scheme counter. state%scheme_order = 1 diff --git a/test/var_compatibility_test/test_host_mod.F90 b/test/var_compatibility_test/test_host_mod.F90 index 33e4a858..09d1fdb5 100644 --- a/test/var_compatibility_test/test_host_mod.F90 +++ b/test/var_compatibility_test/test_host_mod.F90 @@ -1,24 +1,23 @@ 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 = 12 - integer, parameter :: pver = 4 - type(physics_state) :: phys_state - real(kind=kind_phys) :: effrs(ncols, pver) - logical, parameter :: has_ice = .true. - logical, parameter :: has_graupel = .true. - - public :: init_data - public :: compare_data + 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 = 12 + integer, parameter :: pver = 4 + type(physics_state) :: phys_state + real(kind_phys) :: effrs(ncols, pver) + logical, parameter :: has_ice = .true. + logical, parameter :: has_graupel = .true. + + public :: init_data + public :: compare_data contains @@ -28,19 +27,19 @@ subroutine init_data() call allocate_physics_state(ncols, pver, phys_state, has_graupel, has_ice) phys_state%effrr = 1.0E-3 ! 1000 microns, in meter phys_state%effrl = 1.0E-4 ! 100 microns, in meter - phys_state%scalar_var = 1.0 ! in m - phys_state%scalar_vara = 273.15 ! in K - phys_state%scalar_varb = 1013.0 ! in mb - phys_state%scalar_varc = 380 ! in ppmv - effrs = 5.0E-4 ! 500 microns, in meter + phys_state%scalar_var = 1.0 ! in m + phys_state%scalar_varA = 273.15 ! in K + phys_state%scalar_varB = 1013.0 ! in mb + phys_state%scalar_varC = 380 ! in ppmv + effrs = 5.0E-4 ! 500 microns, in meter if (has_graupel) then - phys_state%effrg = 2.5E-4 ! 250 microns, in meter - phys_state%ncg = 40 - end if + phys_state%effrg = 2.5E-4 ! 250 microns, in meter + phys_state%ncg = 40 + endif if (has_ice) then - phys_state%effri = 5.0E-5 ! 50 microns, in meter - phys_state%nci = 80 - end if + phys_state%effri = 5.0E-5 ! 50 microns, in meter + phys_state%nci = 80 + endif phys_state%tke = 10.0 !J kg-1 phys_state%tke2 = 42.0 !J kg-1 @@ -48,85 +47,80 @@ end subroutine init_data logical function compare_data() - real(kind=kind_phys), parameter :: effrr_expected = 1.0E-3 ! 1000 microns, in meter - real(kind=kind_phys), parameter :: effrl_expected = 5.0E-5 ! 50 microns, in meter - real(kind=kind_phys), parameter :: effri_expected = 7.5E-5 ! 75 microns, in meter - real(kind=kind_phys), parameter :: effrs_expected = 5.3E-4 ! 530 microns, in meter - real(kind=kind_phys), parameter :: scalar_expected = 2.0E3 ! 2 km, in meter - real(kind=kind_phys), parameter :: tke_expected = 10.0 ! 10 J kg-1 - real(kind=kind_phys), parameter :: tolerance = 1.0E-6 ! used as scaling factor for expected value - real(kind=kind_phys), parameter :: sfc_up_sw_expected = 100. ! W/m2 - real(kind=kind_phys), parameter :: sfc_down_sw_expected = 400. ! W/m2 - real(kind=kind_phys), parameter :: sfc_up_lw_expected = 300. ! W/m2 - real(kind=kind_phys), parameter :: sfc_down_lw_expected = 50. ! W/m2 + real(kind_phys), parameter :: effrr_expected = 1.0E-3 ! 1000 microns, in meter + real(kind_phys), parameter :: effrl_expected = 5.0E-5 ! 50 microns, in meter + real(kind_phys), parameter :: effri_expected = 7.5E-5 ! 75 microns, in meter + real(kind_phys), parameter :: effrs_expected = 5.3E-4 ! 530 microns, in meter + real(kind_phys), parameter :: scalar_expected = 2.0E3 ! 2 km, in meter + real(kind_phys), parameter :: tke_expected = 10.0 ! 10 J kg-1 + real(kind_phys), parameter :: tolerance = 1.0E-6 ! used as scaling factor for expected value + real(kind_phys), parameter :: sfc_up_sw_expected = 100. ! W/m2 + real(kind_phys), parameter :: sfc_down_sw_expected = 400. ! W/m2 + real(kind_phys), parameter :: sfc_up_lw_expected = 300. ! W/m2 + real(kind_phys), parameter :: sfc_down_lw_expected = 50. ! W/m2 compare_data = .true. - if (maxval(abs(phys_state%effrr - effrr_expected)) > tolerance * effrr_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrr from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effrr - effrr_expected)), ' > ', tolerance * effrr_expected - compare_data = .false. - end if - - if (maxval(abs(phys_state%effrl - effrl_expected)) > tolerance * effrl_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrl from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effrl - effrl_expected)), ' > ', tolerance * effrl_expected - compare_data = .false. - end if - - if (maxval(abs(phys_state%effri - effri_expected)) > tolerance * effri_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effri from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effri - effri_expected)), ' > ', tolerance * effri_expected - compare_data = .false. - end if - - if (maxval(abs(effrs - effrs_expected)) > tolerance * effrs_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of effrs from expected value exceeds tolerance: ', & - maxval(abs(effrs - effrs_expected)), ' > ', tolerance * effrs_expected - compare_data = .false. - end if - - if (abs(phys_state%scalar_var - scalar_expected) > tolerance * scalar_expected) then - write(6, '(a,e16.7,a,e16.7)') & - 'Error: max diff of scalar_var from expected value exceeds tolerance: ', & - abs(phys_state%scalar_var - scalar_expected), ' > ', tolerance * scalar_expected - compare_data = .false. + if (maxval(abs(phys_state%effrr - effrr_expected)) > tolerance*effrr_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrr from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effrr - effrr_expected)), ' > ', tolerance*effrr_expected + compare_data = .false. end if - if (abs(phys_state%tke - tke_expected) > tolerance * tke_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of tke from expected value exceeds tolerance: ', & - abs(phys_state%tke - tke_expected), ' > ', tolerance * tke_expected - compare_data = .false. + if (maxval(abs(phys_state%effrl - effrl_expected)) > tolerance*effrl_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrl from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effrl - effrl_expected)), ' > ', tolerance*effrl_expected + compare_data = .false. end if - if (maxval(abs(phys_state%fluxsw%sfc_up_sw - sfc_up_sw_expected)) > tolerance * sfc_up_sw_expected) then - write(6, '(a,e16.7,a,e16.7)') & - 'Error: max diff of sfc_up_sw from expected value exceeds tolerance: ', & - abs(phys_state%fluxsw%sfc_up_sw - sfc_up_sw_expected), ' > ', tolerance * sfc_up_sw_expected - compare_data = .false. + if (maxval(abs(phys_state%effri - effri_expected)) > tolerance*effri_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effri from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effri - effri_expected)), ' > ', tolerance*effri_expected + compare_data = .false. end if - if (maxval(abs(phys_state%fluxsw%sfc_down_sw - sfc_down_sw_expected)) > tolerance * sfc_down_sw_expected) then - write(6, '(a,e16.7,a,e16.7)') & - 'Error: max diff of sfc_down_sw from expected value exceeds tolerance: ', & - abs(phys_state%fluxsw%sfc_down_sw - sfc_down_sw_expected), ' > ', tolerance * sfc_down_sw_expected - compare_data = .false. + if (maxval(abs( effrs - effrs_expected)) > tolerance*effrs_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of effrs from expected value exceeds tolerance: ', & + maxval(abs( effrs - effrs_expected)), ' > ', tolerance*effrs_expected + compare_data = .false. end if - if (maxval(abs(phys_state%fluxlw%sfc_up_lw - sfc_up_lw_expected)) > tolerance * sfc_up_lw_expected) then - write(6, '(a,e16.7,a,e16.7)') & - 'Error: max diff of sfc_up_lw from expected value exceeds tolerance: ', & - abs(phys_state%fluxlw%sfc_up_lw - sfc_up_lw_expected), ' > ', tolerance * sfc_up_lw_expected - compare_data = .false. + if (abs( phys_state%scalar_var - scalar_expected) > tolerance*scalar_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of scalar_var from expected value exceeds tolerance: ', & + abs( phys_state%scalar_var - scalar_expected), ' > ', tolerance*scalar_expected + compare_data = .false. end if - if (maxval(abs(phys_state%fluxlw%sfc_down_lw - sfc_down_lw_expected)) > tolerance * sfc_down_lw_expected) then - write(6, '(a,e16.7,a,e16.7)') & - 'Error: max diff of sfc_down_lw from expected value exceeds tolerance: ', & - abs(phys_state%fluxlw%sfc_down_lw - sfc_down_lw_expected), ' > ', tolerance * sfc_down_lw_expected - compare_data = .false. + if (abs( phys_state%tke - tke_expected) > tolerance*tke_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of tke from expected value exceeds tolerance: ', & + abs( phys_state%tke - tke_expected), ' > ', tolerance*tke_expected + compare_data = .false. end if + if (maxval(abs( phys_state%fluxSW%sfc_up_sw - sfc_up_sw_expected)) > tolerance*sfc_up_sw_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_up_sw from expected value exceeds tolerance: ', & + abs( phys_state%fluxSW%sfc_up_sw - sfc_up_sw_expected), ' > ', tolerance*sfc_up_sw_expected + compare_data = .false. + end if + + if (maxval(abs( phys_state%fluxSW%sfc_down_sw - sfc_down_sw_expected)) > tolerance*sfc_down_sw_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_down_sw from expected value exceeds tolerance: ', & + abs( phys_state%fluxSW%sfc_down_sw - sfc_down_sw_expected), ' > ', tolerance*sfc_down_sw_expected + compare_data = .false. + end if + + if (maxval(abs( phys_state%fluxLW%sfc_up_lw - sfc_up_lw_expected)) > tolerance*sfc_up_lw_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_up_lw from expected value exceeds tolerance: ', & + abs( phys_state%fluxLW%sfc_up_lw - sfc_up_lw_expected), ' > ', tolerance*sfc_up_lw_expected + compare_data = .false. + end if + + if (maxval(abs( phys_state%fluxLW%sfc_down_lw - sfc_down_lw_expected)) > tolerance*sfc_down_lw_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_down_lw from expected value exceeds tolerance: ', & + abs( phys_state%fluxLW%sfc_down_lw - sfc_down_lw_expected), ' > ', tolerance*sfc_down_lw_expected + compare_data = .false. + end if + end function compare_data end module test_host_mod diff --git a/test/var_compatibility_test/test_var_compatibility_integration.F90 b/test/var_compatibility_test/test_var_compatibility_integration.F90 index 36fb3404..1e081e10 100644 --- a/test/var_compatibility_test/test_var_compatibility_integration.F90 +++ b/test/var_compatibility_test/test_var_compatibility_integration.F90 @@ -1,88 +1,85 @@ program test_var_compatibility_integration - 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(1) = (/ 'radiation ' /) + character(len=cs), target :: test_parts1(1) = (/ 'radiation ' /) - character(len=cm), target :: test_invars1(18) = (/ & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'effective_radius_of_stratiform_cloud_graupel ', & - 'cloud_graupel_number_concentration ', & - 'scalar_variable_for_testing ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'scalar_variable_for_testing_a ', & - 'scalar_variable_for_testing_b ', & - 'scalar_variable_for_testing_c ', & - 'scheme_order_in_suite ', & - 'num_subcycles_for_effr ', & - 'flag_indicating_cloud_microphysics_has_graupel ', & - 'flag_indicating_cloud_microphysics_has_ice ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_invars1(18) = (/ & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'effective_radius_of_stratiform_cloud_graupel ', & + 'cloud_graupel_number_concentration ', & + 'scalar_variable_for_testing ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'scalar_variable_for_testing_a ', & + 'scalar_variable_for_testing_b ', & + 'scalar_variable_for_testing_c ', & + 'scheme_order_in_suite ', & + 'num_subcycles_for_effr ', & + 'flag_indicating_cloud_microphysics_has_graupel ', & + 'flag_indicating_cloud_microphysics_has_ice ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'longwave_radiation_fluxes '/) - character(len=cm), target :: test_outvars1(14) = (/ & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'effective_radius_of_stratiform_cloud_ice_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'cloud_ice_number_concentration ', & - 'scalar_variable_for_testing ', & - 'scheme_order_in_suite ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_outvars1(14) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'effective_radius_of_stratiform_cloud_ice_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'cloud_ice_number_concentration ', & + 'scalar_variable_for_testing ', & + 'scheme_order_in_suite ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'longwave_radiation_fluxes '/) - character(len=cm), target :: test_reqvars1(22) = (/ & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_ice_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'effective_radius_of_stratiform_cloud_graupel ', & - 'cloud_graupel_number_concentration ', & - 'cloud_ice_number_concentration ', & - 'scalar_variable_for_testing ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'scalar_variable_for_testing_a ', & - 'scalar_variable_for_testing_b ', & - 'scalar_variable_for_testing_c ', & - 'scheme_order_in_suite ', & - 'num_subcycles_for_effr ', & - 'flag_indicating_cloud_microphysics_has_graupel ', & - 'flag_indicating_cloud_microphysics_has_ice ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_reqvars1(22) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_ice_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'effective_radius_of_stratiform_cloud_graupel ', & + 'cloud_graupel_number_concentration ', & + 'cloud_ice_number_concentration ', & + 'scalar_variable_for_testing ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'scalar_variable_for_testing_a ', & + 'scalar_variable_for_testing_b ', & + 'scalar_variable_for_testing_c ', & + 'scheme_order_in_suite ', & + 'num_subcycles_for_effr ', & + 'flag_indicating_cloud_microphysics_has_graupel ', & + 'flag_indicating_cloud_microphysics_has_ice ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'longwave_radiation_fluxes '/) - type(suite_info) :: test_suites(1) - logical :: run_okay + type(suite_info) :: test_suites(1) + logical :: run_okay - ! Setup expected test suite info - test_suites(1)%suite_name = 'var_compatibility_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 + ! Setup expected test suite info + test_suites(1)%suite_name = 'var_compatibility_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 - 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_var_compatibility_integration diff --git a/test_prebuild/test_blocked_data/blocked_data_scheme.F90 b/test_prebuild/test_blocked_data/blocked_data_scheme.F90 index 77e1e687..eeda2206 100644 --- a/test_prebuild/test_blocked_data/blocked_data_scheme.F90 +++ b/test_prebuild/test_blocked_data/blocked_data_scheme.F90 @@ -4,123 +4,115 @@ module blocked_data_scheme - use, intrinsic :: iso_fortran_env, only: error_unit - implicit none + use, intrinsic :: iso_fortran_env, only: error_unit + implicit none - private - public :: blocked_data_scheme_init, & - blocked_data_scheme_timestep_init, & - blocked_data_scheme_run, & - blocked_data_scheme_timestep_finalize, & - blocked_data_scheme_finalize + private + public :: blocked_data_scheme_init, & + blocked_data_scheme_timestep_init, & + blocked_data_scheme_run, & + blocked_data_scheme_timestep_finalize, & + blocked_data_scheme_finalize - ! This is for unit testing only - integer, parameter, dimension(4) :: data_array_sizes = (/6, 6, 6, 3/) + ! This is for unit testing only + integer, parameter, dimension(4) :: data_array_sizes = (/6,6,6,3/) -contains + contains - !! \section arg_table_blocked_data_scheme_init Argument Table - !! \htmlinclude blocked_data_scheme_init.html - !! - subroutine blocked_data_scheme_init(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit, '(a,i3)') 'In blocked_data_scheme_init: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& - data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_init +!! \section arg_table_blocked_data_scheme_init Argument Table +!! \htmlinclude blocked_data_scheme_init.html +!! + subroutine blocked_data_scheme_init(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit,'(a,i3)') 'In blocked_data_scheme_init: checking size of data array to be', sum(data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_init - !! \section arg_table_blocked_data_scheme_timestep_init Argument Table - !! \htmlinclude blocked_data_scheme_timestep_init.html - !! - subroutine blocked_data_scheme_timestep_init(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit, '(a,i3)') 'In blocked_data_scheme_timestep_init: checking size of data array to be', sum(& - data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), " but got ", size(& - data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_timestep_init +!! \section arg_table_blocked_data_scheme_timestep_init Argument Table +!! \htmlinclude blocked_data_scheme_timestep_init.html +!! + subroutine blocked_data_scheme_timestep_init(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit,'(a,i3)') 'In blocked_data_scheme_timestep_init: checking size of data array to be', sum(data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), " but got ", size(data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_timestep_init - !! \section arg_table_blocked_data_scheme_run Argument Table - !! \htmlinclude blocked_data_scheme_run.html - !! - subroutine blocked_data_scheme_run(nb, data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nb - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit, '(2(a,i3))') 'In blocked_data_scheme_run: checking size of data array for block', nb, & - ' to be', data_array_sizes(nb) - if (size(data_array)/=data_array_sizes(nb)) then - write(errmsg, '(a,i4)') "Error in blocked_data_scheme_run, expected size(data_array)==6, got ", size(data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_run +!! \section arg_table_blocked_data_scheme_run Argument Table +!! \htmlinclude blocked_data_scheme_run.html +!! + subroutine blocked_data_scheme_run(nb, data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nb + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit,'(2(a,i3))') 'In blocked_data_scheme_run: checking size of data array for block', nb, ' to be', data_array_sizes(nb) + if (size(data_array)/=data_array_sizes(nb)) then + write(errmsg,'(a,i4)') "Error in blocked_data_scheme_run, expected size(data_array)==6, got ", size(data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_run - !! \section arg_table_blocked_data_scheme_timestep_finalize Argument Table - !! \htmlinclude blocked_data_scheme_timestep_finalize.html - !! - subroutine blocked_data_scheme_timestep_finalize(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit, '(a,i3)') 'In blocked_data_scheme_timestep_finalize: checking size of data array to be', sum(& - data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& - data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_timestep_finalize + !! \section arg_table_blocked_data_scheme_timestep_finalize Argument Table + !! \htmlinclude blocked_data_scheme_timestep_finalize.html + !! + subroutine blocked_data_scheme_timestep_finalize(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit,'(a,i3)') 'In blocked_data_scheme_timestep_finalize: checking size of data array to be', sum(data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_timestep_finalize - !! \section arg_table_blocked_data_scheme_finalize Argument Table - !! \htmlinclude blocked_data_scheme_finalize.html - !! - subroutine blocked_data_scheme_finalize(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit, '(a,i3)') 'In blocked_data_scheme_finalize: checking size of data array to be', sum(& - data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& - data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_finalize +!! \section arg_table_blocked_data_scheme_finalize Argument Table +!! \htmlinclude blocked_data_scheme_finalize.html +!! + subroutine blocked_data_scheme_finalize(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit,'(a,i3)') 'In blocked_data_scheme_finalize: checking size of data array to be', sum(data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_finalize end module blocked_data_scheme diff --git a/test_prebuild/test_blocked_data/data.F90 b/test_prebuild/test_blocked_data/data.F90 index 0d399f27..97ad051e 100644 --- a/test_prebuild/test_blocked_data/data.F90 +++ b/test_prebuild/test_blocked_data/data.F90 @@ -1,41 +1,41 @@ module data - !! \section arg_table_data Argument Table - !! \htmlinclude data.html - !! - use ccpp_types, only: ccpp_t +!! \section arg_table_data Argument Table +!! \htmlinclude data.html +!! + use ccpp_types, only: ccpp_t - implicit none + implicit none - private + private - public nblks, blksz, ncols - public ccpp_data_domain, ccpp_data_blocks, blocked_data_type, blocked_data_instance + public nblks, blksz, ncols + public ccpp_data_domain, ccpp_data_blocks, blocked_data_type, blocked_data_instance - integer, parameter :: nblks = 4 - type(ccpp_t), target :: ccpp_data_domain - type(ccpp_t), dimension(nblks), target :: ccpp_data_blocks + integer, parameter :: nblks = 4 + type(ccpp_t), target :: ccpp_data_domain + type(ccpp_t), dimension(nblks), target :: ccpp_data_blocks - integer, parameter, dimension(nblks) :: blksz = (/6, 6, 6, 3/) - integer, parameter :: ncols = sum(blksz) + integer, parameter, dimension(nblks) :: blksz = (/6,6,6,3/) + integer, parameter :: ncols = sum(blksz) - !! \section arg_table_blocked_data_type - !! \htmlinclude blocked_data_type.html - !! - type blocked_data_type - integer, dimension(:), allocatable :: array_data - contains - procedure :: create => blocked_data_create - end type blocked_data_type +!! \section arg_table_blocked_data_type +!! \htmlinclude blocked_data_type.html +!! + type blocked_data_type + integer, dimension(:), allocatable :: array_data + contains + procedure :: create => blocked_data_create + end type blocked_data_type - type(blocked_data_type), dimension(nblks) :: blocked_data_instance + type(blocked_data_type), dimension(nblks) :: blocked_data_instance contains - subroutine blocked_data_create(blocked_data_instance, ncol) - class(blocked_data_type), intent(inout) :: blocked_data_instance - integer, intent(in) :: ncol - allocate(blocked_data_instance%array_data(ncol)) - end subroutine blocked_data_create + subroutine blocked_data_create(blocked_data_instance, ncol) + class(blocked_data_type), intent(inout) :: blocked_data_instance + integer, intent(in) :: ncol + allocate(blocked_data_instance%array_data(ncol)) + end subroutine blocked_data_create end module data diff --git a/test_prebuild/test_blocked_data/main.F90 b/test_prebuild/test_blocked_data/main.F90 index 5b357b43..4711b3c9 100644 --- a/test_prebuild/test_blocked_data/main.F90 +++ b/test_prebuild/test_blocked_data/main.F90 @@ -1,117 +1,112 @@ program test_blocked_data - use, intrinsic :: iso_fortran_env, only: error_unit - - use ccpp_types, only: ccpp_t - use data, only: nblks, & - blksz, & - ncols - use data, only: ccpp_data_domain, & - ccpp_data_blocks, & - blocked_data_type, & - blocked_data_instance - - use ccpp_static_api, only: ccpp_physics_init, & - ccpp_physics_timestep_init, & - ccpp_physics_run, & - ccpp_physics_timestep_finalize, & - ccpp_physics_finalize - - implicit none - - character(len=*), parameter :: ccpp_suite = 'blocked_data_suite' - integer :: ib, ierr - type(ccpp_t), pointer :: cdata => null() - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! For physics running over the entire domain, - ! ccpp_thread_number and ccpp_chunk_number are - ! set to 1, indicating that arrays are to be sent - ! following their dimension specification in the - ! metadata (must match horizontal_dimension). - ccpp_data_domain%blk_no = 1 - ccpp_data_domain%thrd_no = 1 - ccpp_data_domain%thrd_cnt = 1 - - ! Loop over all blocks and threads for ccpp_data_blocks - do ib = 1, nblks - ! Assign the correct block numbers, only one thread - ccpp_data_blocks(ib)%blk_no = ib - ccpp_data_blocks(ib)%thrd_no = 1 - ccpp_data_blocks(ib)%thrd_cnt = 1 - end do - - do ib = 1, size(blocked_data_instance) - allocate(blocked_data_instance(ib)%array_data(blksz(ib))) - write(error_unit, '(2(a,i3))') "Allocated array_data for block", ib, " to size", size(blocked_data_instance(ib)%& - array_data) - end do - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_init:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics run step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - do ib = 1, nblks - cdata => ccpp_data_blocks(ib) - call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a,i3,a)') "An error occurred in ccpp_physics_run for block", ib, ":" - write(error_unit, '(a)') trim(cdata%errmsg) + use, intrinsic :: iso_fortran_env, only: error_unit + + use ccpp_types, only: ccpp_t + use data, only: nblks, blksz, ncols + use data, only: ccpp_data_domain, ccpp_data_blocks, & + blocked_data_type, blocked_data_instance + + use ccpp_static_api, only: ccpp_physics_init, & + ccpp_physics_timestep_init, & + ccpp_physics_run, & + ccpp_physics_timestep_finalize, & + ccpp_physics_finalize + + implicit none + + character(len=*), parameter :: ccpp_suite = 'blocked_data_suite' + integer :: ib, ierr + type(ccpp_t), pointer :: cdata => null() + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! For physics running over the entire domain, + ! ccpp_thread_number and ccpp_chunk_number are + ! set to 1, indicating that arrays are to be sent + ! following their dimension specification in the + ! metadata (must match horizontal_dimension). + ccpp_data_domain%blk_no = 1 + ccpp_data_domain%thrd_no = 1 + ccpp_data_domain%thrd_cnt = 1 + + ! Loop over all blocks and threads for ccpp_data_blocks + do ib=1,nblks + ! Assign the correct block numbers, only one thread + ccpp_data_blocks(ib)%blk_no = ib + ccpp_data_blocks(ib)%thrd_no = 1 + ccpp_data_blocks(ib)%thrd_cnt = 1 + end do + + do ib=1,size(blocked_data_instance) + allocate(blocked_data_instance(ib)%array_data(blksz(ib))) + write(error_unit,'(2(a,i3))') "Allocated array_data for block", ib, " to size", size(blocked_data_instance(ib)%array_data) + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_init:" + write(error_unit,'(a)') trim(cdata%errmsg) stop 1 - end if - end do - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_finalize:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_finalize:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics run step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do ib=1,nblks + cdata => ccpp_data_blocks(ib) + call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a,i3,a)') "An error occurred in ccpp_physics_run for block", ib, ":" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_finalize:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_finalize:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if contains -end program test_blocked_data +end program test_blocked_data \ No newline at end of file diff --git a/test_prebuild/test_chunked_data/chunked_data_scheme.F90 b/test_prebuild/test_chunked_data/chunked_data_scheme.F90 index 392167b2..1bb2a266 100644 --- a/test_prebuild/test_chunked_data/chunked_data_scheme.F90 +++ b/test_prebuild/test_chunked_data/chunked_data_scheme.F90 @@ -4,123 +4,115 @@ module chunked_data_scheme - use, intrinsic :: iso_fortran_env, only: error_unit - implicit none + use, intrinsic :: iso_fortran_env, only: error_unit + implicit none - private - public :: chunked_data_scheme_init, & - chunked_data_scheme_timestep_init, & - chunked_data_scheme_run, & - chunked_data_scheme_timestep_finalize, & - chunked_data_scheme_finalize + private + public :: chunked_data_scheme_init, & + chunked_data_scheme_timestep_init, & + chunked_data_scheme_run, & + chunked_data_scheme_timestep_finalize, & + chunked_data_scheme_finalize - ! This is for unit testing only - integer, parameter, dimension(4) :: data_array_sizes = (/6, 6, 6, 3/) + ! This is for unit testing only + integer, parameter, dimension(4) :: data_array_sizes = (/6,6,6,3/) -contains + contains - !! \section arg_table_chunked_data_scheme_init Argument Table - !! \htmlinclude chunked_data_scheme_init.html - !! - subroutine chunked_data_scheme_init(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit, '(a,i3)') 'In chunked_data_scheme_init: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& - data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_init +!! \section arg_table_chunked_data_scheme_init Argument Table +!! \htmlinclude chunked_data_scheme_init.html +!! + subroutine chunked_data_scheme_init(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit,'(a,i3)') 'In chunked_data_scheme_init: checking size of data array to be', sum(data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_init - !! \section arg_table_chunked_data_scheme_timestep_init Argument Table - !! \htmlinclude chunked_data_scheme_timestep_init.html - !! - subroutine chunked_data_scheme_timestep_init(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit, '(a,i3)') 'In chunked_data_scheme_timestep_init: checking size of data array to be', sum(& - data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), " but got ", size(& - data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_timestep_init +!! \section arg_table_chunked_data_scheme_timestep_init Argument Table +!! \htmlinclude chunked_data_scheme_timestep_init.html +!! + subroutine chunked_data_scheme_timestep_init(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit,'(a,i3)') 'In chunked_data_scheme_timestep_init: checking size of data array to be', sum(data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), " but got ", size(data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_timestep_init - !! \section arg_table_chunked_data_scheme_run Argument Table - !! \htmlinclude chunked_data_scheme_run.html - !! - subroutine chunked_data_scheme_run(nchunk, data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nchunk - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit, '(2(a,i3))') 'In chunked_data_scheme_run: checking size of data array for chunk', nchunk, & - ' to be', data_array_sizes(nchunk) - if (size(data_array)/=data_array_sizes(nchunk)) then - write(errmsg, '(a,i4)') "Error in chunked_data_scheme_run, expected size(data_array)==6, got ", size(data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_run +!! \section arg_table_chunked_data_scheme_run Argument Table +!! \htmlinclude chunked_data_scheme_run.html +!! + subroutine chunked_data_scheme_run(nchunk, data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nchunk + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit,'(2(a,i3))') 'In chunked_data_scheme_run: checking size of data array for chunk', nchunk, ' to be', data_array_sizes(nchunk) + if (size(data_array)/=data_array_sizes(nchunk)) then + write(errmsg,'(a,i4)') "Error in chunked_data_scheme_run, expected size(data_array)==6, got ", size(data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_run - !! \section arg_table_chunked_data_scheme_timestep_finalize Argument Table - !! \htmlinclude chunked_data_scheme_timestep_finalize.html - !! - subroutine chunked_data_scheme_timestep_finalize(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit, '(a,i3)') 'In chunked_data_scheme_timestep_finalize: checking size of data array to be', sum(& - data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& - data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_timestep_finalize + !! \section arg_table_chunked_data_scheme_timestep_finalize Argument Table + !! \htmlinclude chunked_data_scheme_timestep_finalize.html + !! + subroutine chunked_data_scheme_timestep_finalize(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit,'(a,i3)') 'In chunked_data_scheme_timestep_finalize: checking size of data array to be', sum(data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_timestep_finalize - !! \section arg_table_chunked_data_scheme_finalize Argument Table - !! \htmlinclude chunked_data_scheme_finalize.html - !! - subroutine chunked_data_scheme_finalize(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit, '(a,i3)') 'In chunked_data_scheme_finalize: checking size of data array to be', sum(& - data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& - data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_finalize +!! \section arg_table_chunked_data_scheme_finalize Argument Table +!! \htmlinclude chunked_data_scheme_finalize.html +!! + subroutine chunked_data_scheme_finalize(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit,'(a,i3)') 'In chunked_data_scheme_finalize: checking size of data array to be', sum(data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_finalize end module chunked_data_scheme diff --git a/test_prebuild/test_chunked_data/data.F90 b/test_prebuild/test_chunked_data/data.F90 index 82c4abac..8fbf21ed 100644 --- a/test_prebuild/test_chunked_data/data.F90 +++ b/test_prebuild/test_chunked_data/data.F90 @@ -1,43 +1,43 @@ module data - !! \section arg_table_dATa Argument Table - !! \htmlinclude datA.Html - !! - use ccpp_types, only: ccpp_t +!! \section arg_table_dATa Argument Table +!! \htmlinclude datA.Html +!! + use ccpp_types, only: ccpp_t - implicit none + implicit none - private + private - public nchunks, chunksize, chunk_begin, chunk_end, ncols - public ccpp_data_domain, ccpp_data_chunks, chunked_data_type, chunked_data_instance + public nchunks, chunksize, chunk_begin, chunk_end, ncols + public ccpp_data_domain, ccpp_data_chunks, chunked_data_type, chunked_data_instance - integer, parameter :: nchunks = 4 - type(ccpp_t), target :: ccpp_data_domain - type(ccpp_t), dimension(nchunks), target :: ccpp_data_chunks + integer, parameter :: nchunks = 4 + type(ccpp_t), target :: ccpp_data_domain + type(ccpp_t), dimension(nchunks), target :: ccpp_data_chunks - integer, parameter, dimension(nchunks) :: chunksize = (/6, 6, 6, 3/) - integer, parameter, dimension(nchunks) :: chunk_begin = (/1, 7, 13, 19/) - integer, parameter, dimension(nchunks) :: chunk_end = (/6, 12, 18, 21/) - integer, parameter :: ncols = sum(chunksize) + integer, parameter, dimension(nchunks) :: chunksize = (/6,6,6,3/) + integer, parameter, dimension(nchunks) :: chunk_begin = (/1,7,13,19/) + integer, parameter, dimension(nchunks) :: chunk_end = (/6,12,18,21/) + integer, parameter :: ncols = sum(chunksize) - !! \section arg_table_cHuNkEd_dATa_TYPe - !! \htmlinclude CHuNKed_Data_tYpe.hTMl - !! - type chunked_data_type - integer, dimension(:), allocatable :: array_data - contains - procedure :: create => chunked_data_create - end type chunked_data_type +!! \section arg_table_cHuNkEd_dATa_TYPe +!! \htmlinclude CHuNKed_Data_tYpe.hTMl +!! + type chunked_data_type + integer, dimension(:), allocatable :: array_data + contains + procedure :: create => chunked_data_create + end type chunked_data_type - type(chunked_data_type) :: chunked_data_instance + type(chunked_data_type) :: chunked_data_instance contains - subroutine chunked_data_create(chunked_data_instance, ncol) - class(chunked_data_type), intent(inout) :: chunked_data_instance - integer, intent(in) :: ncol - allocate(chunked_data_instance%array_data(ncol)) - end subroutine chunked_data_create + subroutine chunked_data_create(chunked_data_instance, ncol) + class(chunked_data_type), intent(inout) :: chunked_data_instance + integer, intent(in) :: ncol + allocate(chunked_data_instance%array_data(ncol)) + end subroutine chunked_data_create end module data diff --git a/test_prebuild/test_chunked_data/main.F90 b/test_prebuild/test_chunked_data/main.F90 index da96d1d1..a1af449b 100644 --- a/test_prebuild/test_chunked_data/main.F90 +++ b/test_prebuild/test_chunked_data/main.F90 @@ -1,114 +1,110 @@ program test_chunked_data - use, intrinsic :: iso_fortran_env, only: error_unit - - use ccpp_types, only: ccpp_t - use data, only: nchunks, & - chunksize, & - ncols - use data, only: ccpp_data_domain, & - ccpp_data_chunks, & - chunked_data_type, & - chunked_data_instance - - use ccpp_static_api, only: ccpp_physics_init, & - ccpp_physics_timestep_init, & - ccpp_physics_run, & - ccpp_physics_timestep_finalize, & - ccpp_physics_finalize - - implicit none - - character(len=*), parameter :: ccpp_suite = 'chunked_data_suite' - integer :: ic, ierr - type(ccpp_t), pointer :: cdata => null() - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! For physics running over the entire domain, - ! ccpp_thread_number and ccpp_chunk_number are - ! set to 1, indicating that arrays are to be sent - ! following their dimension specification in the - ! metadata (must match horizontal_dimension). - ccpp_data_domain%thrd_no = 1 - ccpp_data_domain%chunk_no = 1 - ccpp_data_domain%thrd_cnt = 1 - - ! Loop over all chunks and threads for ccpp_data_chunks - do ic = 1, nchunks - ! Assign the correct chunk numbers, only one thread - ccpp_data_chunks(ic)%chunk_no = ic - ccpp_data_chunks(ic)%thrd_no = 1 - ccpp_data_chunks(ic)%thrd_cnt = 1 - end do - - call chunked_data_instance%create(ncols) - write(error_unit, '(2(a,i3))') "Chunked_data_instance%array_data to size", size(chunked_data_instance%array_data) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_init:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics run step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - do ic = 1, nchunks - cdata => ccpp_data_chunks(ic) - call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a,i3,a)') "An error occurred in ccpp_physics_run for chunk", ic, ":" - write(error_unit, '(a)') trim(cdata%errmsg) + use, intrinsic :: iso_fortran_env, only: error_unit + + use ccpp_types, only: ccpp_t + use data, only: nchunks, chunksize, ncols + use data, only: ccpp_data_domain, ccpp_data_chunks, & + chunked_data_type, chunked_data_instance + + use ccpp_static_api, only: ccpp_physics_init, & + ccpp_physics_timestep_init, & + ccpp_physics_run, & + ccpp_physics_timestep_finalize, & + ccpp_physics_finalize + + implicit none + + character(len=*), parameter :: ccpp_suite = 'chunked_data_suite' + integer :: ic, ierr + type(ccpp_t), pointer :: cdata => null() + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! For physics running over the entire domain, + ! ccpp_thread_number and ccpp_chunk_number are + ! set to 1, indicating that arrays are to be sent + ! following their dimension specification in the + ! metadata (must match horizontal_dimension). + ccpp_data_domain%thrd_no = 1 + ccpp_data_domain%chunk_no = 1 + ccpp_data_domain%thrd_cnt = 1 + + ! Loop over all chunks and threads for ccpp_data_chunks + do ic=1,nchunks + ! Assign the correct chunk numbers, only one thread + ccpp_data_chunks(ic)%chunk_no = ic + ccpp_data_chunks(ic)%thrd_no = 1 + ccpp_data_chunks(ic)%thrd_cnt = 1 + end do + + call chunked_data_instance%create(ncols) + write(error_unit,'(2(a,i3))') "Chunked_data_instance%array_data to size", size(chunked_data_instance%array_data) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_init:" + write(error_unit,'(a)') trim(cdata%errmsg) stop 1 - end if - end do - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_finalize:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_finalize:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics run step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do ic=1,nchunks + cdata => ccpp_data_chunks(ic) + call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a,i3,a)') "An error occurred in ccpp_physics_run for chunk", ic, ":" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_finalize:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_finalize:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if contains -end program test_chunked_data +end program test_chunked_data \ No newline at end of file diff --git a/test_prebuild/test_opt_arg/ccpp_kinds.F90 b/test_prebuild/test_opt_arg/ccpp_kinds.F90 index a07ded9b..cf6bfeaf 100644 --- a/test_prebuild/test_opt_arg/ccpp_kinds.F90 +++ b/test_prebuild/test_opt_arg/ccpp_kinds.F90 @@ -1,13 +1,13 @@ module ccpp_kinds - !! \section arg_table_ccpp_kinds - !! \htmlinclude ccpp_kinds.html - !! +!! \section arg_table_ccpp_kinds +!! \htmlinclude ccpp_kinds.html +!! - use iso_fortran_env, only: real64 + use iso_fortran_env, only: real64 - implicit none + implicit none - integer, parameter :: kind_phys = real64 + integer, parameter :: kind_phys = real64 end module ccpp_kinds diff --git a/test_prebuild/test_opt_arg/data.F90 b/test_prebuild/test_opt_arg/data.F90 index f66cf8c1..e16051fd 100644 --- a/test_prebuild/test_opt_arg/data.F90 +++ b/test_prebuild/test_opt_arg/data.F90 @@ -1,23 +1,23 @@ module data - !! \section arg_table_data Argument Table - !! \htmlinclude data.html - !! - use ccpp_types, only: ccpp_t - use ccpp_kinds, only: kind_phys +!! \section arg_table_data Argument Table +!! \htmlinclude data.html +!! + use ccpp_types, only: ccpp_t + use ccpp_kinds, only: kind_phys - implicit none + implicit none - private + private - public cdata, nx, flag_for_opt_arg, std_arg, opt_arg, opt_arg_2 + public cdata, nx, flag_for_opt_arg, std_arg, opt_arg, opt_arg_2 - type(ccpp_t), target :: cdata - integer, parameter :: nx = 3 - logical :: flag_for_opt_arg + type(ccpp_t), target :: cdata + integer, parameter :: nx = 3 + logical :: flag_for_opt_arg - integer, dimension(nx) :: std_arg - integer, dimension(:), allocatable :: opt_arg - real(kind=kind_phys), dimension(:), allocatable :: opt_arg_2 + integer, dimension(nx) :: std_arg + integer, dimension(:), allocatable :: opt_arg + real(kind=kind_phys), dimension(:), allocatable :: opt_arg_2 end module data diff --git a/test_prebuild/test_opt_arg/main.F90 b/test_prebuild/test_opt_arg/main.F90 index 7716c077..932958bc 100644 --- a/test_prebuild/test_opt_arg/main.F90 +++ b/test_prebuild/test_opt_arg/main.F90 @@ -1,127 +1,119 @@ program test_opt_arg - use, intrinsic :: iso_fortran_env, only: output_unit, & - error_unit - - use ccpp_types, only: ccpp_t - use data, only: cdata, & - nx, & - flag_for_opt_arg, & - std_arg, & - opt_arg, & - opt_arg_2 - - use ccpp_static_api, only: ccpp_physics_init, & - ccpp_physics_timestep_init, & - ccpp_physics_run, & - ccpp_physics_timestep_finalize, & - ccpp_physics_finalize - - implicit none - - character(len=*), parameter :: ccpp_suite = 'opt_arg_suite' - integer :: ierr - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata%blk_no = 1 - cdata%thrd_no = 1 - cdata%thrd_cnt = 1 - - std_arg = 1 - flag_for_opt_arg = .true. - allocate(opt_arg(nx)) - allocate(opt_arg_2(nx)) - - ! std_arg must all be 1, opt_arg must all be 0 - write(output_unit, '(a)') "After ccpp_init: check std_arg(:)==1, opt_arg(:)==0, opt_arg_2(:)==0" - if ( .not. all(std_arg == 1)) write(error_unit, '(a,3i3)') "Error after ccpp_init: std_arg=", std_arg - if ( .not. all(opt_arg == 0)) write(error_unit, '(a,3i3)') "Error after ccpp_init: opt_arg=", opt_arg - if ( .not. all(opt_arg_2 == 0)) write(error_unit, '(a,3i3)') "Error after ccpp_init: opt_arg_2=", opt_arg_2 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_init:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 1, opt_arg must all be 0 - write(output_unit, '(a)') "After ccpp_physics_init: check std_arg(:)==1 and opt_arg(:)==0" - if ( .not. all(std_arg == 1)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_init: std_arg=", std_arg - if ( .not. all(opt_arg == 0)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_init: opt_arg=", opt_arg - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 1, opt_arg must all be 2 - write(output_unit, '(a)') "After ccpp_physics_timestep_init: check std_arg(:)==1 and opt_arg(:)==2" - if ( .not. all(std_arg == 1)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_timestep_init: std_arg=", std_arg - if ( .not. all(opt_arg == 2)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_timestep_init: opt_arg=", opt_arg - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics run step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_run:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 1, opt_arg must all be 3 - write(output_unit, '(a)') "After ccpp_physics_run: check std_arg(:)==1 and opt_arg(:)==3" - if ( .not. all(std_arg == 1)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_run: std_arg=", std_arg - if ( .not. all(opt_arg == 3)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_run: opt_arg=", opt_arg - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - deallocate(opt_arg) - flag_for_opt_arg = .false. - - call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 7, opt_arg no longer allocated - write(output_unit, '(a)') "After ccpp_physics_timestep_final: check std_arg(:)==7; opt_arg not allocated" - if ( .not. all(std_arg == 7)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_timestep_final: std_arg=", & - std_arg - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 7, opt_arg no longer allocated - write(output_unit, '(a)') "After ccpp_physics_timestep_final: check std_arg(:)==7; opt_arg not allocated" - if ( .not. all(std_arg == 7)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_timestep_final: std_arg=", & - std_arg + use, intrinsic :: iso_fortran_env, only: output_unit, error_unit + + use ccpp_types, only: ccpp_t + use data, only: cdata, nx, flag_for_opt_arg, std_arg, opt_arg, opt_arg_2 + + use ccpp_static_api, only: ccpp_physics_init, & + ccpp_physics_timestep_init, & + ccpp_physics_run, & + ccpp_physics_timestep_finalize, & + ccpp_physics_finalize + + implicit none + + character(len=*), parameter :: ccpp_suite = 'opt_arg_suite' + integer :: ierr + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata%blk_no = 1 + cdata%thrd_no = 1 + cdata%thrd_cnt = 1 + + std_arg = 1 + flag_for_opt_arg = .true. + allocate(opt_arg(nx)) + allocate(opt_arg_2(nx)) + + ! std_arg must all be 1, opt_arg must all be 0 + write(output_unit,'(a)') "After ccpp_init: check std_arg(:)==1, opt_arg(:)==0, opt_arg_2(:)==0" + if (.not. all(std_arg .eq. 1)) write(error_unit,'(a,3i3)') "Error after ccpp_init: std_arg=", std_arg + if (.not. all(opt_arg .eq. 0)) write(error_unit,'(a,3i3)') "Error after ccpp_init: opt_arg=", opt_arg + if (.not. all(opt_arg_2 .eq. 0)) write(error_unit,'(a,3i3)') "Error after ccpp_init: opt_arg_2=", opt_arg_2 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_init:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 1, opt_arg must all be 0 + write(output_unit,'(a)') "After ccpp_physics_init: check std_arg(:)==1 and opt_arg(:)==0" + if (.not. all(std_arg .eq. 1)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_init: std_arg=", std_arg + if (.not. all(opt_arg .eq. 0)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_init: opt_arg=", opt_arg + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 1, opt_arg must all be 2 + write(output_unit,'(a)') "After ccpp_physics_timestep_init: check std_arg(:)==1 and opt_arg(:)==2" + if (.not. all(std_arg .eq. 1)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_timestep_init: std_arg=", std_arg + if (.not. all(opt_arg .eq. 2)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_timestep_init: opt_arg=", opt_arg + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics run step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_run:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 1, opt_arg must all be 3 + write(output_unit,'(a)') "After ccpp_physics_run: check std_arg(:)==1 and opt_arg(:)==3" + if (.not. all(std_arg .eq. 1)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_run: std_arg=", std_arg + if (.not. all(opt_arg .eq. 3)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_run: opt_arg=", opt_arg + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + deallocate(opt_arg) + flag_for_opt_arg = .false. + + call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 7, opt_arg no longer allocated + write(output_unit,'(a)') "After ccpp_physics_timestep_final: check std_arg(:)==7; opt_arg not allocated" + if (.not. all(std_arg .eq. 7)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_timestep_final: std_arg=", std_arg + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 7, opt_arg no longer allocated + write(output_unit,'(a)') "After ccpp_physics_timestep_final: check std_arg(:)==7; opt_arg not allocated" + if (.not. all(std_arg .eq. 7)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_timestep_final: std_arg=", std_arg end program test_opt_arg diff --git a/test_prebuild/test_opt_arg/opt_arg_scheme.F90 b/test_prebuild/test_opt_arg/opt_arg_scheme.F90 index 33be0973..1a36fffd 100644 --- a/test_prebuild/test_opt_arg/opt_arg_scheme.F90 +++ b/test_prebuild/test_opt_arg/opt_arg_scheme.F90 @@ -4,87 +4,87 @@ module opt_arg_scheme - use, intrinsic :: iso_fortran_env, only: error_unit - use ccpp_kinds, only: kind_phys + use, intrinsic :: iso_fortran_env, only: error_unit + use ccpp_kinds, only: kind_phys - implicit none + implicit none - private - public :: opt_arg_scheme_timestep_init, & - opt_arg_scheme_run, & - opt_arg_scheme_timestep_finalize + private + public :: opt_arg_scheme_timestep_init, & + opt_arg_scheme_run, & + opt_arg_scheme_timestep_finalize -contains + contains - !! \section arg_table_opt_arg_scheme_timestep_init Argument Table - !! \htmlinclude opt_arg_scheme_timestep_init.html - !! - subroutine opt_arg_scheme_timestep_init(nx, var, opt_var, opt_var_2, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nx - integer, intent(in) :: var(:) - integer, optional, intent(out) :: opt_var(:) - real(kind=kind_phys), optional, intent(out) :: opt_var_2(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Initialize opt_var from var if opt_var if present - if (present(opt_var)) then - opt_var = 2 * var - end if - ! Initialize opt_var_2 from var if opt_var_2 present - if (present(opt_var_2)) then - opt_var_2 = 3.0_kind_phys * var - end if - end subroutine opt_arg_scheme_timestep_init +!! \section arg_table_opt_arg_scheme_timestep_init Argument Table +!! \htmlinclude opt_arg_scheme_timestep_init.html +!! + subroutine opt_arg_scheme_timestep_init(nx, var, opt_var, opt_var_2, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nx + integer, intent(in) :: var(:) + integer, optional, intent(out) :: opt_var(:) + real(kind=kind_phys), optional, intent(out) :: opt_var_2(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Initialize opt_var from var if opt_var if present + if (present(opt_var)) then + opt_var = 2*var + end if + ! Initialize opt_var_2 from var if opt_var_2 present + if (present(opt_var_2)) then + opt_var_2 = 3.0_kind_phys*var + end if + end subroutine opt_arg_scheme_timestep_init - !! \section arg_table_opt_arg_scheme_run Argument Table - !! \htmlinclude opt_arg_scheme_run.html - !! - subroutine opt_arg_scheme_run(nx, var, opt_var, opt_var_2, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nx - integer, intent(in) :: var(:) - integer, optional, intent(inout) :: opt_var(:) - real(kind=kind_phys), optional, intent(inout) :: opt_var_2(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Update opt_var from var if opt_var present - if (present(opt_var)) then - opt_var = 3 * var - end if - ! Update opt_var_2 from var if opt_var_2 present - if (present(opt_var_2)) then - opt_var_2 = 4.0_kind_phys * var - end if - end subroutine opt_arg_scheme_run +!! \section arg_table_opt_arg_scheme_run Argument Table +!! \htmlinclude opt_arg_scheme_run.html +!! + subroutine opt_arg_scheme_run(nx, var, opt_var, opt_var_2, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nx + integer, intent(in) :: var(:) + integer, optional, intent(inout) :: opt_var(:) + real(kind=kind_phys), optional, intent(inout) :: opt_var_2(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Update opt_var from var if opt_var present + if (present(opt_var)) then + opt_var = 3*var + end if + ! Update opt_var_2 from var if opt_var_2 present + if (present(opt_var_2)) then + opt_var_2 = 4.0_kind_phys*var + end if + end subroutine opt_arg_scheme_run - !! \section arg_table_opt_arg_scheme_timestep_finalize Argument Table - !! \htmlinclude opt_arg_scheme_timestep_finalize.html - !! - subroutine opt_arg_scheme_timestep_finalize(nx, var, opt_var, opt_var_2, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nx - integer, intent(inout) :: var(:) - integer, optional, intent(in) :: opt_var(:) - real(kind=kind_phys), optional, intent(inout) :: opt_var_2(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Update var from opt_var if opt_var is present - if (present(opt_var)) then - var = 4 * opt_var - else - var = 7 * var - end if - ! Update opt_var_2 if present - if (present(opt_var_2)) then - opt_var_2 = opt_var_2 + 5.0_kind_phys - end if - end subroutine opt_arg_scheme_timestep_finalize +!! \section arg_table_opt_arg_scheme_timestep_finalize Argument Table +!! \htmlinclude opt_arg_scheme_timestep_finalize.html +!! + subroutine opt_arg_scheme_timestep_finalize(nx, var, opt_var, opt_var_2, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nx + integer, intent(inout) :: var(:) + integer, optional, intent(in) :: opt_var(:) + real(kind=kind_phys), optional, intent(inout) :: opt_var_2(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Update var from opt_var if opt_var is present + if (present(opt_var)) then + var = 4*opt_var + else + var = 7*var + end if + ! Update opt_var_2 if present + if (present(opt_var_2)) then + opt_var_2 = opt_var_2 + 5.0_kind_phys + end if + end subroutine opt_arg_scheme_timestep_finalize end module opt_arg_scheme diff --git a/test_prebuild/test_unit_conv/ccpp_kinds.F90 b/test_prebuild/test_unit_conv/ccpp_kinds.F90 index a07ded9b..cf6bfeaf 100644 --- a/test_prebuild/test_unit_conv/ccpp_kinds.F90 +++ b/test_prebuild/test_unit_conv/ccpp_kinds.F90 @@ -1,13 +1,13 @@ module ccpp_kinds - !! \section arg_table_ccpp_kinds - !! \htmlinclude ccpp_kinds.html - !! +!! \section arg_table_ccpp_kinds +!! \htmlinclude ccpp_kinds.html +!! - use iso_fortran_env, only: real64 + use iso_fortran_env, only: real64 - implicit none + implicit none - integer, parameter :: kind_phys = real64 + integer, parameter :: kind_phys = real64 end module ccpp_kinds diff --git a/test_prebuild/test_unit_conv/data.F90 b/test_prebuild/test_unit_conv/data.F90 index ad6db921..645a531b 100644 --- a/test_prebuild/test_unit_conv/data.F90 +++ b/test_prebuild/test_unit_conv/data.F90 @@ -1,24 +1,24 @@ module data - !! \section arg_table_data Argument Table - !! \htmlinclude data.html - !! - use ccpp_kinds, only : kind_phys - use ccpp_types, only: ccpp_t +!! \section arg_table_data Argument Table +!! \htmlinclude data.html +!! + use ccpp_kinds, only : kind_phys + use ccpp_types, only: ccpp_t - implicit none + implicit none - private + private - public ncols, ncolsrun, nspecies - public cdata, data_array, data_array2, opt_array_flag + public ncols, ncolsrun, nspecies + public cdata, data_array, data_array2, opt_array_flag - integer, parameter :: ncols = 4 - integer, parameter :: ncolsrun = ncols - integer, parameter :: nspecies = 2 - type(ccpp_t), target :: cdata - real(kind=kind_phys), dimension(1:ncols, 1:nspecies) :: data_array - real(kind=kind_phys), dimension(1:ncols) :: data_array2 - logical :: opt_array_flag + integer, parameter :: ncols = 4 + integer, parameter :: ncolsrun = ncols + integer, parameter :: nspecies = 2 + type(ccpp_t), target :: cdata + real(kind_phys), dimension(1:ncols,1:nspecies) :: data_array + real(kind_phys), dimension(1:ncols) :: data_array2 + logical :: opt_array_flag end module data diff --git a/test_prebuild/test_unit_conv/main.F90 b/test_prebuild/test_unit_conv/main.F90 index dabcebac..3eb6462e 100644 --- a/test_prebuild/test_unit_conv/main.F90 +++ b/test_prebuild/test_unit_conv/main.F90 @@ -1,96 +1,92 @@ program test_unit_conv - use, intrinsic :: iso_fortran_env, only: error_unit - - use ccpp_types, only: ccpp_t - use data, only: ncols, & - nspecies - use data, only: cdata, & - data_array, & - data_array2, & - opt_array_flag - - use ccpp_static_api, only: ccpp_physics_init, & - ccpp_physics_timestep_init, & - ccpp_physics_run, & - ccpp_physics_timestep_finalize, & - ccpp_physics_finalize - - implicit none - - character(len=*), parameter :: ccpp_suite = 'unit_conv_suite' - integer :: ierr - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! For physics running over the entire domain, - ! ccpp_thread_number and ccpp_chunk_number are - ! set to 1, indicating that arrays are to be sent - ! following their dimension specification in the - ! metadata (must match horizontal_dimension). - cdata%thrd_no = 1 - cdata%chunk_no = 1 - cdata%thrd_cnt = 1 - - data_array = 1.0_8 - data_array2 = 42.0_8 - opt_array_flag = .true. - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_init:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics run step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_run:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_finalize:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit, '(a)') trim(cdata%errmsg) - stop 1 - end if + use, intrinsic :: iso_fortran_env, only: error_unit + + use ccpp_types, only: ccpp_t + use data, only: ncols, nspecies + use data, only: cdata, data_array, data_array2, opt_array_flag + + use ccpp_static_api, only: ccpp_physics_init, & + ccpp_physics_timestep_init, & + ccpp_physics_run, & + ccpp_physics_timestep_finalize, & + ccpp_physics_finalize + + implicit none + + character(len=*), parameter :: ccpp_suite = 'unit_conv_suite' + integer :: ierr + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! For physics running over the entire domain, + ! ccpp_thread_number and ccpp_chunk_number are + ! set to 1, indicating that arrays are to be sent + ! following their dimension specification in the + ! metadata (must match horizontal_dimension). + cdata%thrd_no = 1 + cdata%chunk_no = 1 + cdata%thrd_cnt = 1 + + data_array = 1.0_8 + data_array2 = 42.0_8 + opt_array_flag = .true. + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_init:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics run step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_run:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_finalize:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit,'(a)') trim(cdata%errmsg) + stop 1 + end if contains diff --git a/test_prebuild/test_unit_conv/unit_conv_scheme_1.F90 b/test_prebuild/test_unit_conv/unit_conv_scheme_1.F90 index 5ef02560..9ef178ff 100644 --- a/test_prebuild/test_unit_conv/unit_conv_scheme_1.F90 +++ b/test_prebuild/test_unit_conv/unit_conv_scheme_1.F90 @@ -4,67 +4,62 @@ module unit_conv_scheme_1 - use, intrinsic :: iso_fortran_env, only: error_unit - use ccpp_kinds, only : kind_phys - implicit none + use, intrinsic :: iso_fortran_env, only: error_unit + use ccpp_kinds, only : kind_phys + implicit none - private - public :: unit_conv_scheme_1_run + private + public :: unit_conv_scheme_1_run - !! This is for unit testing only - real(kind=kind_phys), parameter :: target_value = 1.0_kind_phys - real(kind=kind_phys), parameter :: target_value2 = 42.0_kind_phys + !! This is for unit testing only + real(kind_phys), parameter :: target_value = 1.0_kind_phys + real(kind_phys), parameter :: target_value2 = 42.0_kind_phys -contains + contains - !! \section arg_table_unit_conv_scheme_1_run Argument Table - !! \htmlinclude unit_conv_scheme_1_run.html - !! - subroutine unit_conv_scheme_1_run(data_array, data_array2, data_array_opt, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - real(kind=kind_phys), intent(inout) :: data_array(:) - real(kind=kind_phys), intent(inout) :: data_array2(:) - real(kind=kind_phys), intent(inout), optional :: data_array_opt(:) +!! \section arg_table_unit_conv_scheme_1_run Argument Table +!! \htmlinclude unit_conv_scheme_1_run.html +!! + subroutine unit_conv_scheme_1_run(data_array, data_array2, data_array_opt, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind_phys), intent(inout) :: data_array(:) + real(kind_phys), intent(inout) :: data_array2(:) + real(kind_phys), intent(inout), optional :: data_array_opt(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check values in data array - write(error_unit, '(a,e12.4)') & - 'In unit_conv_scheme_1_run: checking min/max values of data array to be approximately ', target_value - if (minval(data_array) < 0.99 * target_value .or. maxval(data_array) > 1.01 * target_value) then - write(errmsg, '(3(a,e12.4),a)') & - "Error in unit_conv_scheme_1_run, expected values for data_array of approximately ", & - target_value, " but got [ ", minval(data_array), " : ", maxval(data_array), " ]" - errflg = 1 - return - end if - ! Check values in data array2 - write(error_unit, '(a,e12.4)') & - 'In unit_conv_scheme_1_run: checking min/max values of data array 2 to be approximately ', target_value2 - if (minval(data_array2) < 0.99 * target_value2 .or. maxval(data_array2) > 1.01 * target_value2) then - write(errmsg, '(3(a,e12.4),a)') & - "Error in unit_conv_scheme_1_run, expected values for data array 2 of approximately ", & - target_value2, " but got [ ", minval(data_array2), " : ", maxval(data_array2), " ]" - errflg = 1 - return - end if - ! Check for presence of optional data array, then check its values - write(error_unit, '(a)') 'In unit_conv_scheme_1_run: checking for presence of optional data array' - if ( .not. present(data_array_opt)) then - write(error_unit, '(a)') 'Error in unit_conv_scheme_1_run, optional data array expected but not present' - errflg = 1 - return - end if - write(error_unit, '(a,e12.4)') & - 'In unit_conv_scheme_1_run: checking min/max values of optional data array to be approximately ', target_value - if (minval(data_array_opt) < 0.99 * target_value .or. maxval(data_array_opt) > 1.01 * target_value) then - write(errmsg, '(3(a,e12.4),a)') 'Error in unit_conv_scheme_1_run, expected values of approximately ', & - target_value, ' but got [ ', minval(data_array_opt), ' : ', maxval(data_array_opt), ' ]' - errflg = 1 - return - end if - end subroutine unit_conv_scheme_1_run + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check values in data array + write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_1_run: checking min/max values of data array to be approximately ', target_value + if (minval(data_array)<0.99*target_value .or. maxval(data_array)>1.01*target_value) then + write(errmsg,'(3(a,e12.4),a)') "Error in unit_conv_scheme_1_run, expected values for data_array of approximately ", & + target_value, " but got [ ", minval(data_array), " : ", maxval(data_array), " ]" + errflg = 1 + return + end if + ! Check values in data array2 + write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_1_run: checking min/max values of data array 2 to be approximately ', target_value2 + if (minval(data_array2)<0.99*target_value2 .or. maxval(data_array2)>1.01*target_value2) then + write(errmsg,'(3(a,e12.4),a)') "Error in unit_conv_scheme_1_run, expected values for data array 2 of approximately ", & + target_value2, " but got [ ", minval(data_array2), " : ", maxval(data_array2), " ]" + errflg = 1 + return + end if + ! Check for presence of optional data array, then check its values + write(error_unit,'(a)') 'In unit_conv_scheme_1_run: checking for presence of optional data array' + if (.not. present(data_array_opt)) then + write(error_unit,'(a)') 'Error in unit_conv_scheme_1_run, optional data array expected but not present' + errflg = 1 + return + endif + write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_1_run: checking min/max values of optional data array to be approximately ', target_value + if (minval(data_array_opt)<0.99*target_value .or. maxval(data_array_opt)>1.01*target_value) then + write(errmsg,'(3(a,e12.4),a)') 'Error in unit_conv_scheme_1_run, expected values of approximately ', & + target_value, ' but got [ ', minval(data_array_opt), ' : ', maxval(data_array_opt), ' ]' + errflg = 1 + return + end if + end subroutine unit_conv_scheme_1_run end module unit_conv_scheme_1 diff --git a/test_prebuild/test_unit_conv/unit_conv_scheme_2.F90 b/test_prebuild/test_unit_conv/unit_conv_scheme_2.F90 index ddeee342..66f07d93 100644 --- a/test_prebuild/test_unit_conv/unit_conv_scheme_2.F90 +++ b/test_prebuild/test_unit_conv/unit_conv_scheme_2.F90 @@ -4,66 +4,62 @@ module unit_conv_scheme_2 - use, intrinsic :: iso_fortran_env, only: error_unit - use ccpp_kinds, only : kind_phys - implicit none + use, intrinsic :: iso_fortran_env, only: error_unit + use ccpp_kinds, only : kind_phys + implicit none - private - public :: unit_conv_scheme_2_run + private + public :: unit_conv_scheme_2_run - !! This is for unit testing only - real(kind=kind_phys), parameter :: target_value = 1.0E-3_kind_phys - real(kind=kind_phys), parameter :: target_value2 = 42.0_kind_phys + !! This is for unit testing only + real(kind_phys), parameter :: target_value = 1.0E-3_kind_phys + real(kind_phys), parameter :: target_value2 = 42.0_kind_phys -contains + contains - !! \section arg_table_unit_conv_scheme_2_run Argument Table - !! \htmlinclude unit_conv_scheme_2_run.html - !! - subroutine unit_conv_scheme_2_run(data_array, data_array2, data_array_opt, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - real(kind=kind_phys), intent(inout) :: data_array(:) - real(kind=kind_phys), intent(inout) :: data_array2(:) - real(kind=kind_phys), intent(inout), optional :: data_array_opt(:) +!! \section arg_table_unit_conv_scheme_2_run Argument Table +!! \htmlinclude unit_conv_scheme_2_run.html +!! + subroutine unit_conv_scheme_2_run(data_array, data_array2, data_array_opt, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind_phys), intent(inout) :: data_array(:) + real(kind_phys), intent(inout) :: data_array2(:) + real(kind_phys), intent(inout), optional :: data_array_opt(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check values in data array - write(error_unit, '(a,e12.4)') & - 'In unit_conv_scheme_2_run: checking min/max values of data array to be approximately ', target_value - if (minval(data_array) < 0.99 * target_value .or. maxval(data_array) > 1.01 * target_value) then - write(errmsg, '(3(a,e12.4),a)') 'Error in unit_conv_scheme_2_run, expected values of approximately ', & - target_value, ' but got [ ', minval(data_array), ' : ', maxval(data_array), ' ]' - errflg = 1 - return - end if - ! Check values in data array2 - write(error_unit, '(a,e12.4)') & - 'In unit_conv_scheme_2_run: checking min/max values of data array 2 to be approximately ', target_value2 - if (minval(data_array2) < 0.99 * target_value2 .or. maxval(data_array2) > 1.01 * target_value2) then - write(errmsg, '(3(a,e12.4),a)') & - "Error in unit_conv_scheme_2_run, expected values for data array 2 of approximately ", & - target_value2, " but got [ ", minval(data_array2), " : ", maxval(data_array2), " ]" - errflg = 1 - return - end if - ! Check for presence of optional data array, then check its values - write(error_unit, '(a)') 'In unit_conv_scheme_2_run: checking for presence of optional data array' - if ( .not. present(data_array_opt)) then - write(error_unit, '(a)') 'Error in unit_conv_scheme_2_run, optional data array expected but not present' - errflg = 1 - return - end if - write(error_unit, '(a,e12.4)') & - 'In unit_conv_scheme_2_run: checking min/max values of optional data array to be approximately ', target_value - if (minval(data_array_opt) < 0.99 * target_value .or. maxval(data_array_opt) > 1.01 * target_value) then - write(errmsg, '(3(a,e12.4),a)') 'Error in unit_conv_scheme_2_run, expected values of approximately ', & - target_value, ' but got [ ', minval(data_array_opt), ' : ', maxval(data_array_opt), ' ]' - errflg = 1 - return - end if - end subroutine unit_conv_scheme_2_run + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check values in data array + write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_2_run: checking min/max values of data array to be approximately ', target_value + if (minval(data_array)<0.99*target_value .or. maxval(data_array)>1.01*target_value) then + write(errmsg,'(3(a,e12.4),a)') 'Error in unit_conv_scheme_2_run, expected values of approximately ', & + target_value, ' but got [ ', minval(data_array), ' : ', maxval(data_array), ' ]' + errflg = 1 + return + end if + ! Check values in data array2 + write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_2_run: checking min/max values of data array 2 to be approximately ', target_value2 + if (minval(data_array2)<0.99*target_value2 .or. maxval(data_array2)>1.01*target_value2) then + write(errmsg,'(3(a,e12.4),a)') "Error in unit_conv_scheme_2_run, expected values for data array 2 of approximately ", & + target_value2, " but got [ ", minval(data_array2), " : ", maxval(data_array2), " ]" + errflg = 1 + return + end if + ! Check for presence of optional data array, then check its values + write(error_unit,'(a)') 'In unit_conv_scheme_2_run: checking for presence of optional data array' + if (.not. present(data_array_opt)) then + write(error_unit,'(a)') 'Error in unit_conv_scheme_2_run, optional data array expected but not present' + errflg = 1 + return + endif + write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_2_run: checking min/max values of optional data array to be approximately ', target_value + if (minval(data_array_opt)<0.99*target_value .or. maxval(data_array_opt)>1.01*target_value) then + write(errmsg,'(3(a,e12.4),a)') 'Error in unit_conv_scheme_2_run, expected values of approximately ', & + target_value, ' but got [ ', minval(data_array_opt), ' : ', maxval(data_array_opt), ' ]' + errflg = 1 + return + end if + end subroutine unit_conv_scheme_2_run end module unit_conv_scheme_2 From c4866fc52839ec8f30d76ad82eae0ef18a7a48c7 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 23 Apr 2026 08:17:28 -0600 Subject: [PATCH 4/6] Revert me: test/unit_tests/sample_scheme_files/reorder.F90 test Codee exclude list --- test/unit_tests/sample_scheme_files/reorder.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test/unit_tests/sample_scheme_files/reorder.F90 b/test/unit_tests/sample_scheme_files/reorder.F90 index d3c92530..690aebe0 100644 --- a/test/unit_tests/sample_scheme_files/reorder.F90 +++ b/test/unit_tests/sample_scheme_files/reorder.F90 @@ -66,3 +66,8 @@ subroutine reorder_finalize (errmsg, errflg) end subroutine reorder_finalize END MODULE reorder + + ! add some stuff here to check if codee really ignores this + + +! BLA \ No newline at end of file From 00f47111b36e023d0bb928e03fe1e9444d29e77b Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 23 Apr 2026 08:19:44 -0600 Subject: [PATCH 5/6] Bump codee to 2026.1.2 in GitHub actions --- .github/workflows/fortran-formatting.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/fortran-formatting.yaml b/.github/workflows/fortran-formatting.yaml index 977d5e2c..5f4fdb3c 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.8 + CODEE_VERSION: 2026.1.2 # Only needed when fixing formatting automatically, but this only # works for pull requests from the same repo, not from a fork From 628af2d67db77f9f382c00e926a0eb0dcc50db70 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 23 Apr 2026 08:20:05 -0600 Subject: [PATCH 6/6] Codee format --- src/ccpp_constituent_prop_mod.F90 | 22 +- src/ccpp_hash_table.F90 | 6 +- src/ccpp_scheme_utils.F90 | 5 +- .../apply_constituent_tendencies.F90 | 50 +- test/advection_test/cld_ice.F90 | 220 +- test/advection_test/cld_liq.F90 | 182 +- test/advection_test/const_indices.F90 | 173 +- test/advection_test/dlc_liq.F90 | 58 +- .../test_advection_host_integration.F90 | 137 +- test/advection_test/test_host.F90 | 2166 +++++++++-------- test/advection_test/test_host_data.F90 | 98 +- test/advection_test/test_host_mod.F90 | 323 +-- test/capgen_test/adjust/temp_kinds.F90 | 8 +- .../source_dir1/environ_conditions.F90 | 102 +- test/capgen_test/source_dir2/temp_set.F90 | 149 +- test/capgen_test/temp_adjust.F90 | 5 +- .../test_capgen_host_integration.F90 | 5 +- test/capgen_test/test_host.F90 | 11 +- test/capgen_test/test_host_mod.F90 | 5 +- test/ddthost_test/environ_conditions.F90 | 82 +- test/ddthost_test/host_ccpp_ddt.F90 | 22 +- test/ddthost_test/make_ddt.F90 | 241 +- test/ddthost_test/setup_coeffs.F90 | 6 +- test/ddthost_test/temp_set.F90 | 106 +- .../test_ddt_host_integration.F90 | 139 +- test/ddthost_test/test_host.F90 | 488 ++-- test/ddthost_test/test_host_data.F90 | 34 +- test/ddthost_test/test_host_mod.F90 | 181 +- test/hash_table_tests/test_hash.F90 | 401 +-- test/nested_suite_test/ccpp_kinds.F90 | 10 +- test/nested_suite_test/effr_calc.F90 | 154 +- test/nested_suite_test/effr_diag.F90 | 94 +- test/nested_suite_test/effr_post.F90 | 102 +- test/nested_suite_test/effr_pre.F90 | 98 +- test/nested_suite_test/effrs_calc.F90 | 34 +- test/nested_suite_test/module_rad_ddt.F90 | 10 +- test/nested_suite_test/rad_lw.F90 | 18 +- test/nested_suite_test/rad_sw.F90 | 18 +- test/nested_suite_test/test_host.F90 | 466 ++-- test/nested_suite_test/test_host_data.F90 | 117 +- test/nested_suite_test/test_host_mod.F90 | 182 +- .../test_nested_suite_integration.F90 | 157 +- test/utils/test_utils.F90 | 150 +- test/var_compatibility_test/effr_calc.F90 | 154 +- test/var_compatibility_test/effr_diag.F90 | 94 +- test/var_compatibility_test/effr_post.F90 | 102 +- test/var_compatibility_test/effr_pre.F90 | 98 +- test/var_compatibility_test/effrs_calc.F90 | 34 +- .../var_compatibility_test/module_rad_ddt.F90 | 10 +- test/var_compatibility_test/rad_lw.F90 | 18 +- test/var_compatibility_test/rad_sw.F90 | 18 +- test/var_compatibility_test/test_host.F90 | 466 ++-- .../var_compatibility_test/test_host_data.F90 | 117 +- test/var_compatibility_test/test_host_mod.F90 | 182 +- .../test_var_compatibility_integration.F90 | 151 +- .../test_blocked_data/blocked_data_scheme.F90 | 212 +- test_prebuild/test_blocked_data/data.F90 | 54 +- test_prebuild/test_blocked_data/main.F90 | 217 +- .../test_chunked_data/chunked_data_scheme.F90 | 212 +- test_prebuild/test_chunked_data/data.F90 | 58 +- test_prebuild/test_chunked_data/main.F90 | 212 +- test_prebuild/test_opt_arg/ccpp_kinds.F90 | 12 +- test_prebuild/test_opt_arg/data.F90 | 28 +- test_prebuild/test_opt_arg/main.F90 | 236 +- test_prebuild/test_opt_arg/opt_arg_scheme.F90 | 152 +- test_prebuild/test_unit_conv/ccpp_kinds.F90 | 12 +- test_prebuild/test_unit_conv/data.F90 | 32 +- test_prebuild/test_unit_conv/main.F90 | 178 +- .../test_unit_conv/unit_conv_scheme_1.F90 | 109 +- .../test_unit_conv/unit_conv_scheme_2.F90 | 108 +- 70 files changed, 5202 insertions(+), 5109 deletions(-) diff --git a/src/ccpp_constituent_prop_mod.F90 b/src/ccpp_constituent_prop_mod.F90 index d75be966..d881e308 100644 --- a/src/ccpp_constituent_prop_mod.F90 +++ b/src/ccpp_constituent_prop_mod.F90 @@ -3,8 +3,10 @@ module ccpp_constituent_prop_mod ! ccpp_contituent_prop_mod contains types and procedures for storing ! and retrieving constituent properties - use ccpp_hashable, only: ccpp_hashable_t, ccpp_hashable_char_t - use ccpp_hash_table, only: ccpp_hash_table_t, ccpp_hash_iterator_t + use ccpp_hashable, only: ccpp_hashable_t, & + ccpp_hashable_char_t + use ccpp_hash_table, only: ccpp_hash_table_t, & + ccpp_hash_iterator_t use ccpp_kinds, only: kind_phys implicit none @@ -368,7 +370,7 @@ logical function ccp_is_instantiated(this, errcode, errmsg) ccp_is_instantiated = allocated(this%var_std_name) call initialize_errvars(errcode, errmsg) - if (.not.ccp_is_instantiated) then + if (.not. ccp_is_instantiated) then call append_errvars(1, "ccpp_constituent_properties_t object is not initialized", & subname, errcode=errcode, errmsg=errmsg) end if @@ -1093,7 +1095,7 @@ logical function ccp_model_const_locked(this, errcode, errmsg, warn_func) ! Use an initialized hash table as double check if (this%hash_table%is_initialized()) then ccp_model_const_locked = this%table_locked .and. this%data_locked - if ((.not.(this%table_locked .and. this%data_locked)) .and. & + if ((.not. (this%table_locked .and. this%data_locked)) .and. & present(errmsg) .and. present(warn_func)) then ! Write a warning as a courtesy to calling function but do not set ! errcode (let caller decide). @@ -1125,7 +1127,7 @@ logical function ccp_model_const_props_locked(this, errcode, errmsg, warn_func) ! Use an initialized hash table as double check if (this%hash_table%is_initialized()) then ccp_model_const_props_locked = this%table_locked - if (.not.this%table_locked .and. & + if (.not. this%table_locked .and. & present(errmsg) .and. present(warn_func)) then ! Write a warning as a courtesy to calling function but do not set ! errcode (let caller decide). @@ -1158,7 +1160,7 @@ logical function ccp_model_const_data_locked(this, errcode, errmsg, warn_func) ! Use an initialized hash table as double check if (this%hash_table%is_initialized()) then ccp_model_const_data_locked = this%data_locked - if (.not.this%data_locked .and. & + if (.not. this%data_locked .and. & present(errmsg) .and. present(warn_func)) then ! Write a warning as a courtesy to calling function but do not set ! errcode (let caller decide). @@ -1191,10 +1193,10 @@ logical function ccp_model_const_okay_to_add(this, errcode, errmsg, & ccp_model_const_okay_to_add = this%hash_table%is_initialized() if (ccp_model_const_okay_to_add) then - ccp_model_const_okay_to_add = .not.(this%const_props_locked(errcode=errcode, & + ccp_model_const_okay_to_add = .not. (this%const_props_locked(errcode=errcode, & errmsg=errmsg, warn_func=subname) .or. this%const_data_locked(errcode=errcode, & errmsg=errmsg, warn_func=subname)) - if (.not.ccp_model_const_okay_to_add) then + if (.not. ccp_model_const_okay_to_add) then call append_errvars(1, & "WARNING: Model constituents are locked", & subname, errcode=errcode, errmsg=errmsg, caller=warn_func) @@ -1440,7 +1442,7 @@ subroutine ccp_model_const_table_lock(this, errcode, errmsg) call this%const_metadata(index_const)%set(cprop) end if ! Make sure this is a layer variable - if (.not.cprop%is_layer_var()) then + if (.not. cprop%is_layer_var()) then call cprop%vertical_dimension(dimname, & errcode=errcode, errmsg=errmsg) call append_errvars(1, "ERROR: Bad vertical dimension, '" // & @@ -1510,7 +1512,7 @@ subroutine ccp_model_const_data_lock(this, ncols, num_layers, errcode, errmsg) "WARNING: Model constituent data already locked, ignoring", & subname, errcode=errcode, errmsg=errmsg) errcode_local = errcode_local + 1 - else if (.not.this%const_props_locked(errcode=errcode, errmsg=errmsg, & + else if (.not. this%const_props_locked(errcode=errcode, errmsg=errmsg, & warn_func=subname)) then call append_errvars(1, & "WARNING: Model constituent properties not yet locked, ignoring", & diff --git a/src/ccpp_hash_table.F90 b/src/ccpp_hash_table.F90 index 685c9049..9f175a3a 100644 --- a/src/ccpp_hash_table.F90 +++ b/src/ccpp_hash_table.F90 @@ -260,8 +260,8 @@ function hash_table_table_value(this, key, errmsg) result(tbl_val) end if end if - if ((.not.associated(tbl_val)) .and. present(errmsg)) then - if (.not.have_error(errmsg)) then ! Still need to test for empty + if ((.not. associated(tbl_val)) .and. present(errmsg)) then + if (.not. have_error(errmsg)) then ! Still need to test for empty write(errmsg, *) subname, ": No entry for '", trim(key), "'" end if end if @@ -453,7 +453,7 @@ subroutine hash_iterator_next_entry(this) end if if (has_table_next) then this%table_entry => this%table_entry%next - else if ((.not.has_table_entry) .and. & + else if ((.not. has_table_entry) .and. & associated(this%hash_table%table(this%index)%next)) then this%table_entry => this%hash_table%table(this%index)%next else diff --git a/src/ccpp_scheme_utils.F90 b/src/ccpp_scheme_utils.F90 index f6920e85..d4de6499 100644 --- a/src/ccpp_scheme_utils.F90 +++ b/src/ccpp_scheme_utils.F90 @@ -2,7 +2,8 @@ module ccpp_scheme_utils ! Module of utilities available to CCPP schemes - use ccpp_constituent_prop_mod, only: ccpp_model_constituents_t, int_unassigned + use ccpp_constituent_prop_mod, only: ccpp_model_constituents_t, & + int_unassigned implicit none private @@ -62,7 +63,7 @@ subroutine ccpp_initialize_constituent_ptr(const_obj) ! Dummy arguments type(ccpp_model_constituents_t), pointer, intent(in) :: const_obj - if (.not.initialized) then + if (.not. initialized) then constituent_obj => const_obj initialized = .true. end if diff --git a/test/advection_test/apply_constituent_tendencies.F90 b/test/advection_test/apply_constituent_tendencies.F90 index 150b1190..63a1881c 100644 --- a/test/advection_test/apply_constituent_tendencies.F90 +++ b/test/advection_test/apply_constituent_tendencies.F90 @@ -7,33 +7,33 @@ module apply_constituent_tendencies public :: apply_constituent_tendencies_run -CONTAINS - - !> \section arg_table_apply_constituent_tendencies_run Argument Table - !!! \htmlinclude apply_constituent_tendencies_run.html - subroutine apply_constituent_tendencies_run(const_tend, const, errcode, errmsg) - ! Dummy arguments - real(kind_phys), intent(inout) :: const_tend(:,:,:) ! constituent tendency array - real(kind_phys), intent(inout) :: const(:,:,:) ! constituent state array - integer, intent(out) :: errcode - character(len=512), intent(out) :: errmsg - - ! Local variables - integer :: klev, jcnst, icol - - errcode = 0 - errmsg = '' - - do icol = 1, size(const_tend, 1) - do klev = 1, size(const_tend, 2) - do jcnst = 1, size(const_tend, 3) - const(icol, klev, jcnst) = const(icol, klev, jcnst) + const_tend(icol, klev, jcnst) - end do - end do +contains + + !> \section arg_table_apply_constituent_tendencies_run Argument Table + !!! \htmlinclude apply_constituent_tendencies_run.html + subroutine apply_constituent_tendencies_run(const_tend, const, errcode, errmsg) + ! Dummy arguments + real(kind=kind_phys), intent(inout) :: const_tend(:, :, :) ! constituent tendency array + real(kind=kind_phys), intent(inout) :: const(:, :, :) ! constituent state array + integer, intent(out) :: errcode + character(len=512), intent(out) :: errmsg + + ! Local variables + integer :: klev, jcnst, icol + + errcode = 0 + errmsg = '' + + do icol = 1, size(const_tend, 1) + do klev = 1, size(const_tend, 2) + do jcnst = 1, size(const_tend, 3) + const(icol, klev, jcnst) = const(icol, klev, jcnst) + const_tend(icol, klev, jcnst) + end do end do + end do - const_tend = 0._kind_phys + const_tend = 0._kind_phys - end subroutine apply_constituent_tendencies_run + end subroutine apply_constituent_tendencies_run end module apply_constituent_tendencies diff --git a/test/advection_test/cld_ice.F90 b/test/advection_test/cld_ice.F90 index 15f5b502..3ace2f91 100644 --- a/test/advection_test/cld_ice.F90 +++ b/test/advection_test/cld_ice.F90 @@ -1,127 +1,127 @@ ! Test parameterization with advected species ! -MODULE cld_ice - - USE ccpp_kinds, ONLY: kind_phys - - IMPLICIT NONE - PRIVATE - - PUBLIC :: cld_ice_register - PUBLIC :: cld_ice_init - PUBLIC :: cld_ice_run - PUBLIC :: cld_ice_final - - real(kind_phys), private :: tcld = HUGE(1.0_kind_phys) - -CONTAINS - - !> \section arg_table_cld_ice_register Argument Table - !! \htmlinclude arg_table_cld_ice_register.html - !! - subroutine cld_ice_register(dyn_const_ice, errmsg, errcode) - use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t - type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const_ice(:) - integer, intent(out) :: errcode - character(len=512), intent(out) :: errmsg - - errmsg = '' - errcode = 0 - allocate(dyn_const_ice(2), stat=errcode) - if (errcode /= 0) then - errmsg = 'Error allocating dyn_const in cld_ice_dynamic_constituents' - return - end if - call dyn_const_ice(1)%instantiate(std_name='dyn_const1', long_name='dyn const1', & - diag_name='DYNCONST1', units='kg kg-1', default_value=0._kind_phys, & - vertical_dim='vertical_layer_dimension', advected=.true., & - min_value=1000._kind_phys, water_species=.true., mixing_ratio_type='wet', & - errcode=errcode, errmsg=errmsg) - call dyn_const_ice(2)%instantiate(std_name='dyn_const2_wrt_moist_air', long_name='dyn const2', & - diag_name='DYNCONST2', units='kg kg-1', default_value=0._kind_phys, & - vertical_dim='vertical_layer_dimension', advected=.true., & - water_species=.false., errcode=errcode, errmsg=errmsg) - - end subroutine cld_ice_register - - !> \section arg_table_cld_ice_run Argument Table - !! \htmlinclude arg_table_cld_ice_run.html - !! - subroutine cld_ice_run(ncol, timestep, temp, qv, ps, cld_ice_array, & - errmsg, errflg) - - integer, intent(in) :: ncol - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(inout) :: temp(:,:) - real(kind_phys), intent(inout) :: qv(:,:) - real(kind_phys), intent(in) :: ps(:) - REAL(kind_phys), intent(inout) :: cld_ice_array(:,:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - - integer :: icol - integer :: ilev - real(kind_phys) :: frz - - errmsg = '' - errflg = 0 - - ! Apply state-of-the-art thermodynamics :) - do icol = 1, ncol - do ilev = 1, size(temp, 2) - if (temp(icol, ilev) < tcld) then - frz = MAX(qv(icol, ilev) - 0.5_kind_phys, 0.0_kind_phys) - cld_ice_array(icol, ilev) = cld_ice_array(icol, ilev) + frz - qv(icol, ilev) = qv(icol, ilev) - frz - if (frz > 0.0_kind_phys) then - temp(icol, ilev) = temp(icol, ilev) + 1.0_kind_phys - end if - end if - end do +module cld_ice + + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: cld_ice_register + public :: cld_ice_init + public :: cld_ice_run + public :: cld_ice_final + + real(kind=kind_phys), private :: tcld = huge(1.0_kind_phys) + +contains + + !> \section arg_table_cld_ice_register Argument Table + !! \htmlinclude arg_table_cld_ice_register.html + !! + subroutine cld_ice_register(dyn_const_ice, errmsg, errcode) + use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t + type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const_ice(:) + integer, intent(out) :: errcode + character(len=512), intent(out) :: errmsg + + errmsg = '' + errcode = 0 + allocate(dyn_const_ice(2), stat=errcode) + if (errcode /= 0) then + errmsg = 'Error allocating dyn_const in cld_ice_dynamic_constituents' + return + end if + call dyn_const_ice(1)%instantiate(std_name='dyn_const1', long_name='dyn const1', & + diag_name='DYNCONST1', units='kg kg-1', default_value=0._kind_phys, & + vertical_dim='vertical_layer_dimension', advected=.true., & + min_value=1000._kind_phys, water_species=.true., mixing_ratio_type='wet', & + errcode=errcode, errmsg=errmsg) + call dyn_const_ice(2)%instantiate(std_name='dyn_const2_wrt_moist_air', long_name='dyn const2', & + diag_name='DYNCONST2', units='kg kg-1', default_value=0._kind_phys, & + vertical_dim='vertical_layer_dimension', advected=.true., & + water_species=.false., errcode=errcode, errmsg=errmsg) + + end subroutine cld_ice_register + + !> \section arg_table_cld_ice_run Argument Table + !! \htmlinclude arg_table_cld_ice_run.html + !! + subroutine cld_ice_run(ncol, timestep, temp, qv, ps, cld_ice_array, & + errmsg, errflg) + + integer, intent(in) :: ncol + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(inout) :: temp(:, :) + real(kind=kind_phys), intent(inout) :: qv(:, :) + real(kind=kind_phys), intent(in) :: ps(:) + real(kind=kind_phys), intent(inout) :: cld_ice_array(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + + integer :: icol + integer :: ilev + real(kind=kind_phys) :: frz + + errmsg = '' + errflg = 0 + + ! Apply state-of-the-art thermodynamics :) + do icol = 1, ncol + do ilev = 1, size(temp, 2) + if (temp(icol, ilev) < tcld) then + frz = max(qv(icol, ilev) - 0.5_kind_phys, 0.0_kind_phys) + cld_ice_array(icol, ilev) = cld_ice_array(icol, ilev) + frz + qv(icol, ilev) = qv(icol, ilev) - frz + if (frz > 0.0_kind_phys) then + temp(icol, ilev) = temp(icol, ilev) + 1.0_kind_phys + end if + end if end do + end do - END SUBROUTINE cld_ice_run + end subroutine cld_ice_run - !> \section arg_table_cld_ice_init Argument Table - !! \htmlinclude arg_table_cld_ice_init.html - !! - subroutine cld_ice_init(tfreeze, cld_ice_array, errmsg, errflg) + !> \section arg_table_cld_ice_init Argument Table + !! \htmlinclude arg_table_cld_ice_init.html + !! + subroutine cld_ice_init(tfreeze, cld_ice_array, errmsg, errflg) - real(kind_phys), intent(in) :: tfreeze - real(kind_phys), intent(inout) :: cld_ice_array(:,:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(in) :: tfreeze + real(kind=kind_phys), intent(inout) :: cld_ice_array(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - errmsg = '' - errflg = 0 - cld_ice_array = 0.0_kind_phys - tcld = tfreeze - 20.0_kind_phys + errmsg = '' + errflg = 0 + cld_ice_array = 0.0_kind_phys + tcld = tfreeze - 20.0_kind_phys - end subroutine cld_ice_init + end subroutine cld_ice_init - !> \section arg_table_cld_ice_final Argument Table - !! \htmlinclude arg_table_cld_ice_final.html - !! + !> \section arg_table_cld_ice_final Argument Table + !! \htmlinclude arg_table_cld_ice_final.html + !! - !> @{ - !! This routine does nothing, but it tests if blank - !! lines and doxygen comments between metadata hooks - !! and the subroutine are parsed correctly. - !! @{ + !> @{ + !! This routine does nothing, but it tests if blank + !! lines and doxygen comments between metadata hooks + !! and the subroutine are parsed correctly. + !! @{ - subroutine cld_ice_final(errmsg, errflg) + subroutine cld_ice_final(errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 - end subroutine cld_ice_final + end subroutine cld_ice_final - !! @} - !! @} + !! @} + !! @} -END MODULE cld_ice +end module cld_ice diff --git a/test/advection_test/cld_liq.F90 b/test/advection_test/cld_liq.F90 index 83a6f961..cb02cf11 100644 --- a/test/advection_test/cld_liq.F90 +++ b/test/advection_test/cld_liq.F90 @@ -1,102 +1,102 @@ ! Test parameterization with advected species ! -MODULE cld_liq - - USE ccpp_kinds, ONLY: kind_phys - use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t - - IMPLICIT NONE - PRIVATE - - PUBLIC :: cld_liq_register - PUBLIC :: cld_liq_init - PUBLIC :: cld_liq_run - -CONTAINS - - !> \section arg_table_cld_liq_register Argument Table - !! \htmlinclude arg_table_cld_liq_register.html - !! - subroutine cld_liq_register(dyn_const, errmsg, errflg) - type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - - errmsg = '' - errflg = 0 - allocate(dyn_const(1), stat=errflg) - if (errflg /= 0) then - errmsg = 'Error allocating dyn_const in cld_liq_register' - return - end if - call dyn_const(1)%instantiate(std_name="dyn_const3_wrt_moist_air_and_condensed_water", long_name='dyn const3', & - diag_name='DYNCONST3', units='kg kg-1', default_value=1._kind_phys, & - vertical_dim='vertical_layer_dimension', advected=.true., & - water_species=.true., mixing_ratio_type='dry', & - errcode=errflg, errmsg=errmsg) - - end subroutine cld_liq_register - - !> \section arg_table_cld_liq_run Argument Table - !! \htmlinclude arg_table_cld_liq_run.html - !! - subroutine cld_liq_run(ncol, timestep, tcld, temp, qv, ps, & - cld_liq_tend, errmsg, errflg) - - integer, intent(in) :: ncol - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(in) :: tcld - real(kind_phys), intent(inout) :: temp(:,:) - real(kind_phys), intent(inout) :: qv(:,:) - real(kind_phys), intent(in) :: ps(:) - REAL(kind_phys), intent(inout) :: cld_liq_tend(:,:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - - integer :: icol - integer :: ilev - real(kind_phys) :: cond - - errmsg = '' - errflg = 0 - - ! Apply state-of-the-art thermodynamics :) - do icol = 1, ncol - do ilev = 1, size(temp, 2) - if ( (qv(icol, ilev) > 0.0_kind_phys) .and. & - (temp(icol, ilev) <= tcld)) then - cond = MIN(qv(icol, ilev), 0.1_kind_phys) - cld_liq_tend(icol, ilev) = cond - qv(icol, ilev) = qv(icol, ilev) - cond - if (cond > 0.0_kind_phys) then - temp(icol, ilev) = temp(icol, ilev) + (cond * 5.0_kind_phys) - end if - end if - end do +module cld_liq + + use ccpp_kinds, only: kind_phys + use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t + + implicit none + private + + public :: cld_liq_register + public :: cld_liq_init + public :: cld_liq_run + +contains + + !> \section arg_table_cld_liq_register Argument Table + !! \htmlinclude arg_table_cld_liq_register.html + !! + subroutine cld_liq_register(dyn_const, errmsg, errflg) + type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + + errmsg = '' + errflg = 0 + allocate(dyn_const(1), stat=errflg) + if (errflg /= 0) then + errmsg = 'Error allocating dyn_const in cld_liq_register' + return + end if + call dyn_const(1)%instantiate(std_name="dyn_const3_wrt_moist_air_and_condensed_water", long_name='dyn const3', & + diag_name='DYNCONST3', units='kg kg-1', default_value=1._kind_phys, & + vertical_dim='vertical_layer_dimension', advected=.true., & + water_species=.true., mixing_ratio_type='dry', & + errcode=errflg, errmsg=errmsg) + + end subroutine cld_liq_register + + !> \section arg_table_cld_liq_run Argument Table + !! \htmlinclude arg_table_cld_liq_run.html + !! + subroutine cld_liq_run(ncol, timestep, tcld, temp, qv, ps, & + cld_liq_tend, errmsg, errflg) + + integer, intent(in) :: ncol + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(in) :: tcld + real(kind=kind_phys), intent(inout) :: temp(:, :) + real(kind=kind_phys), intent(inout) :: qv(:, :) + real(kind=kind_phys), intent(in) :: ps(:) + real(kind=kind_phys), intent(inout) :: cld_liq_tend(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + + integer :: icol + integer :: ilev + real(kind=kind_phys) :: cond + + errmsg = '' + errflg = 0 + + ! Apply state-of-the-art thermodynamics :) + do icol = 1, ncol + do ilev = 1, size(temp, 2) + if ((qv(icol, ilev) > 0.0_kind_phys) .and. & + (temp(icol, ilev) <= tcld)) then + cond = min(qv(icol, ilev), 0.1_kind_phys) + cld_liq_tend(icol, ilev) = cond + qv(icol, ilev) = qv(icol, ilev) - cond + if (cond > 0.0_kind_phys) then + temp(icol, ilev) = temp(icol, ilev) + (cond * 5.0_kind_phys) + end if + end if end do + end do - END SUBROUTINE cld_liq_run + end subroutine cld_liq_run - !> \section arg_table_cld_liq_init Argument Table - !! \htmlinclude arg_table_cld_liq_init.html - !! - subroutine cld_liq_init(tfreeze, cld_liq_array, tcld, errmsg, errflg) + !> \section arg_table_cld_liq_init Argument Table + !! \htmlinclude arg_table_cld_liq_init.html + !! + subroutine cld_liq_init(tfreeze, cld_liq_array, tcld, errmsg, errflg) - real(kind_phys), intent(in) :: tfreeze - real(kind_phys), intent(out) :: cld_liq_array(:,:) - real(kind_phys), intent(out) :: tcld - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(in) :: tfreeze + real(kind=kind_phys), intent(out) :: cld_liq_array(:, :) + real(kind=kind_phys), intent(out) :: tcld + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - ! This routine currently does nothing + ! This routine currently does nothing - errmsg = '' - errflg = 0 - cld_liq_array = 0.0_kind_phys - tcld = tfreeze - 20.0_kind_phys + errmsg = '' + errflg = 0 + cld_liq_array = 0.0_kind_phys + tcld = tfreeze - 20.0_kind_phys - end subroutine cld_liq_init + end subroutine cld_liq_init -END MODULE cld_liq +end module cld_liq diff --git a/test/advection_test/const_indices.F90 b/test/advection_test/const_indices.F90 index 0d9cf2e7..bc3b46a7 100644 --- a/test/advection_test/const_indices.F90 +++ b/test/advection_test/const_indices.F90 @@ -1,94 +1,95 @@ ! Test collection of constituent indices ! -MODULE const_indices - - USE ccpp_kinds, ONLY: kind_phys - - IMPLICIT NONE - PRIVATE - - PUBLIC :: const_indices_init - PUBLIC :: const_indices_run - -CONTAINS - - !> \section arg_table_const_indices_run Argument Table - !! \htmlinclude arg_table_const_indices_run.html - !! - subroutine const_indices_run(const_std_name, num_consts, test_stdname_array, & - const_index, const_inds, errmsg, errflg) - use ccpp_constituent_prop_mod, only: int_unassigned - use ccpp_scheme_utils, only: ccpp_constituent_index - use ccpp_scheme_utils, only: ccpp_constituent_indices - - character(len=*), intent(in) :: const_std_name - integer, intent(in) :: num_consts - character(len=*), intent(in) :: test_stdname_array(:) - integer, intent(out) :: const_index - integer, intent(out) :: const_inds(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - - integer :: indx - integer :: test_indx - - errmsg = '' - errflg = 0 - - ! Find the constituent index for - call ccpp_constituent_index(const_std_name, const_index, errflg, errmsg) - if (errflg == 0) then - call ccpp_constituent_indices(test_stdname_array, const_inds, errflg, errmsg) - end if - ! Check that a non-registered constituent is detectable but - ! does not cause an error - if (errflg == 0) then - call ccpp_constituent_index('unobtainium', test_indx, errflg, errmsg) - if (test_indx /= int_unassigned) then - if (errflg == 0) then - ! Do not add an error if one is already reported - errflg = 2 - write(errmsg, '(2a,i0,a,i0)') "ccpp_constituent_index called for ", & - "'unobtainium' returned an index of ", test_indx, ", not ", & - int_unassigned - end if - end if +module const_indices + + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: const_indices_init + public :: const_indices_run + +contains + + !> \section arg_table_const_indices_run Argument Table + !! \htmlinclude arg_table_const_indices_run.html + !! + subroutine const_indices_run(const_std_name, num_consts, test_stdname_array, & + const_index, const_inds, errmsg, errflg) + use ccpp_constituent_prop_mod, only: int_unassigned + use ccpp_scheme_utils, only: ccpp_constituent_index + use ccpp_scheme_utils, only: ccpp_constituent_indices + + character(len=*), intent(in) :: const_std_name + integer, intent(in) :: num_consts + character(len=*), intent(in) :: test_stdname_array(:) + integer, intent(out) :: const_index + integer, intent(out) :: const_inds(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + + integer :: indx + integer :: test_indx + + errmsg = '' + errflg = 0 + + ! Find the constituent index for + call ccpp_constituent_index(const_std_name, const_index, errflg, errmsg) + if (errflg == 0) then + call ccpp_constituent_indices(test_stdname_array, const_inds, errflg, errmsg) + end if + ! Check that a non-registered constituent is detectable but + ! does not cause an error + if (errflg == 0) then + call ccpp_constituent_index('unobtainium', test_indx, errflg, errmsg) + if (test_indx /= int_unassigned) then + if (errflg == 0) then + ! Do not add an error if one is already reported + errflg = 2 + write(errmsg, '(2a,i0,a,i0)') "ccpp_constituent_index called for ", & + "'unobtainium' returned an index of ", test_indx, ", not ", & + int_unassigned + end if end if + end if - end subroutine const_indices_run - - !> \section arg_table_const_indices_init Argument Table - !! \htmlinclude arg_table_const_indices_init.html - !! - subroutine const_indices_init(const_std_name, num_consts, test_stdname_array, & - const_index, const_inds, errmsg, errflg) - use ccpp_scheme_utils, only: ccpp_constituent_index, ccpp_constituent_indices - - character(len=*), intent(in) :: const_std_name - integer, intent(in) :: num_consts - character(len=*), intent(in) :: test_stdname_array(:) - integer, intent(out) :: const_index - integer, intent(out) :: const_inds(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - - integer :: indx - - errmsg = '' - errflg = 0 - - ! Find the constituent index for - call ccpp_constituent_index(const_std_name, const_index, errflg, errmsg) - if (errflg == 0) then - call ccpp_constituent_indices(test_stdname_array, const_inds, errflg, errmsg) - end if + end subroutine const_indices_run + + !> \section arg_table_const_indices_init Argument Table + !! \htmlinclude arg_table_const_indices_init.html + !! + subroutine const_indices_init(const_std_name, num_consts, test_stdname_array, & + const_index, const_inds, errmsg, errflg) + use ccpp_scheme_utils, only: ccpp_constituent_index, & + ccpp_constituent_indices + + character(len=*), intent(in) :: const_std_name + integer, intent(in) :: num_consts + character(len=*), intent(in) :: test_stdname_array(:) + integer, intent(out) :: const_index + integer, intent(out) :: const_inds(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + + integer :: indx + + errmsg = '' + errflg = 0 + + ! Find the constituent index for + call ccpp_constituent_index(const_std_name, const_index, errflg, errmsg) + if (errflg == 0) then + call ccpp_constituent_indices(test_stdname_array, const_inds, errflg, errmsg) + end if - end subroutine const_indices_init + end subroutine const_indices_init - !! @} - !! @} + !! @} + !! @} -END MODULE const_indices +end module const_indices diff --git a/test/advection_test/dlc_liq.F90 b/test/advection_test/dlc_liq.F90 index db456073..20ff4b7b 100644 --- a/test/advection_test/dlc_liq.F90 +++ b/test/advection_test/dlc_liq.F90 @@ -1,41 +1,41 @@ ! Test parameterization with a runtime constituents ! properties object outside of the register phase -MODULE dlc_liq +module dlc_liq - USE ccpp_kinds, ONLY: kind_phys - use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t + use ccpp_kinds, only: kind_phys + use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: dlc_liq_init + public :: dlc_liq_init -CONTAINS +contains - !> \section arg_table_dlc_liq_init Argument Table - !! \htmlinclude arg_table_dlc_liq_init.html - !! - subroutine dlc_liq_init(dyn_const, errmsg, errflg) - type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + !> \section arg_table_dlc_liq_init Argument Table + !! \htmlinclude arg_table_dlc_liq_init.html + !! + subroutine dlc_liq_init(dyn_const, errmsg, errflg) + type(ccpp_constituent_properties_t), allocatable, intent(out) :: dyn_const(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - character(len=256) :: stdname + character(len=256) :: stdname - errmsg = '' - errflg = 0 - allocate(dyn_const(1), stat=errflg) - if (errflg /= 0) then - errmsg = 'Error allocating dyn_const in dlc_liq_init' - return - end if - call dyn_const(1)%instantiate(std_name="dyn_const3", long_name='dyn const3', & - diag_name='DYNCONST3', units='kg kg-1', default_value=1._kind_phys, & - vertical_dim='vertical_layer_dimension', advected=.true., & - errcode=errflg, errmsg=errmsg) - call dyn_const(1)%standard_name(stdname, errcode=errflg, errmsg=errmsg) + errmsg = '' + errflg = 0 + allocate(dyn_const(1), stat=errflg) + if (errflg /= 0) then + errmsg = 'Error allocating dyn_const in dlc_liq_init' + return + end if + call dyn_const(1)%instantiate(std_name="dyn_const3", long_name='dyn const3', & + diag_name='DYNCONST3', units='kg kg-1', default_value=1._kind_phys, & + vertical_dim='vertical_layer_dimension', advected=.true., & + errcode=errflg, errmsg=errmsg) + call dyn_const(1)%standard_name(stdname, errcode=errflg, errmsg=errmsg) - end subroutine dlc_liq_init + end subroutine dlc_liq_init -END MODULE dlc_liq +end module dlc_liq diff --git a/test/advection_test/test_advection_host_integration.F90 b/test/advection_test/test_advection_host_integration.F90 index 728137fa..0ee54da7 100644 --- a/test/advection_test/test_advection_host_integration.F90 +++ b/test/advection_test/test_advection_host_integration.F90 @@ -1,77 +1,80 @@ 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(1) - character(len=cm), target :: test_invars1(12) - character(len=cm), target :: test_outvars1(13) - character(len=cm), target :: test_reqvars1(18) + character(len=cs), target :: test_parts1(1) + character(len=cm), target :: test_invars1(12) + character(len=cm), target :: test_outvars1(13) + character(len=cm), target :: test_reqvars1(18) - type(suite_info) :: test_suites(1) - logical :: run_okay + type(suite_info) :: test_suites(1) + logical :: run_okay - test_parts1 = (/ 'physics '/) - test_invars1 = (/ & - 'banana_array_dim ', & - 'cloud_ice_dry_mixing_ratio ', & - 'cloud_liquid_dry_mixing_ratio ', & - 'tendency_of_cloud_liquid_dry_mixing_ratio', & - 'surface_air_pressure ', & - 'temperature ', & - 'time_step_for_physics ', & - 'water_temperature_at_freezing ', & - 'ccpp_constituent_tendencies ', & - 'ccpp_constituents ', & - 'number_of_ccpp_constituents ', & - 'water_vapor_specific_humidity ' /) - test_outvars1 = (/ & - 'ccpp_error_message ', & - 'ccpp_error_code ', & - 'temperature ', & - 'water_vapor_specific_humidity ', & - 'cloud_liquid_dry_mixing_ratio ', & - 'ccpp_constituent_tendencies ', & - 'ccpp_constituents ', & - 'dynamic_constituents_for_cld_liq ', & - 'dynamic_constituents_for_cld_ice ', & - 'tendency_of_cloud_liquid_dry_mixing_ratio', & - 'test_banana_constituent_index ', & - 'test_banana_constituent_indices ', & - 'cloud_ice_dry_mixing_ratio ' /) - test_reqvars1 = (/ & - 'banana_array_dim ', & - 'surface_air_pressure ', & - 'temperature ', & - 'time_step_for_physics ', & - 'cloud_liquid_dry_mixing_ratio ', & - 'tendency_of_cloud_liquid_dry_mixing_ratio', & - 'cloud_ice_dry_mixing_ratio ', & - 'dynamic_constituents_for_cld_liq ', & - 'dynamic_constituents_for_cld_ice ', & - 'water_temperature_at_freezing ', & - 'ccpp_constituent_tendencies ', & - 'ccpp_constituents ', & - 'number_of_ccpp_constituents ', & - 'test_banana_constituent_index ', & - 'test_banana_constituent_indices ', & - 'water_vapor_specific_humidity ', & - 'ccpp_error_message ', & - 'ccpp_error_code ' /) + test_parts1 = (/ 'physics '/) + test_invars1 = (/ & + 'banana_array_dim ', & + 'cloud_ice_dry_mixing_ratio ', & + 'cloud_liquid_dry_mixing_ratio ', & + 'tendency_of_cloud_liquid_dry_mixing_ratio', & + 'surface_air_pressure ', & + 'temperature ', & + 'time_step_for_physics ', & + 'water_temperature_at_freezing ', & + 'ccpp_constituent_tendencies ', & + 'ccpp_constituents ', & + 'number_of_ccpp_constituents ', & + 'water_vapor_specific_humidity ' /) + test_outvars1 = (/ & + 'ccpp_error_message ', & + 'ccpp_error_code ', & + 'temperature ', & + 'water_vapor_specific_humidity ', & + 'cloud_liquid_dry_mixing_ratio ', & + 'ccpp_constituent_tendencies ', & + 'ccpp_constituents ', & + 'dynamic_constituents_for_cld_liq ', & + 'dynamic_constituents_for_cld_ice ', & + 'tendency_of_cloud_liquid_dry_mixing_ratio', & + 'test_banana_constituent_index ', & + 'test_banana_constituent_indices ', & + 'cloud_ice_dry_mixing_ratio ' /) + test_reqvars1 = (/ & + 'banana_array_dim ', & + 'surface_air_pressure ', & + 'temperature ', & + 'time_step_for_physics ', & + 'cloud_liquid_dry_mixing_ratio ', & + 'tendency_of_cloud_liquid_dry_mixing_ratio', & + 'cloud_ice_dry_mixing_ratio ', & + 'dynamic_constituents_for_cld_liq ', & + 'dynamic_constituents_for_cld_ice ', & + 'water_temperature_at_freezing ', & + 'ccpp_constituent_tendencies ', & + 'ccpp_constituents ', & + 'number_of_ccpp_constituents ', & + 'test_banana_constituent_index ', & + 'test_banana_constituent_indices ', & + 'water_vapor_specific_humidity ', & + 'ccpp_error_message ', & + 'ccpp_error_code ' /) - ! Setup expected test suite info - test_suites(1)%suite_name = 'cld_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 + ! Setup expected test suite info + test_suites(1)%suite_name = 'cld_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 - 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/advection_test/test_host.F90 b/test/advection_test/test_host.F90 index 30a618e8..cc8bbf89 100644 --- a/test/advection_test/test_host.F90 +++ b/test/advection_test/test_host.F90 @@ -1,1110 +1,1114 @@ module test_prog - use ccpp_kinds, only: kind_phys - use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t - - implicit none - private - - public test_host - - ! Public data and interfaces - integer, public, parameter :: cs = 16 - integer, public, parameter :: cm = 41 - - !> \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 - - type(ccpp_constituent_properties_t), private, target, allocatable :: host_constituents(:) - - private :: check_suite - private :: advect_constituents ! Move data around - private :: check_errflg - -CONTAINS - - subroutine check_errflg(subname, errflg, errmsg, errflg_final) - ! If errflg is not zero, print an error message - character(len=*), intent(in) :: subname - integer, intent(in) :: errflg - character(len=*), intent(in) :: errmsg - - integer, intent(out) :: errflg_final - - if (errflg /= 0) then - write(6, '(a,i0,4a)') "Error ", errflg, " from ", trim(subname), & - ':', trim(errmsg) - !Notify test script that a failure occurred: - errflg_final = -1 !Notify test script that a failure occured - end if - - end subroutine check_errflg - - 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 - logical :: check - integer :: errflg - character(len=512) :: errmsg - character(len=128), allocatable :: test_list(:) - - check_suite = .true. - ! 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 - - subroutine advect_constituents() - use test_host_mod, only: phys_state, ncnst - use test_host_mod, only: twist_array - - ! Local variables - integer :: q_ind ! Constituent index - - do q_ind = 1, ncnst ! Skip checks, they were done in constituents_in - call twist_array(phys_state%q(:,:,q_ind)) - end do - end subroutine advect_constituents - - !> \section arg_table_test_host Argument Table - !! \htmlinclude arg_table_test_host.html - !! - subroutine test_host(retval, test_suites) - - use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t - use test_host_mod, only: num_time_steps - use test_host_mod, only: init_data, compare_data - use test_host_mod, only: ncols, pver - use test_host_data, only: num_consts, std_name_array, const_std_name - use test_host_data, only: check_constituent_indices - use test_host_ccpp_cap, only: test_host_ccpp_deallocate_dynamic_constituents - use test_host_ccpp_cap, only: test_host_ccpp_register_constituents - use test_host_ccpp_cap, only: test_host_ccpp_is_scheme_constituent - use test_host_ccpp_cap, only: test_host_ccpp_initialize_constituents - use test_host_ccpp_cap, only: test_host_ccpp_number_constituents - use test_host_ccpp_cap, only: test_host_constituents_array - 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_ccpp_cap, only: test_host_const_get_index - use test_host_ccpp_cap, only: test_host_model_const_properties - use test_utils, only: check_list - - type(suite_info), intent(in) :: test_suites(:) - logical, intent(out) :: retval - - logical :: check - integer :: col_start, col_end - integer :: index, sind - integer :: index_liq, index_ice - integer :: index_dyn1, index_dyn2, index_dyn3 - integer :: time_step - integer :: num_suites - integer :: num_advected ! Num advected species - logical :: const_log - logical :: is_constituent - logical :: has_default - integer :: test_scalar_const_index - integer :: test_const_indices(num_consts) - character(len=128), allocatable :: suite_names(:) - character(len=256) :: const_str - character(len=512) :: errmsg - character(len=512) :: expected_error - integer :: errflg - integer :: errflg_final ! Used to notify testing script of test failure - real(kind_phys), pointer :: const_ptr(:,:,:) - real(kind_phys) :: default_value - real(kind_phys) :: check_value - type(ccpp_constituent_prop_ptr_t), pointer :: const_props(:) - character(len=*), parameter :: subname = 'test_host' - - ! Initialized "final" error flag used to report a failure to the larged - ! testing script: - errflg_final = 0 - - ! 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 - - errflg = 0 - errmsg = '' - - ! Check that is_scheme_constituent works as expected - call test_host_ccpp_is_scheme_constituent('specific_humidity', & - is_constituent, errflg, errmsg) - call check_errflg(subname//"_ccpp_is_scheme_constituent", errflg, & - errmsg, errflg_final) - ! specific_humidity should not be an existing constituent - if (is_constituent) then - write(6, *) "ERROR: specific humidity is already a constituent" - errflg_final = -1 ! Notify test script that a failure occurred - end if - call test_host_ccpp_is_scheme_constituent('cloud_ice_dry_mixing_ratio', & - is_constituent, errflg, errmsg) - call check_errflg(subname//"_ccpp_is_scheme_constituent", errflg, & - errmsg, errflg_final) - ! cloud_ice_dry_mixing_ratio should be an existing constituent - if (.not. is_constituent) then - write(6, *) "ERROR: cloud_ice_dry_mixing ratio not found in ", & - "host cap constituent list" - errflg_final = -1 ! Notify test script that a failure occurred - end if - - ! Use the suite information to call the register phase + use ccpp_kinds, only: kind_phys + use ccpp_constituent_prop_mod, only: ccpp_constituent_properties_t + + implicit none + private + + public test_host + + ! Public data and interfaces + integer, public, parameter :: cs = 16 + integer, public, parameter :: cm = 41 + + !> \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 + + type(ccpp_constituent_properties_t), private, target, allocatable :: host_constituents(:) + + private :: check_suite + private :: advect_constituents ! Move data around + private :: check_errflg + +contains + + subroutine check_errflg(subname, errflg, errmsg, errflg_final) + ! If errflg is not zero, print an error message + character(len=*), intent(in) :: subname + integer, intent(in) :: errflg + character(len=*), intent(in) :: errmsg + + integer, intent(out) :: errflg_final + + if (errflg /= 0) then + write(6, '(a,i0,4a)') "Error ", errflg, " from ", trim(subname), & + ':', trim(errmsg) + !Notify test script that a failure occurred: + errflg_final = -1 !Notify test script that a failure occured + end if + + end subroutine check_errflg + + 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 + logical :: check + integer :: errflg + character(len=512) :: errmsg + character(len=128), allocatable :: test_list(:) + + check_suite = .true. + ! 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 + + subroutine advect_constituents() + use test_host_mod, only: phys_state, & + ncnst + use test_host_mod, only: twist_array + + ! Local variables + integer :: q_ind ! Constituent index + + do q_ind = 1, ncnst ! Skip checks, they were done in constituents_in + call twist_array(phys_state%q(:, :, q_ind)) + end do + end subroutine advect_constituents + + !> \section arg_table_test_host Argument Table + !! \htmlinclude arg_table_test_host.html + !! + subroutine test_host(retval, test_suites) + + use ccpp_constituent_prop_mod, only: ccpp_constituent_prop_ptr_t + use test_host_mod, only: num_time_steps + use test_host_mod, only: init_data, & + compare_data + use test_host_mod, only: ncols, & + pver + use test_host_data, only: num_consts, & + std_name_array, & + const_std_name + use test_host_data, only: check_constituent_indices + use test_host_ccpp_cap, only: test_host_ccpp_deallocate_dynamic_constituents + use test_host_ccpp_cap, only: test_host_ccpp_register_constituents + use test_host_ccpp_cap, only: test_host_ccpp_is_scheme_constituent + use test_host_ccpp_cap, only: test_host_ccpp_initialize_constituents + use test_host_ccpp_cap, only: test_host_ccpp_number_constituents + use test_host_ccpp_cap, only: test_host_constituents_array + 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_ccpp_cap, only: test_host_const_get_index + use test_host_ccpp_cap, only: test_host_model_const_properties + use test_utils, only: check_list + + type(suite_info), intent(in) :: test_suites(:) + logical, intent(out) :: retval + + logical :: check + integer :: col_start, col_end + integer :: index, sind + integer :: index_liq, index_ice + integer :: index_dyn1, index_dyn2, index_dyn3 + integer :: time_step + integer :: num_suites + integer :: num_advected ! Num advected species + logical :: const_log + logical :: is_constituent + logical :: has_default + integer :: test_scalar_const_index + integer :: test_const_indices(num_consts) + character(len=128), allocatable :: suite_names(:) + character(len=256) :: const_str + character(len=512) :: errmsg + character(len=512) :: expected_error + integer :: errflg + integer :: errflg_final ! Used to notify testing script of test failure + real(kind=kind_phys), pointer :: const_ptr(:, :, :) + real(kind=kind_phys) :: default_value + real(kind=kind_phys) :: check_value + type(ccpp_constituent_prop_ptr_t), pointer :: const_props(:) + character(len=*), parameter :: subname = 'test_host' + + ! Initialized "final" error flag used to report a failure to the larged + ! testing script: + errflg_final = 0 + + ! 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 (errflg == 0) then - 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) - exit - end if - end if - end do - - ! Register the constituents to find out what needs advecting - ! DO A COUPLE OF TESTS FIRST - - ! First confirm the correct error occurs if you try to add an - ! incompatible constituent with the same standard name - expected_error = 'ccp_model_const_add_metadata ERROR: Trying to add ' //& - 'constituent specific_humidity but an incompatible ' // & - 'constituent with this name already exists' - allocate(host_constituents(2)) - call host_constituents(1)%instantiate(std_name="specific_humidity", & - long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & - vertical_dim="vertical_layer_dimension", advected=.true., & - min_value=1000._kind_phys, molar_mass=2000._kind_phys, & - errcode=errflg, errmsg=errmsg) - call host_constituents(2)%instantiate(std_name="specific_humidity", & - long_name="Specific humidity", diag_name='H2O', units="kg kg", & - vertical_dim="vertical_layer_dimension", advected=.true., & - min_value=1000._kind_phys, molar_mass=2000._kind_phys, & - errcode=errflg, errmsg=errmsg) - call check_errflg(subname//'.initialize', errflg, errmsg, errflg_final) - if (errflg == 0) then - call test_host_ccpp_register_constituents(host_constituents, & - errmsg=errmsg, errflg=errflg) - end if - ! Check the error - if (errflg == 0) then - write(6, '(2a)') 'ERROR register_constituents: expected this error: ', & - trim(expected_error) - else - if (trim(errmsg) /= trim(expected_error)) then - write(6, '(4a)') 'ERROR register_constituents: expected this error: ', & - trim(expected_error), ' Got: ', trim(errmsg) - end if - end if - ! Now try again but with a compatible constituent - should be ignored when - ! the constituents object is created - ! Use the suite information to call the register phase - errflg = 0 - call test_host_ccpp_deallocate_dynamic_constituents() - deallocate(host_constituents) - do sind = 1, num_suites - if (errflg == 0) then - 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) - exit - end if - end if + if (trim(test_suites(sind)%suite_name) == & + trim(suite_names(index))) then + exit + end if end do - allocate(host_constituents(2)) - call host_constituents(1)%instantiate(std_name="specific_humidity", & - long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & - vertical_dim="vertical_layer_dimension", advected=.true., & - min_value=1000._kind_phys, molar_mass=2000._kind_phys, & - errcode=errflg, errmsg=errmsg) - call host_constituents(2)%instantiate(std_name="specific_humidity", & - long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & - vertical_dim="vertical_layer_dimension", advected=.true., & - min_value=1000._kind_phys, molar_mass=2000._kind_phys, & - errcode=errflg, errmsg=errmsg) - call check_errflg(subname//'.initialize', errflg, errmsg, errflg_final) - if (errflg == 0) then - call test_host_ccpp_register_constituents(host_constituents, & - errmsg=errmsg, errflg=errflg) - end if - if (errflg /= 0) then - write(6, '(2a)') 'ERROR register_constituents: ', trim(errmsg) - retval = .false. - return - end if - ! Check number of advected constituents - if (errflg == 0) then - call test_host_ccpp_number_constituents(num_advected, errmsg=errmsg, & - errflg=errflg) - call check_errflg(subname//".num_advected", errflg, errmsg, errflg_final) - end if - if (num_advected /= 6) then - write(6, '(a,i0)') "ERROR: num advected constituents = ", num_advected - retval = .false. - return - end if - ! Initialize constituent data - call test_host_ccpp_initialize_constituents(ncols, pver, errflg, errmsg) - - ! Stop tests here if initialization failed (as all other tests will likely - ! fail as well: - if (errflg /= 0) then - retval = .false. - return - end if - - ! Initialize our 'data' - const_ptr => test_host_constituents_array() - - ! Check if the specific humidity index can be found: - call test_host_const_get_index('specific_humidity', index, & - errflg, errmsg) - call check_errflg(subname//".index_specific_humidity", errflg, errmsg, & - errflg_final) - - ! Check if the cloud liquid index can be found: - call test_host_const_get_index('cloud_liquid_dry_mixing_ratio', & - index_liq, errflg, errmsg) - call check_errflg(subname//".index_cld_liq", errflg, errmsg, & - errflg_final) - - ! Check if the cloud ice index can be found: - call test_host_const_get_index('cloud_ice_dry_mixing_ratio', & - index_ice, errflg, errmsg) - call check_errflg(subname//".index_cld_ice", errflg, errmsg, & - errflg_final) - - ! Check if the dynamic constituents indices can be found - call test_host_const_get_index('dyn_const1', index_dyn1, errflg, errmsg) - call check_errflg(subname//".index_dyn_const1", errflg, errmsg, & - errflg_final) - call test_host_const_get_index('dyn_const2_wrt_moist_air', index_dyn2, errflg, errmsg) - call check_errflg(subname//".index_dyn_const2", errflg, errmsg, & - errflg_final) - call test_host_const_get_index('dyn_const3_wrt_moist_air_and_condensed_water', index_dyn3, errflg, errmsg) - call check_errflg(subname//".index_dyn_const3", errflg, errmsg, & - errflg_final) - - ! Load up the test array indices - call test_host_const_get_index(const_std_name, test_scalar_const_index, errflg, errmsg) - call check_errflg(subname//"."//const_std_name, errflg, errmsg, & - errflg_final) - do sind = 1, num_consts - call test_host_const_get_index(std_name_array(sind), & - test_const_indices(sind), errflg, errmsg) - call check_errflg(subname//"."//std_name_array(sind), errflg, errmsg, & - errflg_final) + 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 - - ! Stop tests here if the index checks failed, as all other tests will - ! likely fail as well: - if (errflg_final /= 0) then - retval = .false. - return - end if - - call init_data(const_ptr, index, index_liq, index_ice, index_dyn3) - - ! Check some constituent properties - ! ++++++++++++++++++++++++++++++++++ - - const_props => test_host_model_const_properties() - - ! Standard name: - call const_props(index)%standard_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get standard_name for specific_humidity, index = ", & - index, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'specific_humidity') then - write(6, *) "ERROR: standard name, '", trim(const_str), & - "' should be 'specific_humidity'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check standard name for a dynamic constituent - call const_props(index_dyn2)%standard_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get standard_name for dyn_const2, index = ", & - index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'dyn_const2_wrt_moist_air') then - write(6, *) "ERROR: standard name, '", trim(const_str), & - "' should be 'dyn_const2_wrt_moist_air'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - - ! Long name: - call const_props(index_liq)%long_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get long_name for cld_liq index = ", & - index_liq, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'Cloud liquid dry mixing ratio') then - write(6, *) "ERROR: long name, '", trim(const_str), & - "' should be 'Cloud liquid dry mixing ratio'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check long name for a dynamic constituent - call const_props(index_dyn1)%long_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get long_name for dyn_const1 index = ", & - index_dyn1, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if + end if + !!! Return here if any check failed + if (.not. retval) then + return + end if + + errflg = 0 + errmsg = '' + + ! Check that is_scheme_constituent works as expected + call test_host_ccpp_is_scheme_constituent('specific_humidity', & + is_constituent, errflg, errmsg) + call check_errflg(subname // "_ccpp_is_scheme_constituent", errflg, & + errmsg, errflg_final) + ! specific_humidity should not be an existing constituent + if (is_constituent) then + write(6, *) "ERROR: specific humidity is already a constituent" + errflg_final = -1 ! Notify test script that a failure occurred + end if + call test_host_ccpp_is_scheme_constituent('cloud_ice_dry_mixing_ratio', & + is_constituent, errflg, errmsg) + call check_errflg(subname // "_ccpp_is_scheme_constituent", errflg, & + errmsg, errflg_final) + ! cloud_ice_dry_mixing_ratio should be an existing constituent + if (.not. is_constituent) then + write(6, *) "ERROR: cloud_ice_dry_mixing ratio not found in ", & + "host cap constituent list" + errflg_final = -1 ! Notify test script that a failure occurred + end if + + ! Use the suite information to call the register phase + do sind = 1, num_suites if (errflg == 0) then - if (trim(const_str) /= 'dyn const1') then - write(6, *) "ERROR: long name, '", trim(const_str), & - "' should be 'dyn const1'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Diagnostic name: - call const_props(index_liq)%diagnostic_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get diagnostic name for cld_liq index = ", & - index_liq, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'CLDLIQ') then - write(6, *) "ERROR: diagnostic name, '", trim(const_str), & - "' should be 'CLDLIQ'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check default diagnostic name is set correctly - call const_props(index_ice)%diagnostic_name(const_str, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get diagnostic name for cld_ice index = ", & - index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'cld_ice_array') then - write(6, *) "ERROR: diagnostic name, '", trim(const_str), & - "' should be 'cld_ice_array'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check diagnostic name of a dynamic constituent - call const_props(index_dyn2)%diagnostic_name(const_str, errflg, & - errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get diagnostic name for dyn_const2 index = ", & - index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (trim(const_str) /= 'DYNCONST2') then - write(6, *) "ERROR: diagnostic name, '", trim(const_str), & - "' should be 'DYNCONST2'" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Mass mixing ratio: - call const_props(index_ice)%is_mass_mixing_ratio(const_log, errflg, & - errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get mass mixing ratio prop for cld_ice index = ", & - index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if - if (errflg == 0) then - if (.not. const_log) then - write(6, *) "ERROR: cloud ice is not a mass mixing_ratio" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check mass mixing ratio for a dynamic constituent - call const_props(index_dyn2)%is_mass_mixing_ratio(const_log, errflg, & - errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get mass mixing ratio prop for dyn_const2 index = ", & - index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occured - end if + 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) + exit + end if + end if + end do + + ! Register the constituents to find out what needs advecting + ! DO A COUPLE OF TESTS FIRST + + ! First confirm the correct error occurs if you try to add an + ! incompatible constituent with the same standard name + expected_error = 'ccp_model_const_add_metadata ERROR: Trying to add ' //& + 'constituent specific_humidity but an incompatible ' // & + 'constituent with this name already exists' + allocate(host_constituents(2)) + call host_constituents(1)%instantiate(std_name="specific_humidity", & + long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & + vertical_dim="vertical_layer_dimension", advected=.true., & + min_value=1000._kind_phys, molar_mass=2000._kind_phys, & + errcode=errflg, errmsg=errmsg) + call host_constituents(2)%instantiate(std_name="specific_humidity", & + long_name="Specific humidity", diag_name='H2O', units="kg kg", & + vertical_dim="vertical_layer_dimension", advected=.true., & + min_value=1000._kind_phys, molar_mass=2000._kind_phys, & + errcode=errflg, errmsg=errmsg) + call check_errflg(subname // '.initialize', errflg, errmsg, errflg_final) + if (errflg == 0) then + call test_host_ccpp_register_constituents(host_constituents, & + errmsg=errmsg, errflg=errflg) + end if + ! Check the error + if (errflg == 0) then + write(6, '(2a)') 'ERROR register_constituents: expected this error: ', & + trim(expected_error) + else + if (trim(errmsg) /= trim(expected_error)) then + write(6, '(4a)') 'ERROR register_constituents: expected this error: ', & + trim(expected_error), ' Got: ', trim(errmsg) + end if + end if + ! Now try again but with a compatible constituent - should be ignored when + ! the constituents object is created + ! Use the suite information to call the register phase + errflg = 0 + call test_host_ccpp_deallocate_dynamic_constituents() + deallocate(host_constituents) + do sind = 1, num_suites if (errflg == 0) then - if (.not. const_log) then - write(6, *) "ERROR: dyn_const2 is not a mass mixing_ratio" - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Dry mixing ratio: - call const_props(index_ice)%is_dry(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get dry prop for cld_ice index = ", index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (.not. const_log) then - write(6, *) "ERROR: cloud ice mass_mixing_ratio is not dry" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check wet mixing ratio for dynamic constituent 1 - call const_props(index_dyn1)%is_dry(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get dry prop for dyn_const1 index = ", index_dyn1, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (const_log) then - write(6, *) "ERROR: dyn_const1 is dry and should be wet" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_dyn1)%is_wet(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get wet prop for dyn_const1 index = ", index_dyn1, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (.not. const_log) then - write(6, *) "ERROR: dyn_const1 is not wet but should be" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check moist mixing ratio for dynamic constituent 2 - call const_props(index_dyn2)%is_dry(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get dry prop for dyn_const2 index = ", index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (const_log) then - write(6, *) "ERROR: dyn_const2 is dry and should be moist" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_dyn2)%is_moist(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get moist prop for dyn_const2 index = ", index_dyn2, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (.not. const_log) then - write(6, *) "ERROR: dyn_const2 is not moist but should be" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! Check dry mixing ratio for dynamic constituent 3 - call const_props(index_dyn3)%is_dry(const_log, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get dry prop for dyn_const3 index = ", index_dyn3, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (.not. const_log) then - write(6, *) "ERROR: dyn_const3 is not dry and should be" - errflg_final = -1 - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! ------------------- - - ! ------------------- - ! minimum value tests: - ! ------------------- - - ! Check that a constituent's minimum value defaults to zero: - call const_props(index_dyn2)%minimum(check_value, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get minimum value for dyn_const2 index = ", index_dyn2, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (check_value /= 0._kind_phys) then ! Should be zero - write(6, *) "ERROR: 'minimum' should default to zero for all ", & - "constituents unless set by host model or scheme metadata." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Check that a constituent instantiated with a specified minimum value - ! actually contains that minimum value property: + 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) + exit + end if + end if + end do + allocate(host_constituents(2)) + call host_constituents(1)%instantiate(std_name="specific_humidity", & + long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & + vertical_dim="vertical_layer_dimension", advected=.true., & + min_value=1000._kind_phys, molar_mass=2000._kind_phys, & + errcode=errflg, errmsg=errmsg) + call host_constituents(2)%instantiate(std_name="specific_humidity", & + long_name="Specific humidity", diag_name='H2O', units="kg kg-1", & + vertical_dim="vertical_layer_dimension", advected=.true., & + min_value=1000._kind_phys, molar_mass=2000._kind_phys, & + errcode=errflg, errmsg=errmsg) + call check_errflg(subname // '.initialize', errflg, errmsg, errflg_final) + if (errflg == 0) then + call test_host_ccpp_register_constituents(host_constituents, & + errmsg=errmsg, errflg=errflg) + end if + if (errflg /= 0) then + write(6, '(2a)') 'ERROR register_constituents: ', trim(errmsg) + retval = .false. + return + end if + ! Check number of advected constituents + if (errflg == 0) then + call test_host_ccpp_number_constituents(num_advected, errmsg=errmsg, & + errflg=errflg) + call check_errflg(subname // ".num_advected", errflg, errmsg, errflg_final) + end if + if (num_advected /= 6) then + write(6, '(a,i0)') "ERROR: num advected constituents = ", num_advected + retval = .false. + return + end if + ! Initialize constituent data + call test_host_ccpp_initialize_constituents(ncols, pver, errflg, errmsg) + + ! Stop tests here if initialization failed (as all other tests will likely + ! fail as well: + if (errflg /= 0) then + retval = .false. + return + end if + + ! Initialize our 'data' + const_ptr => test_host_constituents_array() + + ! Check if the specific humidity index can be found: + call test_host_const_get_index('specific_humidity', index, & + errflg, errmsg) + call check_errflg(subname // ".index_specific_humidity", errflg, errmsg, & + errflg_final) + + ! Check if the cloud liquid index can be found: + call test_host_const_get_index('cloud_liquid_dry_mixing_ratio', & + index_liq, errflg, errmsg) + call check_errflg(subname // ".index_cld_liq", errflg, errmsg, & + errflg_final) + + ! Check if the cloud ice index can be found: + call test_host_const_get_index('cloud_ice_dry_mixing_ratio', & + index_ice, errflg, errmsg) + call check_errflg(subname // ".index_cld_ice", errflg, errmsg, & + errflg_final) + + ! Check if the dynamic constituents indices can be found + call test_host_const_get_index('dyn_const1', index_dyn1, errflg, errmsg) + call check_errflg(subname // ".index_dyn_const1", errflg, errmsg, & + errflg_final) + call test_host_const_get_index('dyn_const2_wrt_moist_air', index_dyn2, errflg, errmsg) + call check_errflg(subname // ".index_dyn_const2", errflg, errmsg, & + errflg_final) + call test_host_const_get_index('dyn_const3_wrt_moist_air_and_condensed_water', index_dyn3, errflg, errmsg) + call check_errflg(subname // ".index_dyn_const3", errflg, errmsg, & + errflg_final) + + ! Load up the test array indices + call test_host_const_get_index(const_std_name, test_scalar_const_index, errflg, errmsg) + call check_errflg(subname // "." // const_std_name, errflg, errmsg, & + errflg_final) + do sind = 1, num_consts + call test_host_const_get_index(std_name_array(sind), & + test_const_indices(sind), errflg, errmsg) + call check_errflg(subname // "." // std_name_array(sind), errflg, errmsg, & + errflg_final) + end do + + ! Stop tests here if the index checks failed, as all other tests will + ! likely fail as well: + if (errflg_final /= 0) then + retval = .false. + return + end if + + call init_data(const_ptr, index, index_liq, index_ice, index_dyn3) + + ! Check some constituent properties + ! ++++++++++++++++++++++++++++++++++ + + const_props => test_host_model_const_properties() + + ! Standard name: + call const_props(index)%standard_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get standard_name for specific_humidity, index = ", & + index, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'specific_humidity') then + write(6, *) "ERROR: standard name, '", trim(const_str), & + "' should be 'specific_humidity'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check standard name for a dynamic constituent + call const_props(index_dyn2)%standard_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get standard_name for dyn_const2, index = ", & + index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'dyn_const2_wrt_moist_air') then + write(6, *) "ERROR: standard name, '", trim(const_str), & + "' should be 'dyn_const2_wrt_moist_air'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Long name: + call const_props(index_liq)%long_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get long_name for cld_liq index = ", & + index_liq, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'Cloud liquid dry mixing ratio') then + write(6, *) "ERROR: long name, '", trim(const_str), & + "' should be 'Cloud liquid dry mixing ratio'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check long name for a dynamic constituent + call const_props(index_dyn1)%long_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get long_name for dyn_const1 index = ", & + index_dyn1, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'dyn const1') then + write(6, *) "ERROR: long name, '", trim(const_str), & + "' should be 'dyn const1'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Diagnostic name: + call const_props(index_liq)%diagnostic_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get diagnostic name for cld_liq index = ", & + index_liq, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'CLDLIQ') then + write(6, *) "ERROR: diagnostic name, '", trim(const_str), & + "' should be 'CLDLIQ'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check default diagnostic name is set correctly + call const_props(index_ice)%diagnostic_name(const_str, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get diagnostic name for cld_ice index = ", & + index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'cld_ice_array') then + write(6, *) "ERROR: diagnostic name, '", trim(const_str), & + "' should be 'cld_ice_array'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check diagnostic name of a dynamic constituent + call const_props(index_dyn2)%diagnostic_name(const_str, errflg, & + errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get diagnostic name for dyn_const2 index = ", & + index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (trim(const_str) /= 'DYNCONST2') then + write(6, *) "ERROR: diagnostic name, '", trim(const_str), & + "' should be 'DYNCONST2'" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Mass mixing ratio: + call const_props(index_ice)%is_mass_mixing_ratio(const_log, errflg, & + errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get mass mixing ratio prop for cld_ice index = ", & + index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (.not. const_log) then + write(6, *) "ERROR: cloud ice is not a mass mixing_ratio" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check mass mixing ratio for a dynamic constituent + call const_props(index_dyn2)%is_mass_mixing_ratio(const_log, errflg, & + errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get mass mixing ratio prop for dyn_const2 index = ", & + index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occured + end if + if (errflg == 0) then + if (.not. const_log) then + write(6, *) "ERROR: dyn_const2 is not a mass mixing_ratio" + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Dry mixing ratio: + call const_props(index_ice)%is_dry(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get dry prop for cld_ice index = ", index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (.not. const_log) then + write(6, *) "ERROR: cloud ice mass_mixing_ratio is not dry" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check wet mixing ratio for dynamic constituent 1 + call const_props(index_dyn1)%is_dry(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get dry prop for dyn_const1 index = ", index_dyn1, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (const_log) then + write(6, *) "ERROR: dyn_const1 is dry and should be wet" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_dyn1)%is_wet(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get wet prop for dyn_const1 index = ", index_dyn1, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (.not. const_log) then + write(6, *) "ERROR: dyn_const1 is not wet but should be" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check moist mixing ratio for dynamic constituent 2 + call const_props(index_dyn2)%is_dry(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get dry prop for dyn_const2 index = ", index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (const_log) then + write(6, *) "ERROR: dyn_const2 is dry and should be moist" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_dyn2)%is_moist(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get moist prop for dyn_const2 index = ", index_dyn2, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (.not. const_log) then + write(6, *) "ERROR: dyn_const2 is not moist but should be" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! Check dry mixing ratio for dynamic constituent 3 + call const_props(index_dyn3)%is_dry(const_log, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get dry prop for dyn_const3 index = ", index_dyn3, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (.not. const_log) then + write(6, *) "ERROR: dyn_const3 is not dry and should be" + errflg_final = -1 + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! ------------------- + + ! ------------------- + ! minimum value tests: + ! ------------------- + + ! Check that a constituent's minimum value defaults to zero: + call const_props(index_dyn2)%minimum(check_value, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get minimum value for dyn_const2 index = ", index_dyn2, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (check_value /= 0._kind_phys) then ! Should be zero + write(6, *) "ERROR: 'minimum' should default to zero for all ", & + "constituents unless set by host model or scheme metadata." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that a constituent instantiated with a specified minimum value + ! actually contains that minimum value property: + call const_props(index_dyn1)%minimum(check_value, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get minimum value for dyn_const1 index = ", index_dyn1, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (check_value /= 1000._kind_phys) then !Should be 1000 + write(6, *) "ERROR: 'minimum' should give a value of 1000 ", & + "for dyn_const1, as was set during instantiation." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that setting a constituent's minimum value works + ! as expected: + call const_props(index_dyn1)%set_minimum(1._kind_phys, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to set minimum value for dyn_const1 index = ", index_dyn1, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then call const_props(index_dyn1)%minimum(check_value, errflg, errmsg) if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get minimum value for dyn_const1 index = ", index_dyn1, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (check_value /= 1000._kind_phys) then !Should be 1000 - write(6, *) "ERROR: 'minimum' should give a value of 1000 ", & - "for dyn_const1, as was set during instantiation." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Check that setting a constituent's minimum value works - ! as expected: - call const_props(index_dyn1)%set_minimum(1._kind_phys, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to set minimum value for dyn_const1 index = ", index_dyn1, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - call const_props(index_dyn1)%minimum(check_value, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - " trying to get minimum value for dyn_const1 index = ", & - index_dyn1, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - end if - if (errflg == 0) then - if (check_value /= 1._kind_phys) then ! Should now be one - write(6, *) "ERROR: 'set_minimum' did not set constituent", & - " minimum value correctly." - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! ---------------------- - ! molecular weight tests: - ! ---------------------- - - ! Check that a constituent instantiated with a specified molecular - ! weight actually contains that molecular weight property value: - call const_props(index)%molar_mass(check_value, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get molecular weight for specific humidity index = ", & - index, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (check_value /= 2000._kind_phys) then ! Should be 2000 - write(6, *) "ERROR: 'molar_mass' should give a value of 2000 ", & - "for specific humidity, as was set during instantiation." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Check that setting a constituent's molecular weight works - ! as expected: - call const_props(index_ice)%set_molar_mass(1._kind_phys, errflg, & - errmsg) + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + " trying to get minimum value for dyn_const1 index = ", & + index_dyn1, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + end if + if (errflg == 0) then + if (check_value /= 1._kind_phys) then ! Should now be one + write(6, *) "ERROR: 'set_minimum' did not set constituent", & + " minimum value correctly." + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! ---------------------- + ! molecular weight tests: + ! ---------------------- + + ! Check that a constituent instantiated with a specified molecular + ! weight actually contains that molecular weight property value: + call const_props(index)%molar_mass(check_value, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get molecular weight for specific humidity index = ", & + index, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (check_value /= 2000._kind_phys) then ! Should be 2000 + write(6, *) "ERROR: 'molar_mass' should give a value of 2000 ", & + "for specific humidity, as was set during instantiation." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that setting a constituent's molecular weight works + ! as expected: + call const_props(index_ice)%set_molar_mass(1._kind_phys, errflg, & + errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to set molecular weight for cld_ice index = ", index_ice, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + call const_props(index_ice)%molar_mass(check_value, errflg, errmsg) if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to set molecular weight for cld_ice index = ", index_ice, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - call const_props(index_ice)%molar_mass(check_value, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - " trying to get molecular weight for cld_ice index = ", & - index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - end if - if (errflg == 0) then - if (check_value /= 1._kind_phys) then ! Should be equal to one - write(6, *) "ERROR: 'set_molar_mass' did not set constituent", & - " molecular weight value correctly." - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! ------------------- - ! thermo-active tests: - ! ------------------- - - ! Check that being thermodynamically active defaults to False: + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + " trying to get molecular weight for cld_ice index = ", & + index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + end if + if (errflg == 0) then + if (check_value /= 1._kind_phys) then ! Should be equal to one + write(6, *) "ERROR: 'set_molar_mass' did not set constituent", & + " molecular weight value correctly." + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! ------------------- + ! thermo-active tests: + ! ------------------- + + ! Check that being thermodynamically active defaults to False: + call const_props(index_ice)%is_thermo_active(check, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get thermo_active prop for cld_ice index = ", index_ice, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (check) then ! Should be False + write(6, *) "ERROR: 'is_thermo_active' should default to False ", & + "for all constituents unless set by host model." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that setting a constituent to be thermodynamically active works + ! as expected: + call const_props(index_ice)%set_thermo_active(.true., errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to set thermo_active prop for cld_ice index = ", index_ice, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then call const_props(index_ice)%is_thermo_active(check, errflg, errmsg) if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get thermo_active prop for cld_ice index = ", index_ice, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (check) then ! Should be False - write(6, *) "ERROR: 'is_thermo_active' should default to False ", & - "for all constituents unless set by host model." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - - ! Check that setting a constituent to be thermodynamically active works - ! as expected: - call const_props(index_ice)%set_thermo_active(.true., errflg, errmsg) + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + " trying to get thermo_active prop for cld_ice index = ", & + index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + end if + if (errflg == 0) then + if (.not. check) then ! Should now be True + write(6, *) "ERROR: 'set_thermo_active' did not set", & + " thermo_active constituent property correctly." + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! ------------------- + + ! ------------------- + ! water-species tests: + ! ------------------- + + ! Check that being a water species defaults to False: + call const_props(index_liq)%is_water_species(check, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to get water_species prop for cld_liq index = ", index_liq, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (check) then ! Should be False + write(6, *) "ERROR: 'is_water_species' should default to False ", & + "for all constituents unless set by host model." + errflg_final = -1 ! Notify test script that a failure occured + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that setting a constituent to be a water species works + ! as expected: + call const_props(index_liq)%set_water_species(.true., errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to set water_species prop for cld_liq index = ", index_liq, & + trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + call const_props(index_liq)%is_water_species(check, errflg, errmsg) if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to set thermo_active prop for cld_ice index = ", index_ice, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - call const_props(index_ice)%is_thermo_active(check, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - " trying to get thermo_active prop for cld_ice index = ", & - index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - end if - if (errflg == 0) then - if (.not. check) then ! Should now be True - write(6, *) "ERROR: 'set_thermo_active' did not set", & - " thermo_active constituent property correctly." - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! ------------------- + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + " trying to get water_species prop for cld_liq index = ", & + index_liq, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + end if + if (errflg == 0) then + if (.not. check) then ! Should now be True + write(6, *) "ERROR: 'set_water_species' did not set", & + " water_species constituent property correctly." + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + + ! Check that setting a constituent to be a water species via the + ! instantiate call works as expected + call const_props(index_dyn1)%is_water_species(check, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + "trying to get water_species prop for dyn_const1 index = ", & + index_dyn1, trim(errmsg) + end if + if (errflg == 0) then + if (.not. check) then ! Should now be True + write(6, *) "ERROR: 'water_species=.true. did not set", & + " water_species constituent property correctly" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_dyn2)%is_water_species(check, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & + "trying to get water_species prop for dyn_const2 index = ", & + index_dyn2, trim(errmsg) + end if + if (errflg == 0) then + if (check) then ! Should now be False + write(6, *) "ERROR: 'water_species=.false. did not set", & + " water_species constituent property correctly" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! ------------------- + + ! Check that setting a constituent's default value works as expected + call const_props(index_liq)%has_default(has_default, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to check for default for cld_liq index = ", index_liq, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (has_default) then + write(6, *) "ERROR: cloud liquid mass_mixing_ratio should not have default but does" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_ice)%has_default(has_default, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to check for default for cld_ice index = ", index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (.not. has_default) then + write(6, *) "ERROR: cloud ice mass_mixing_ratio should have default but doesn't" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + call const_props(index_ice)%default_value(default_value, errflg, errmsg) + if (errflg /= 0) then + write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & + "to grab default for cld_ice index = ", index_ice, trim(errmsg) + errflg_final = -1 ! Notify test script that a failure occurred + end if + if (errflg == 0) then + if (default_value /= 0.0_kind_phys) then + write(6, *) "ERROR: cloud ice mass_mixing_ratio default is ", default_value, & + " but should be 0.0" + errflg_final = -1 ! Notify test script that a failure occurred + end if + else + ! Reset error flag to continue testing other properties: + errflg = 0 + end if + ! ++++++++++++++++++++++++++++++++++ - ! ------------------- - ! water-species tests: - ! ------------------- + ! Set error flag to the "final" value, because any error + ! above will likely result in a large number of failures + ! below: + errflg = errflg_final - ! Check that being a water species defaults to False: - call const_props(index_liq)%is_water_species(check, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to get water_species prop for cld_liq index = ", index_liq, & - trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if + ! Use the suite information to setup the run + do sind = 1, num_suites if (errflg == 0) then - if (check) then ! Should be False - write(6, *) "ERROR: 'is_water_species' should default to False ", & - "for all constituents unless set by host model." - errflg_final = -1 ! Notify test script that a failure occured - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if + 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) + exit + end if + end if + end do + + ! Check indices + call check_constituent_indices(test_scalar_const_index, test_const_indices, & + errmsg, errflg) + call check_errflg(subname // " check suite indices", errflg, errmsg, & + errflg_final) + + ! Loop over time steps + do time_step = 1, num_time_steps + ! Initialize the timestep + do sind = 1, num_suites + if (errflg == 0) then + call test_host_ccpp_physics_timestep_initial( & + test_suites(sind)%suite_name, errmsg, errflg) + if (errflg /= 0) then + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(errmsg) + end if + end if + end do - ! Check that setting a constituent to be a water species works - ! as expected: - call const_props(index_liq)%set_water_species(.true., errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to set water_species prop for cld_liq index = ", index_liq, & + do col_start = 1, ncols, 5 + if (errflg /= 0) then + continue + end if + col_end = min(col_start + 4, ncols) + + do sind = 1, num_suites + do index = 1, size(test_suites(sind)%suite_parts) + 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) + 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 if + end do + end do + end do + ! Check indices + call check_constituent_indices(test_scalar_const_index, test_const_indices, & + errmsg, errflg) + call check_errflg(subname // " check suite indices", errflg, errmsg, & + errflg_final) + + do sind = 1, num_suites + 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) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - call const_props(index_liq)%is_water_species(check, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - " trying to get water_species prop for cld_liq index = ", & - index_liq, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - end if - if (errflg == 0) then - if (.not. check) then ! Should now be True - write(6, *) "ERROR: 'set_water_species' did not set", & - " water_species constituent property correctly." - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if + exit + end if + end do - ! Check that setting a constituent to be a water species via the - ! instantiate call works as expected - call const_props(index_dyn1)%is_water_species(check, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - "trying to get water_species prop for dyn_const1 index = ", & - index_dyn1, trim(errmsg) - end if + ! Run "dycore" if (errflg == 0) then - if (.not. check) then ! Should now be True - write(6,*) "ERROR: 'water_species=.true. did not set", & - " water_species constituent property correctly" - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_dyn2)%is_water_species(check, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,a,i0,/,a)') "ERROR: Error, ", errflg, & - "trying to get water_species prop for dyn_const2 index = ", & - index_dyn2, trim(errmsg) + call advect_constituents() end if - if (errflg == 0) then - if (check) then ! Should now be False - write(6,*) "ERROR: 'water_species=.false. did not set", & - " water_species constituent property correctly" - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - ! ------------------- + end do ! End time step loop - ! Check that setting a constituent's default value works as expected - call const_props(index_liq)%has_default(has_default, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to check for default for cld_liq index = ", index_liq, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if + do sind = 1, num_suites if (errflg == 0) then - if (has_default) then - write(6, *) "ERROR: cloud liquid mass_mixing_ratio should not have default but does" - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_ice)%has_default(has_default, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to check for default for cld_ice index = ", index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (.not. has_default) then - write(6, *) "ERROR: cloud ice mass_mixing_ratio should have default but doesn't" - errflg_final = -1 ! Notify test script that a failure occurred - end if - else - ! Reset error flag to continue testing other properties: - errflg = 0 - end if - call const_props(index_ice)%default_value(default_value, errflg, errmsg) - if (errflg /= 0) then - write(6, '(a,i0,2a,i0,/,a)') "ERROR: Error, ", errflg, " trying ", & - "to grab default for cld_ice index = ", index_ice, trim(errmsg) - errflg_final = -1 ! Notify test script that a failure occurred - end if - if (errflg == 0) then - if (default_value /= 0.0_kind_phys) then - write(6, *) "ERROR: cloud ice mass_mixing_ratio default is ", default_value, & - " but should be 0.0" - errflg_final = -1 ! Notify test script that a failure occurred - end if + call test_host_ccpp_physics_finalize( & + test_suites(sind)%suite_name, errmsg, errflg) + 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 if + end do + + if (errflg == 0) then + ! Run finished without error, check answers + if (compare_data(num_advected)) then + write(6, *) 'Answers are correct!' + errflg = 0 else - ! Reset error flag to continue testing other properties: - errflg = 0 + write(6, *) 'Answers are not correct!' + errflg = -1 end if - ! ++++++++++++++++++++++++++++++++++ - - ! Set error flag to the "final" value, because any error - ! above will likely result in a large number of failures - ! below: - errflg = errflg_final - - ! Use the suite information to setup the run - do sind = 1, num_suites - if (errflg == 0) then - 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) - exit - end if - end if - end do - - ! Check indices - call check_constituent_indices(test_scalar_const_index, test_const_indices, & - errmsg, errflg) - call check_errflg(subname//" check suite indices", errflg, errmsg, & - errflg_final) - - ! Loop over time steps - do time_step = 1, num_time_steps - ! Initialize the timestep - do sind = 1, num_suites - if (errflg == 0) then - call test_host_ccpp_physics_timestep_initial( & - test_suites(sind)%suite_name, errmsg, errflg) - if (errflg /= 0) then - write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(errmsg) - end if - end if - end do - - do col_start = 1, ncols, 5 - if (errflg /= 0) then - continue - end if - col_end = MIN(col_start + 4, ncols) - - do sind = 1, num_suites - do index = 1, size(test_suites(sind)%suite_parts) - 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) - 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 if - end do - end do - end do - ! Check indices - call check_constituent_indices(test_scalar_const_index, test_const_indices, & - errmsg, errflg) - call check_errflg(subname//" check suite indices", errflg, errmsg, & - errflg_final) - - do sind = 1, num_suites - 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 - - ! Run "dycore" - if (errflg == 0) then - call advect_constituents() - end if - end do ! End time step loop - - do sind = 1, num_suites - if (errflg == 0) then - call test_host_ccpp_physics_finalize( & - test_suites(sind)%suite_name, errmsg, errflg) - 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 if - end do - - if (errflg == 0) then - ! Run finished without error, check answers - if (compare_data(num_advected)) then - write(6, *) 'Answers are correct!' - errflg = 0 - else - write(6, *) 'Answers are not correct!' - errflg = -1 - end if - end if + end if - ! Make sure "final" flag is non-zero if "errflg" is: - if (errflg /= 0) then - errflg_final = -1 ! Notify test script that a failure occured - end if + ! Make sure "final" flag is non-zero if "errflg" is: + if (errflg /= 0) then + errflg_final = -1 ! Notify test script that a failure occured + end if - ! Set return value to False if any errors were found: - retval = errflg_final == 0 + ! Set return value to False if any errors were found: + retval = errflg_final == 0 - end subroutine test_host + end subroutine test_host - end module test_prog +end module test_prog diff --git a/test/advection_test/test_host_data.F90 b/test/advection_test/test_host_data.F90 index bbf0efdc..f360ad79 100644 --- a/test/advection_test/test_host_data.F90 +++ b/test/advection_test/test_host_data.F90 @@ -7,22 +7,22 @@ module test_host_data !> \section arg_table_physics_state Argument Table !! \htmlinclude arg_table_physics_state.html type physics_state - real(kind_phys), allocatable :: ps(:) ! surface pressure - real(kind_phys), allocatable :: temp(:,:) ! temperature - real(kind_phys), dimension(:,:,:), pointer :: q => NULL() ! constituent array + real(kind=kind_phys), allocatable :: ps(:) ! surface pressure + real(kind=kind_phys), allocatable :: temp(:, :) ! temperature + real(kind=kind_phys), dimension(:, :, :), pointer :: q => null() ! constituent array end type physics_state !> \section arg_table_test_host_data Argument Table !! \htmlinclude arg_table_test_host_data.html integer, public, parameter :: num_consts = 3 - character(len=32), public, parameter :: std_name_array(num_consts) = (/ & - 'specific_humidity ', & - 'cloud_liquid_dry_mixing_ratio', & - 'cloud_ice_dry_mixing_ratio ' /) + character(len=32), public, parameter :: std_name_array(num_consts) = (/ & + 'specific_humidity ', & + 'cloud_liquid_dry_mixing_ratio', & + 'cloud_ice_dry_mixing_ratio ' /) character(len=32), public, parameter :: const_std_name = std_name_array(1) - integer :: const_inds(num_consts) = -1 ! test array access from suite - integer :: const_index = -1 ! test scalar access from suite + integer :: const_inds(num_consts) = -1 ! test array access from suite + integer :: const_index = -1 ! test scalar access from suite public :: allocate_physics_state public :: check_constituent_indices @@ -30,63 +30,63 @@ module test_host_data contains subroutine check_constituent_indices(test_index, test_indices, errmsg, errflg) - ! Check constituent indices against what was found by suite - ! indices are passed in rather than looked up to avoid a dependency loop - ! Dummy arguments - integer, intent(in) :: test_index ! scalar const index from host - integer, intent(in) :: test_indices(:) ! array_test_indices from host - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variable - integer :: indx - integer :: emstrt - - errflg = 0 - errmsg = '' - if (test_index /= const_index) then + ! Check constituent indices against what was found by suite + ! indices are passed in rather than looked up to avoid a dependency loop + ! Dummy arguments + integer, intent(in) :: test_index ! scalar const index from host + integer, intent(in) :: test_indices(:) ! array_test_indices from host + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variable + integer :: indx + integer :: emstrt + + errflg = 0 + errmsg = '' + if (test_index /= const_index) then + emstrt = len_trim(errmsg) + 1 + write(errmsg(emstrt:), '(2a,i0,a,i0)') 'const_index_check for ', & + const_std_name, test_index, ' /= ', const_index + errflg = errflg + 1 + end if + do indx = 1, num_consts + if (test_indices(indx) /= const_inds(indx)) then emstrt = len_trim(errmsg) + 1 - write(errmsg(emstrt:), '(2a,i0,a,i0)') 'const_index_check for ', & - const_std_name, test_index, ' /= ', const_index - errflg = errflg + 1 - end if - do indx = 1, num_consts - if (test_indices(indx) /= const_inds(indx)) then - emstrt = len_trim(errmsg) + 1 - if (len_trim(errmsg) > 0) then - write(errmsg(emstrt:), '(", ")') - emstrt = emstrt + 2 - end if - write(errmsg(emstrt:), '(2a,i0,a,i0)') 'const_indices_check for ', & - std_name_array(indx), test_indices(indx), ' /= ', const_inds(indx) - errflg = errflg + 1 + if (len_trim(errmsg) > 0) then + write(errmsg(emstrt:), '(", ")') + emstrt = emstrt + 2 end if - end do + write(errmsg(emstrt:), '(2a,i0,a,i0)') 'const_indices_check for ', & + std_name_array(indx), test_indices(indx), ' /= ', const_inds(indx) + errflg = errflg + 1 + end if + end do - ! Reset for next test - const_index = -1 - const_inds = -1 + ! Reset for next test + const_index = -1 + const_inds = -1 end subroutine check_constituent_indices subroutine allocate_physics_state(cols, levels, constituents, state) - integer, intent(in) :: cols - integer, intent(in) :: levels - real(kind_phys), pointer :: constituents(:,:,:) + integer, intent(in) :: cols + integer, intent(in) :: levels + real(kind=kind_phys), pointer :: constituents(:, :, :) type(physics_state), intent(out) :: state if (allocated(state%ps)) then - deallocate(state%ps) + deallocate(state%ps) end if allocate(state%ps(cols)) state%ps = 0.0_kind_phys if (allocated(state%temp)) then - deallocate(state%temp) + deallocate(state%temp) end if allocate(state%temp(cols, levels)) if (associated(state%q)) then - ! Do not deallocate (we do not own this array) - nullify(state%q) + ! Do not deallocate (we do not own this array) + nullify(state%q) end if ! Point to the advected constituents array state%q => constituents diff --git a/test/advection_test/test_host_mod.F90 b/test/advection_test/test_host_mod.F90 index 50826f17..5099b9c1 100644 --- a/test/advection_test/test_host_mod.F90 +++ b/test/advection_test/test_host_mod.F90 @@ -1,175 +1,176 @@ module test_host_mod - use ccpp_kinds, only: kind_phys - use test_host_data, only: physics_state, allocate_physics_state - - implicit none - public - - integer, parameter :: num_time_steps = 2 - real(kind_phys), parameter :: tolerance = 1.0e-13_kind_phys - - !> \section arg_table_test_host_mod Argument Table - !! \htmlinclude arg_table_test_host_mod.html - !! - integer, parameter :: ncols = 10 - integer, parameter :: pver = 5 - integer, parameter :: pverP = pver + 1 - integer, protected :: ncnst = -1 - integer, protected :: index_qv = -1 - real(kind_phys) :: dt - real(kind_phys), parameter :: tfreeze = 273.15_kind_phys - type(physics_state) :: phys_state - integer :: num_model_times = -1 - integer, allocatable :: model_times(:) - - public :: init_data - public :: compare_data - public :: twist_array - - real(kind_phys), private, allocatable :: check_vals(:,:,:) - real(kind_phys), private :: check_temp(ncols, pver) - integer, private :: ind_liq = -1 - integer, private :: ind_ice = -1 + use ccpp_kinds, only: kind_phys + use test_host_data, only: physics_state, & + allocate_physics_state + + implicit none + public + + integer, parameter :: num_time_steps = 2 + real(kind=kind_phys), parameter :: tolerance = 1.0e-13_kind_phys + + !> \section arg_table_test_host_mod Argument Table + !! \htmlinclude arg_table_test_host_mod.html + !! + integer, parameter :: ncols = 10 + integer, parameter :: pver = 5 + integer, parameter :: pverp = pver + 1 + integer, protected :: ncnst = -1 + integer, protected :: index_qv = -1 + real(kind=kind_phys) :: dt + real(kind=kind_phys), parameter :: tfreeze = 273.15_kind_phys + type(physics_state) :: phys_state + integer :: num_model_times = -1 + integer, allocatable :: model_times(:) + + public :: init_data + public :: compare_data + public :: twist_array + + real(kind=kind_phys), private, allocatable :: check_vals(:, :, :) + real(kind=kind_phys), private :: check_temp(ncols, pver) + integer, private :: ind_liq = -1 + integer, private :: ind_ice = -1 contains - subroutine init_data(constituent_array, index_qv_use, index_liq, index_ice, index_dyn) - - ! Dummy arguments - real(kind_phys), pointer :: constituent_array(:,:,:) ! From host & suites - integer, intent(in) :: index_qv_use - integer, intent(in) :: index_liq - integer, intent(in) :: index_ice - integer, intent(in) :: index_dyn - - ! Local variables - integer :: col - integer :: lev - integer :: cind - integer :: itime - real(kind_phys) :: qmax - real(kind_phys), parameter :: inc = 0.1_kind_phys - - ! Allocate and initialize state - ! Temperature starts above freezing and decreases to -30C - ! water vapor is initialized in odd columns to different amounts - ncnst = SIZE(constituent_array, 3) - call allocate_physics_state(ncols, pver, constituent_array, phys_state) - index_qv = index_qv_use - ind_liq = index_liq - ind_ice = index_ice - allocate(check_vals(ncols, pver, ncnst)) - check_vals(:,:,:) = 0.0_kind_phys - check_vals(:,:,index_dyn) = 1.0_kind_phys - do lev = 1, pver - phys_state%temp(:, lev) = tfreeze + (10.0_kind_phys * (lev - 3)) - qmax = real(lev, kind_phys) - do col = 1, ncols - if (mod(col, 2) == 1) then - phys_state%q(col, lev, index_qv) = qmax - else - phys_state%q(col, lev, index_qv) = 0.0_kind_phys - end if - end do + subroutine init_data(constituent_array, index_qv_use, index_liq, index_ice, index_dyn) + + ! Dummy arguments + real(kind=kind_phys), pointer :: constituent_array(:, :, :) ! From host & suites + integer, intent(in) :: index_qv_use + integer, intent(in) :: index_liq + integer, intent(in) :: index_ice + integer, intent(in) :: index_dyn + + ! Local variables + integer :: col + integer :: lev + integer :: cind + integer :: itime + real(kind=kind_phys) :: qmax + real(kind=kind_phys), parameter :: inc = 0.1_kind_phys + + ! Allocate and initialize state + ! Temperature starts above freezing and decreases to -30C + ! water vapor is initialized in odd columns to different amounts + ncnst = size(constituent_array, 3) + call allocate_physics_state(ncols, pver, constituent_array, phys_state) + index_qv = index_qv_use + ind_liq = index_liq + ind_ice = index_ice + allocate(check_vals(ncols, pver, ncnst)) + check_vals(:, :, :) = 0.0_kind_phys + check_vals(:, :, index_dyn) = 1.0_kind_phys + do lev = 1, pver + phys_state%temp(:, lev) = tfreeze + (10.0_kind_phys * (lev - 3)) + qmax = real(lev, kind_phys) + do col = 1, ncols + if (mod(col, 2) == 1) then + phys_state%q(col, lev, index_qv) = qmax + else + phys_state%q(col, lev, index_qv) = 0.0_kind_phys + end if end do - check_vals(:,:,index_qv) = phys_state%q(:,:,index_qv) - check_temp(:,:) = phys_state%temp(:,:) - ! Do timestep 1 - do col = 1, ncols, 2 - check_temp(col, 1) = check_temp(col, 1) + 0.5_kind_phys - check_vals(col, 1, index_qv) = check_vals(col, 1, index_qv) - inc - check_vals(col, 1, ind_liq) = check_vals(col, 1, ind_liq) + inc + end do + check_vals(:, :, index_qv) = phys_state%q(:, :, index_qv) + check_temp(:, :) = phys_state%temp(:, :) + ! Do timestep 1 + do col = 1, ncols, 2 + check_temp(col, 1) = check_temp(col, 1) + 0.5_kind_phys + check_vals(col, 1, index_qv) = check_vals(col, 1, index_qv) - inc + check_vals(col, 1, ind_liq) = check_vals(col, 1, ind_liq) + inc + end do + do itime = 1, num_time_steps + do cind = 1, ncnst + call twist_array(check_vals(:, :, cind)) end do - do itime = 1, num_time_steps - do cind = 1, ncnst - call twist_array(check_vals(:,:,cind)) - end do + end do + + end subroutine init_data + + subroutine twist_array(array) + ! Dummy argument + real(kind=kind_phys), intent(inout) :: array(:, :) + + ! Local variables + integer :: icol, ilev ! Field coordinates + integer :: idir ! 'w' sign + integer :: levb, leve ! Starting and ending level indices + real(kind=kind_phys) :: last_val, next_val + + idir = 1 + leve = (pver * mod(ncols, 2)) + mod(ncols - 1, 2) + last_val = array(ncols, leve) + do icol = 1, ncols + levb = ((pver * (1 - idir)) + (1 + idir)) / 2 + leve = ((pver * (1 + idir)) + (1 - idir)) / 2 + do ilev = levb, leve, idir + next_val = array(icol, ilev) + array(icol, ilev) = last_val + last_val = next_val end do - - end subroutine init_data - - subroutine twist_array(array) - ! Dummy argument - real(kind_phys), intent(inout) :: array(:,:) - - ! Local variables - integer :: icol, ilev ! Field coordinates - integer :: idir ! 'w' sign - integer :: levb, leve ! Starting and ending level indices - real(kind_phys) :: last_val, next_val - - idir = 1 - leve = (pver * mod(ncols, 2)) + mod(ncols-1, 2) - last_val = array(ncols, leve) - do icol = 1, ncols - levb = ((pver * (1 - idir)) + (1 + idir)) / 2 - leve = ((pver * (1 + idir)) + (1 - idir)) / 2 - do ilev = levb, leve, idir - next_val = array(icol, ilev) - array(icol, ilev) = last_val - last_val = next_val - end do - idir = -1 * idir - end do - - end subroutine twist_array - - logical function compare_data(ncnst) - - integer, intent(in) :: ncnst - - integer :: col - integer :: lev - integer :: cind - logical :: need_header - real(kind_phys) :: check - real(kind_phys) :: denom - - compare_data = .true. - - need_header = .true. + idir = -1 * idir + end do + + end subroutine twist_array + + logical function compare_data(ncnst) + + integer, intent(in) :: ncnst + + integer :: col + integer :: lev + integer :: cind + logical :: need_header + real(kind=kind_phys) :: check + real(kind=kind_phys) :: denom + + compare_data = .true. + + need_header = .true. + do lev = 1, pver + do col = 1, ncols + check = check_temp(col, lev) + if (abs((phys_state%temp(col, lev) - check) / check) > & + 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, & + phys_state%temp(col, lev), check + compare_data = .false. + end if + end do + end do + ! Check constituents + need_header = .true. + do cind = 1, ncnst do lev = 1, pver - do col = 1, ncols - check = check_temp(col, lev) - if (abs((phys_state%temp(col, lev) - check) / check) > & - 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, & - phys_state%temp(col, lev), check - compare_data = .false. + do col = 1, ncols + check = check_vals(col, lev, cind) + if (check < tolerance) then + denom = 1.0_kind_phys + else + denom = check + end if + if (abs((phys_state%q(col, lev, cind) - check) / denom) > & + 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 - end do - end do - ! Check constituents - need_header = .true. - do cind = 1, ncnst - do lev = 1, pver - do col = 1, ncols - check = check_vals(col, lev, cind) - if (check < tolerance) then - denom = 1.0_kind_phys - else - denom = check - end if - if (abs((phys_state%q(col, lev, cind) - check) / denom) > & - 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), check - compare_data = .false. - end if - end do - end do + write(6, '(3i5,2(3x,es15.7))') col, lev, cind, & + phys_state%q(col, lev, cind), check + compare_data = .false. + end if + end do end do + end do - end function compare_data + end function compare_data end module test_host_mod diff --git a/test/capgen_test/adjust/temp_kinds.F90 b/test/capgen_test/adjust/temp_kinds.F90 index 59e813e5..3fb4cca4 100644 --- a/test/capgen_test/adjust/temp_kinds.F90 +++ b/test/capgen_test/adjust/temp_kinds.F90 @@ -3,10 +3,10 @@ module temp_kinds - implicit none - private + implicit none + private - integer, public, parameter :: temp_r8 = selected_real_kind(12) !8-byte real - integer, public, parameter :: temp_i8 = selected_int_kind (13) !8-byte integer + integer, public, parameter :: temp_r8 = selected_real_kind(12) !8-byte real + integer, public, parameter :: temp_i8 = selected_int_kind(13) !8-byte integer end module temp_kinds diff --git a/test/capgen_test/source_dir1/environ_conditions.F90 b/test/capgen_test/source_dir1/environ_conditions.F90 index 62183012..2d63366e 100644 --- a/test/capgen_test/source_dir1/environ_conditions.F90 +++ b/test/capgen_test/source_dir1/environ_conditions.F90 @@ -1,51 +1,51 @@ -MODULE environ_conditions +module environ_conditions - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys - IMPLICIT NONE - PRIVATE + implicit none + private - PUBLIC :: environ_conditions_init - PUBLIC :: environ_conditions_run - PUBLIC :: environ_conditions_finalize + public :: environ_conditions_init + public :: environ_conditions_run + public :: environ_conditions_finalize integer, parameter :: input_model_times = 3 integer, parameter :: input_model_values(input_model_times) = (/ 31, 37, 41 /) -CONTAINS +contains -!> \section arg_table_environ_conditions_run Argument Table -!! \htmlinclude arg_table_environ_conditions_run.html -!! + !> \section arg_table_environ_conditions_run Argument Table + !! \htmlinclude arg_table_environ_conditions_run.html + !! subroutine environ_conditions_run(psurf, errmsg, errflg) ! This routine currently does nothing -- should update values - real(kind_phys), intent(in) :: psurf(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(in) :: psurf(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 - END SUBROUTINE environ_conditions_run + end subroutine environ_conditions_run -!> \section arg_table_environ_conditions_init Argument Table -!! \htmlinclude arg_table_environ_conditions_init.html -!! - subroutine environ_conditions_init (nbox, O3, HNO3, ntimes, model_times, & - errmsg, errflg) + !> \section arg_table_environ_conditions_init Argument Table + !! \htmlinclude arg_table_environ_conditions_init.html + !! + subroutine environ_conditions_init(nbox, o3, hno3, ntimes, model_times, & + errmsg, errflg) - integer, intent(in) :: nbox - real(kind_phys), intent(out) :: O3(:) - real(kind_phys), intent(out) :: HNO3(:) - integer, intent(out) :: ntimes - integer, allocatable, intent(out) :: model_times(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg -!---------------------------------------------------------------- + integer, intent(in) :: nbox + real(kind=kind_phys), intent(out) :: o3(:) + real(kind=kind_phys), intent(out) :: hno3(:) + integer, intent(out) :: ntimes + integer, allocatable, intent(out) :: model_times(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- - integer :: i, j + integer :: i, j errmsg = '' errflg = 0 @@ -53,8 +53,8 @@ subroutine environ_conditions_init (nbox, O3, HNO3, ntimes, model_times, & ! This may be replaced with MusicBox json environmental conditions reader??? do i = 1, nbox - O3(i) = real(i, kind_phys) * 1.e-6_kind_phys - HNO3(i) = real(i, kind_phys) * 1.e-9_kind_phys + o3(i) = real(i, kind_phys) * 1.e-6_kind_phys + hno3(i) = real(i, kind_phys) * 1.e-9_kind_phys end do ntimes = input_model_times @@ -63,34 +63,34 @@ subroutine environ_conditions_init (nbox, O3, HNO3, ntimes, model_times, & end subroutine environ_conditions_init -!> \section arg_table_environ_conditions_finalize Argument Table -!! \htmlinclude arg_table_environ_conditions_finalize.html -!! - subroutine environ_conditions_finalize (ntimes, model_times, errmsg, errflg) + !> \section arg_table_environ_conditions_finalize Argument Table + !! \htmlinclude arg_table_environ_conditions_finalize.html + !! + subroutine environ_conditions_finalize(ntimes, model_times, errmsg, errflg) - integer, intent(in) :: ntimes - integer, intent(in) :: model_times(:) + integer, intent(in) :: ntimes + integer, intent(in) :: model_times(:) character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(out) :: errflg ! This routine checks the size and values of model_times if (ntimes /= input_model_times) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'ntimes mismatch, ', ntimes, ' should be ', & - input_model_times + errflg = 1 + write(errmsg, '(2(a,i0))') 'ntimes mismatch, ', ntimes, ' should be ', & + input_model_times else if (size(model_times) /= input_model_times) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'model_times size mismatch, ', & - size(model_times), ' should be ', input_model_times - else if (ANY(model_times /= input_model_values)) then - errflg = 1 - write(errmsg, *) 'model_times mismatch, ', & - model_times, ' should be ', input_model_values + errflg = 1 + write(errmsg, '(2(a,i0))') 'model_times size mismatch, ', & + size(model_times), ' should be ', input_model_times + else if (any(model_times /= input_model_values)) then + errflg = 1 + write(errmsg, *) 'model_times mismatch, ', & + model_times, ' should be ', input_model_values else - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 end if end subroutine environ_conditions_finalize -END MODULE environ_conditions +end module environ_conditions diff --git a/test/capgen_test/source_dir2/temp_set.F90 b/test/capgen_test/source_dir2/temp_set.F90 index 0a0aa92c..be54b80c 100644 --- a/test/capgen_test/source_dir2/temp_set.F90 +++ b/test/capgen_test/source_dir2/temp_set.F90 @@ -1,83 +1,84 @@ !Test 3D parameterization ! -MODULE temp_set - - USE ccpp_kinds, ONLY: kind_phys, kind_temp - - IMPLICIT NONE - PRIVATE - - PUBLIC :: temp_set_init - PUBLIC :: temp_set_timestep_initialize - PUBLIC :: temp_set_run - PUBLIC :: temp_set_finalize - -CONTAINS - -!> \section arg_table_temp_set_run Argument Table -!! \htmlinclude arg_table_temp_set_run.html -!! - SUBROUTINE temp_set_run(ncol, lev, timestep, temp_level, temp_diag, temp, ps, & - to_promote, promote_pcnst, slev_lbound, soil_levs, var_array, errmsg, errflg) -!---------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------- - - integer, intent(in) :: ncol, lev, slev_lbound - REAL(kind_phys), intent(out) :: temp(:,:) - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(in) :: ps(:) - REAL(kind_phys), INTENT(inout) :: temp_level(:, :) - real(kind_phys), intent(inout) :: temp_diag(:,:) - real(kind_phys), intent(inout) :: soil_levs(slev_lbound:) - real(kind_phys), intent(inout) :: var_array(:,:,:,:) - real(kind_temp), intent(out) :: to_promote(:, :) - real(kind_phys), intent(out) :: promote_pcnst(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg -!---------------------------------------------------------------- - integer :: ilev - - integer :: col_index - integer :: lev_index - real(kind_phys) :: internal_scalar_var +module temp_set + + use ccpp_kinds, only: kind_phys, & + kind_temp + + implicit none + private + + public :: temp_set_init + public :: temp_set_timestep_initialize + public :: temp_set_run + public :: temp_set_finalize + +contains + + !> \section arg_table_temp_set_run Argument Table + !! \htmlinclude arg_table_temp_set_run.html + !! + subroutine temp_set_run(ncol, lev, timestep, temp_level, temp_diag, temp, ps, & + to_promote, promote_pcnst, slev_lbound, soil_levs, var_array, errmsg, errflg) + !---------------------------------------------------------------- + implicit none + !---------------------------------------------------------------- + + integer, intent(in) :: ncol, lev, slev_lbound + real(kind=kind_phys), intent(out) :: temp(:, :) + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(in) :: ps(:) + real(kind=kind_phys), intent(inout) :: temp_level(:, :) + real(kind=kind_phys), intent(inout) :: temp_diag(:, :) + real(kind=kind_phys), intent(inout) :: soil_levs(slev_lbound:) + real(kind=kind_phys), intent(inout) :: var_array(:, :, :, :) + real(kind=kind_temp), intent(out) :: to_promote(:, :) + real(kind=kind_phys), intent(out) :: promote_pcnst(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + integer :: ilev + + integer :: col_index + integer :: lev_index + real(kind=kind_phys) :: internal_scalar_var errmsg = '' errflg = 0 ilev = size(temp_level, 2) if (ilev /= (lev + 1)) then - errflg = 1 - errmsg = 'Invalid value for ilev, must be lev+1' - return + errflg = 1 + errmsg = 'Invalid value for ilev, must be lev+1' + return end if do col_index = 1, ncol - do lev_index = 1, lev - temp(col_index, lev_index) = (temp_level(col_index, lev_index) & - + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys - end do + do lev_index = 1, lev + temp(col_index, lev_index) = (temp_level(col_index, lev_index) & + + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys + end do end do - var_array(:,:,:,:) = 1._kind_phys + var_array(:, :, :, :) = 1._kind_phys ! internal_scalar_var = soil_levs(slev_lbound) internal_scalar_var = soil_levs(0) - END SUBROUTINE temp_set_run + end subroutine temp_set_run -!> \section arg_table_temp_set_init Argument Table -!! \htmlinclude arg_table_temp_set_init.html -!! + !> \section arg_table_temp_set_init Argument Table + !! \htmlinclude arg_table_temp_set_init.html + !! subroutine temp_set_init(temp_inc_in, fudge, temp_inc_set, errmsg, errflg) - real(kind_phys), intent(in) :: temp_inc_in - real(kind_phys), intent(in) :: fudge - real(kind_phys), intent(out) :: temp_inc_set - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(in) :: temp_inc_in + real(kind=kind_phys), intent(in) :: fudge + real(kind=kind_phys), intent(out) :: temp_inc_set + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg temp_inc_set = temp_inc_in @@ -86,17 +87,17 @@ subroutine temp_set_init(temp_inc_in, fudge, temp_inc_set, errmsg, errflg) end subroutine temp_set_init -!> \section arg_table_temp_set_timestep_initialize Argument Table -!! \htmlinclude arg_table_temp_set_timestep_initialize.html -!! - subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & - errmsg, errflg) + !> \section arg_table_temp_set_timestep_initialize Argument Table + !! \htmlinclude arg_table_temp_set_timestep_initialize.html + !! + subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & + errmsg, errflg) - integer, intent(in) :: ncol - real(kind_phys), intent(in) :: temp_inc - real(kind_phys), intent(inout) :: temp_level(:,:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + real(kind=kind_phys), intent(in) :: temp_inc + real(kind=kind_phys), intent(inout) :: temp_level(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 @@ -105,13 +106,13 @@ subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & end subroutine temp_set_timestep_initialize -!> \section arg_table_temp_set_finalize Argument Table -!! \htmlinclude arg_table_temp_set_finalize.html -!! + !> \section arg_table_temp_set_finalize Argument Table + !! \htmlinclude arg_table_temp_set_finalize.html + !! subroutine temp_set_finalize(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 @@ -120,4 +121,4 @@ subroutine temp_set_finalize(errmsg, errflg) end subroutine temp_set_finalize -END MODULE temp_set +end module temp_set diff --git a/test/capgen_test/temp_adjust.F90 b/test/capgen_test/temp_adjust.F90 index 35c951e0..e8ac281d 100644 --- a/test/capgen_test/temp_adjust.F90 +++ b/test/capgen_test/temp_adjust.F90 @@ -3,7 +3,8 @@ module temp_adjust - use ccpp_kinds, only: kind_phys, kind_temp + use ccpp_kinds, only: kind_phys, & + kind_temp implicit none private @@ -67,7 +68,7 @@ subroutine temp_adjust_run(foo, timestep, interstitial_var, temp_prev, temp_laye return end if - if (.not.module_level_config) then + if (.not. module_level_config) then ! do nothing return end if diff --git a/test/capgen_test/test_capgen_host_integration.F90 b/test/capgen_test/test_capgen_host_integration.F90 index eb11f2f8..7f964178 100644 --- a/test/capgen_test/test_capgen_host_integration.F90 +++ b/test/capgen_test/test_capgen_host_integration.F90 @@ -1,5 +1,8 @@ program test - use test_prog, only: test_host, suite_info, cm, cs + use test_prog, only: test_host, & + suite_info, & + cm, & + cs implicit none diff --git a/test/capgen_test/test_host.F90 b/test/capgen_test/test_host.F90 index 6e39c787..258f0d91 100644 --- a/test/capgen_test/test_host.F90 +++ b/test/capgen_test/test_host.F90 @@ -106,7 +106,8 @@ subroutine test_host(retval, test_suites) #ifdef _OPENMP use omp_lib #endif - use test_host_mod, only: ncols, num_time_steps + 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 @@ -114,7 +115,9 @@ subroutine test_host(retval, test_suites) 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_host_mod, only: init_data, & + compare_data, & + check_model_times use test_utils, only: check_list type(suite_info), intent(in) :: test_suites(:) @@ -156,7 +159,7 @@ subroutine test_host(retval, test_suites) end do end if !!! Return here if any check failed - if (.not.retval) then + if (.not. retval) then return end if @@ -284,7 +287,7 @@ subroutine test_host(retval, test_suites) if (errflg == 0) then ! Run finished without error, check answers - if (.not.check_model_times()) then + if (.not. check_model_times()) then write(6, *) 'Model times error!' errflg = -1 else if (compare_data()) then diff --git a/test/capgen_test/test_host_mod.F90 b/test/capgen_test/test_host_mod.F90 index aecc5f15..48ee959b 100644 --- a/test/capgen_test/test_host_mod.F90 +++ b/test/capgen_test/test_host_mod.F90 @@ -1,7 +1,8 @@ module test_host_mod use ccpp_kinds, only: kind_phys - use test_host_data, only: physics_state, allocate_physics_state + use test_host_data, only: physics_state, & + allocate_physics_state implicit none public @@ -79,7 +80,7 @@ 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 + 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 diff --git a/test/ddthost_test/environ_conditions.F90 b/test/ddthost_test/environ_conditions.F90 index b6816117..2d63366e 100644 --- a/test/ddthost_test/environ_conditions.F90 +++ b/test/ddthost_test/environ_conditions.F90 @@ -14,38 +14,38 @@ module environ_conditions contains -!> \section arg_table_environ_conditions_run Argument Table -!! \htmlinclude arg_table_environ_conditions_run.html -!! + !> \section arg_table_environ_conditions_run Argument Table + !! \htmlinclude arg_table_environ_conditions_run.html + !! subroutine environ_conditions_run(psurf, errmsg, errflg) ! This routine currently does nothing -- should update values - real(kind_phys), intent(in) :: psurf(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(in) :: psurf(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 end subroutine environ_conditions_run -!> \section arg_table_environ_conditions_init Argument Table -!! \htmlinclude arg_table_environ_conditions_init.html -!! - subroutine environ_conditions_init (nbox, O3, HNO3, ntimes, model_times, & - errmsg, errflg) - - integer, intent(in) :: nbox - real(kind_phys), intent(out) :: O3(:) - real(kind_phys), intent(out) :: HNO3(:) - integer, intent(out) :: ntimes - integer, allocatable, intent(out) :: model_times(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg -!---------------------------------------------------------------- + !> \section arg_table_environ_conditions_init Argument Table + !! \htmlinclude arg_table_environ_conditions_init.html + !! + subroutine environ_conditions_init(nbox, o3, hno3, ntimes, model_times, & + errmsg, errflg) + + integer, intent(in) :: nbox + real(kind=kind_phys), intent(out) :: o3(:) + real(kind=kind_phys), intent(out) :: hno3(:) + integer, intent(out) :: ntimes + integer, allocatable, intent(out) :: model_times(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- - integer :: i, j + integer :: i, j errmsg = '' errflg = 0 @@ -53,8 +53,8 @@ subroutine environ_conditions_init (nbox, O3, HNO3, ntimes, model_times, & ! This may be replaced with MusicBox json environmental conditions reader??? do i = 1, nbox - O3(i) = real(i, kind_phys) * 1.e-6_kind_phys - HNO3(i) = real(i, kind_phys) * 1.e-9_kind_phys + o3(i) = real(i, kind_phys) * 1.e-6_kind_phys + hno3(i) = real(i, kind_phys) * 1.e-9_kind_phys end do ntimes = input_model_times @@ -63,32 +63,32 @@ subroutine environ_conditions_init (nbox, O3, HNO3, ntimes, model_times, & end subroutine environ_conditions_init -!> \section arg_table_environ_conditions_finalize Argument Table -!! \htmlinclude arg_table_environ_conditions_finalize.html -!! - subroutine environ_conditions_finalize (ntimes, model_times, errmsg, errflg) + !> \section arg_table_environ_conditions_finalize Argument Table + !! \htmlinclude arg_table_environ_conditions_finalize.html + !! + subroutine environ_conditions_finalize(ntimes, model_times, errmsg, errflg) - integer, intent(in) :: ntimes - integer, intent(in) :: model_times(:) + integer, intent(in) :: ntimes + integer, intent(in) :: model_times(:) character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(out) :: errflg ! This routine checks the size and values of model_times if (ntimes /= input_model_times) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'ntimes mismatch, ', ntimes, ' should be ', & - input_model_times + errflg = 1 + write(errmsg, '(2(a,i0))') 'ntimes mismatch, ', ntimes, ' should be ', & + input_model_times else if (size(model_times) /= input_model_times) then - errflg = 1 - write(errmsg, '(2(a,i0))') 'model_times size mismatch, ', & - size(model_times), ' should be ', input_model_times + errflg = 1 + write(errmsg, '(2(a,i0))') 'model_times size mismatch, ', & + size(model_times), ' should be ', input_model_times else if (any(model_times /= input_model_values)) then - errflg = 1 - write(errmsg, *) 'model_times mismatch, ', & - model_times, ' should be ', input_model_values + errflg = 1 + write(errmsg, *) 'model_times mismatch, ', & + model_times, ' should be ', input_model_values else - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 end if end subroutine environ_conditions_finalize diff --git a/test/ddthost_test/host_ccpp_ddt.F90 b/test/ddthost_test/host_ccpp_ddt.F90 index 157f795f..b60c81af 100644 --- a/test/ddthost_test/host_ccpp_ddt.F90 +++ b/test/ddthost_test/host_ccpp_ddt.F90 @@ -1,16 +1,16 @@ module host_ccpp_ddt - implicit none - private + implicit none + private - !> \section arg_table_ccpp_info_t Argument Table - !! \htmlinclude arg_table_ccpp_info_t.html - !! - type, public :: ccpp_info_t - integer :: col_start ! horizontal_loop_begin - integer :: col_end ! horizontal_loop_end - character(len=512) :: errmsg ! ccpp_error_message - integer :: errflg ! ccpp_error_code - end type ccpp_info_t + !> \section arg_table_ccpp_info_t Argument Table + !! \htmlinclude arg_table_ccpp_info_t.html + !! + type, public :: ccpp_info_t + integer :: col_start ! horizontal_loop_begin + integer :: col_end ! horizontal_loop_end + character(len=512) :: errmsg ! ccpp_error_message + integer :: errflg ! ccpp_error_code + end type ccpp_info_t end module host_ccpp_ddt diff --git a/test/ddthost_test/make_ddt.F90 b/test/ddthost_test/make_ddt.F90 index c9d0832b..a0de4177 100644 --- a/test/ddthost_test/make_ddt.F90 +++ b/test/ddthost_test/make_ddt.F90 @@ -3,132 +3,131 @@ module make_ddt - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: make_ddt_init - public :: make_ddt_run - public :: make_ddt_timestep_final - public :: vmr_type - - !> \section arg_table_vmr_type Argument Table - !! \htmlinclude arg_table_vmr_type.html - !! - type vmr_type - integer :: nvmr - real(kind_phys), allocatable :: vmr_array(:,:) - end type vmr_type + public :: make_ddt_init + public :: make_ddt_run + public :: make_ddt_timestep_final + public :: vmr_type + !> \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(:, :) + 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 predecessor 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, ccpp_info, vmr, errmsg, errflg) - use host_ccpp_ddt, only: ccpp_info_t - - ! Dummy arguments - integer, intent(in) :: nbox - type(ccpp_info_t), intent(in) :: ccpp_info - 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 + !> \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 predecessor 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, ccpp_info, vmr, errmsg, errflg) + use host_ccpp_ddt, only: ccpp_info_t + + ! Dummy arguments + integer, intent(in) :: nbox + type(ccpp_info_t), intent(in) :: ccpp_info + 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/ddthost_test/setup_coeffs.F90 b/test/ddthost_test/setup_coeffs.F90 index 27918695..09c7fcc1 100644 --- a/test/ddthost_test/setup_coeffs.F90 +++ b/test/ddthost_test/setup_coeffs.F90 @@ -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/ddthost_test/temp_set.F90 b/test/ddthost_test/temp_set.F90 index 27233e92..ce1c32ed 100644 --- a/test/ddthost_test/temp_set.F90 +++ b/test/ddthost_test/temp_set.F90 @@ -15,59 +15,59 @@ module temp_set contains -!> \section arg_table_temp_set_run Argument Table -!! \htmlinclude arg_table_temp_set_run.html -!! - subroutine temp_set_run(ncol, lev, timestep, temp_level, temp, ps, & - to_promote, promote_pcnst, errmsg, errflg) -!---------------------------------------------------------------- - implicit none -!---------------------------------------------------------------- - - integer, intent(in) :: ncol, lev - real(kind_phys), intent(out) :: temp(:,:) - real(kind_phys), intent(in) :: timestep - real(kind_phys), intent(in) :: ps(:) - real(kind_phys), intent(inout) :: temp_level(:, :) - real(kind_phys), intent(out) :: to_promote(:, :) - real(kind_phys), intent(out) :: promote_pcnst(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg -!---------------------------------------------------------------- - integer :: ilev - - integer :: col_index - integer :: lev_index + !> \section arg_table_temp_set_run Argument Table + !! \htmlinclude arg_table_temp_set_run.html + !! + subroutine temp_set_run(ncol, lev, timestep, temp_level, temp, ps, & + to_promote, promote_pcnst, errmsg, errflg) + !---------------------------------------------------------------- + implicit none + !---------------------------------------------------------------- + + integer, intent(in) :: ncol, lev + real(kind=kind_phys), intent(out) :: temp(:, :) + real(kind=kind_phys), intent(in) :: timestep + real(kind=kind_phys), intent(in) :: ps(:) + real(kind=kind_phys), intent(inout) :: temp_level(:, :) + real(kind=kind_phys), intent(out) :: to_promote(:, :) + real(kind=kind_phys), intent(out) :: promote_pcnst(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + integer :: ilev + + integer :: col_index + integer :: lev_index errmsg = '' errflg = 0 ilev = size(temp_level, 2) if (ilev /= (lev + 1)) then - errflg = 1 - errmsg = 'Invalid value for ilev, must be lev+1' - return + errflg = 1 + errmsg = 'Invalid value for ilev, must be lev+1' + return end if do col_index = 1, ncol - do lev_index = 1, lev - temp(col_index, lev_index) = (temp_level(col_index, lev_index) & - + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys - end do + do lev_index = 1, lev + temp(col_index, lev_index) = (temp_level(col_index, lev_index) & + + temp_level(col_index, lev_index + 1)) / 2.0_kind_phys + end do end do end subroutine temp_set_run -!> \section arg_table_temp_set_init Argument Table -!! \htmlinclude arg_table_temp_set_init.html -!! + !> \section arg_table_temp_set_init Argument Table + !! \htmlinclude arg_table_temp_set_init.html + !! subroutine temp_set_init(temp_inc_in, fudge, temp_inc_set, errmsg, errflg) - real(kind_phys), intent(in) :: temp_inc_in - real(kind_phys), intent(in) :: fudge - real(kind_phys), intent(out) :: temp_inc_set - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(in) :: temp_inc_in + real(kind=kind_phys), intent(in) :: fudge + real(kind=kind_phys), intent(out) :: temp_inc_set + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg temp_inc_set = temp_inc_in @@ -76,17 +76,17 @@ subroutine temp_set_init(temp_inc_in, fudge, temp_inc_set, errmsg, errflg) end subroutine temp_set_init -!> \section arg_table_temp_set_timestep_initialize Argument Table -!! \htmlinclude arg_table_temp_set_timestep_initialize.html -!! - subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & - errmsg, errflg) + !> \section arg_table_temp_set_timestep_initialize Argument Table + !! \htmlinclude arg_table_temp_set_timestep_initialize.html + !! + subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & + errmsg, errflg) - integer, intent(in) :: ncol - real(kind_phys), intent(in) :: temp_inc - real(kind_phys), intent(inout) :: temp_level(:,:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + real(kind=kind_phys), intent(in) :: temp_inc + real(kind=kind_phys), intent(inout) :: temp_level(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg errmsg = '' errflg = 0 @@ -95,13 +95,13 @@ subroutine temp_set_timestep_initialize(ncol, temp_inc, temp_level, & end subroutine temp_set_timestep_initialize -!> \section arg_table_temp_set_finalize Argument Table -!! \htmlinclude arg_table_temp_set_finalize.html -!! + !> \section arg_table_temp_set_finalize Argument Table + !! \htmlinclude arg_table_temp_set_finalize.html + !! subroutine temp_set_finalize(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 diff --git a/test/ddthost_test/test_ddt_host_integration.F90 b/test/ddthost_test/test_ddt_host_integration.F90 index 23a0e53c..c3cef458 100644 --- a/test/ddthost_test/test_ddt_host_integration.F90 +++ b/test/ddthost_test/test_ddt_host_integration.F90 @@ -1,79 +1,82 @@ 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(7) = (/ & - 'potential_temperature ', & - 'potential_temperature_at_interface ', & - 'coefficients_for_interpolation ', & - 'surface_air_pressure ', & - 'water_vapor_specific_humidity ', & - 'potential_temperature_increment ', & - 'time_step_for_physics ' /) - character(len=cm), target :: test_outvars1(7) = (/ & - 'potential_temperature ', & - 'potential_temperature_at_interface ', & - 'coefficients_for_interpolation ', & - 'surface_air_pressure ', & - 'water_vapor_specific_humidity ', & - 'ccpp_error_code ', & - 'ccpp_error_message ' /) - character(len=cm), target :: test_reqvars1(9) = (/ & - 'potential_temperature ', & - 'potential_temperature_at_interface ', & - 'coefficients_for_interpolation ', & - 'surface_air_pressure ', & - 'water_vapor_specific_humidity ', & - 'potential_temperature_increment ', & - 'time_step_for_physics ', & - 'ccpp_error_code ', & - 'ccpp_error_message ' /) + character(len=cs), target :: test_parts1(2) = (/ 'physics1 ', & + 'physics2 ' /) + character(len=cs), target :: test_parts2(1) = (/ 'data_prep ' /) + character(len=cm), target :: test_invars1(7) = (/ & + 'potential_temperature ', & + 'potential_temperature_at_interface ', & + 'coefficients_for_interpolation ', & + 'surface_air_pressure ', & + 'water_vapor_specific_humidity ', & + 'potential_temperature_increment ', & + 'time_step_for_physics ' /) + character(len=cm), target :: test_outvars1(7) = (/ & + 'potential_temperature ', & + 'potential_temperature_at_interface ', & + 'coefficients_for_interpolation ', & + 'surface_air_pressure ', & + 'water_vapor_specific_humidity ', & + 'ccpp_error_code ', & + 'ccpp_error_message ' /) + character(len=cm), target :: test_reqvars1(9) = (/ & + 'potential_temperature ', & + 'potential_temperature_at_interface ', & + 'coefficients_for_interpolation ', & + 'surface_air_pressure ', & + 'water_vapor_specific_humidity ', & + 'potential_temperature_increment ', & + 'time_step_for_physics ', & + 'ccpp_error_code ', & + 'ccpp_error_message ' /) - character(len=cm), target :: test_invars2(4) = (/ & - 'model_times ', & - 'number_of_model_times ', & - 'surface_air_pressure ', & - 'host_standard_ccpp_type ' /) + character(len=cm), target :: test_invars2(4) = (/ & + 'model_times ', & + 'number_of_model_times ', & + 'surface_air_pressure ', & + 'host_standard_ccpp_type ' /) - 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(6) = (/ & - 'model_times ', & - 'number_of_model_times ', & - 'surface_air_pressure ', & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'host_standard_ccpp_type ' /) - type(suite_info) :: test_suites(2) - logical :: run_okay + character(len=cm), target :: test_reqvars2(6) = (/ & + 'model_times ', & + 'number_of_model_times ', & + 'surface_air_pressure ', & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'host_standard_ccpp_type ' /) + 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/ddthost_test/test_host.F90 b/test/ddthost_test/test_host.F90 index c8213e20..ebe175d9 100644 --- a/test/ddthost_test/test_host.F90 +++ b/test/ddthost_test/test_host.F90 @@ -1,271 +1,273 @@ 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 - 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) + use host_ccpp_ddt, only: ccpp_info_t + use test_host_mod, only: ncols, & + num_time_steps + 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 host_ccpp_ddt, only: ccpp_info_t - use test_host_mod, only: ncols, num_time_steps - 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 + integer :: index, sind + integer :: time_step + integer :: num_suites + character(len=128), allocatable :: suite_names(:) + type(ccpp_info_t) :: ccpp_info - logical :: check - integer :: col_start - integer :: index, sind - integer :: time_step - integer :: num_suites - character(len=128), allocatable :: suite_names(:) - type(ccpp_info_t) :: ccpp_info + ! 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 setup the run + do sind = 1, num_suites + call test_host_ccpp_physics_initialize(test_suites(sind)%suite_name, & + ccpp_info) + if (ccpp_info%errflg /= 0) then + write(6, '(4a)') 'ERROR in initialize of ', & + trim(test_suites(sind)%suite_name), ': ', trim(ccpp_info%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 (ccpp_info%errflg /= 0) then + exit + end if + if (ccpp_info%errflg == 0) then + call test_host_ccpp_physics_timestep_initial( & + test_suites(sind)%suite_name, ccpp_info) + end if + if (ccpp_info%errflg /= 0) then + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(ccpp_info%errmsg) + exit + end if + if (ccpp_info%errflg /= 0) then + exit + 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, & - ccpp_info) + do col_start = 1, ncols, 5 + if (ccpp_info%errflg /= 0) then + exit + end if + ccpp_info%col_start = col_start + ccpp_info%col_end = min(col_start + 4, ncols) + + do sind = 1, num_suites if (ccpp_info%errflg /= 0) then - write(6, '(4a)') 'ERROR in initialize of ', & - trim(test_suites(sind)%suite_name), ': ', trim(ccpp_info%errmsg) + exit end if - end do - ! Loop over time steps - do time_step = 1, num_time_steps - ! Initialize the timestep - do sind = 1, num_suites - if (ccpp_info%errflg /= 0) then - exit - end if - if (ccpp_info%errflg == 0) then - call test_host_ccpp_physics_timestep_initial( & - test_suites(sind)%suite_name, ccpp_info) - end if - if (ccpp_info%errflg /= 0) then - write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(ccpp_info%errmsg) - exit - end if - if (ccpp_info%errflg /= 0) then - exit - end if + do index = 1, size(test_suites(sind)%suite_parts) + if (ccpp_info%errflg /= 0) then + exit + end if + if (ccpp_info%errflg == 0) then + call test_host_ccpp_physics_run( & + test_suites(sind)%suite_name, & + test_suites(sind)%suite_parts(index), & + ccpp_info) + end if + if (ccpp_info%errflg /= 0) then + write(6, '(5a)') trim(test_suites(sind)%suite_name), & + '/', trim(test_suites(sind)%suite_parts(index)), & + ': ', trim(ccpp_info%errmsg) + exit + end if end do + end do + end do - do col_start = 1, ncols, 5 - if (ccpp_info%errflg /= 0) then - exit - end if - ccpp_info%col_start = col_start - ccpp_info%col_end = MIN(col_start + 4, ncols) + do sind = 1, num_suites + if (ccpp_info%errflg /= 0) then + exit + end if + if (ccpp_info%errflg == 0) then + call test_host_ccpp_physics_timestep_final( & + test_suites(sind)%suite_name, ccpp_info) + end if + if (ccpp_info%errflg /= 0) then + write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & + trim(ccpp_info%errmsg) + exit + end if + end do + end do ! End time step loop - do sind = 1, num_suites - if (ccpp_info%errflg /= 0) then - exit - end if - do index = 1, size(test_suites(sind)%suite_parts) - if (ccpp_info%errflg /= 0) then - exit - end if - if (ccpp_info%errflg == 0) then - call test_host_ccpp_physics_run( & - test_suites(sind)%suite_name, & - test_suites(sind)%suite_parts(index), & - ccpp_info) - end if - if (ccpp_info%errflg /= 0) then - write(6, '(5a)') trim(test_suites(sind)%suite_name), & - '/', trim(test_suites(sind)%suite_parts(index)), & - ': ', trim(ccpp_info%errmsg) - exit - end if - end do - end do - end do + do sind = 1, num_suites + if (ccpp_info%errflg /= 0) then + exit + end if + if (ccpp_info%errflg == 0) then + call test_host_ccpp_physics_finalize( & + test_suites(sind)%suite_name, ccpp_info) + end if + if (ccpp_info%errflg /= 0) then + write(6, '(3a)') test_suites(sind)%suite_parts(index), ': ', & + trim(ccpp_info%errmsg) + write(6, '(2a)') 'An error occurred in ccpp_timestep_final, ', & + 'Exiting...' + exit + end if + end do - do sind = 1, num_suites - if (ccpp_info%errflg /= 0) then - exit - end if - if (ccpp_info%errflg == 0) then - call test_host_ccpp_physics_timestep_final( & - test_suites(sind)%suite_name, ccpp_info) - end if - if (ccpp_info%errflg /= 0) then - write(6, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(ccpp_info%errmsg) - exit - end if - end do - end do ! End time step loop - - do sind = 1, num_suites - if (ccpp_info%errflg /= 0) then - exit - end if - if (ccpp_info%errflg == 0) then - call test_host_ccpp_physics_finalize( & - test_suites(sind)%suite_name,ccpp_info) - end if - if (ccpp_info%errflg /= 0) then - write(6, '(3a)') test_suites(sind)%suite_parts(index), ': ', & - trim(ccpp_info%errmsg) - write(6,'(2a)') 'An error occurred in ccpp_timestep_final, ', & - 'Exiting...' - exit - end if - end do - - if (ccpp_info%errflg == 0) then - ! Run finished without error, check answers - if (.not. check_model_times()) then - write(6, *) 'Model times error!' - ccpp_info%errflg = -1 - else if (compare_data()) then - write(6, *) 'Answers are correct!' - ccpp_info%errflg = 0 - else - write(6, *) 'Answers are not correct!' - ccpp_info%errflg = -1 - end if - end if + if (ccpp_info%errflg == 0) then + ! Run finished without error, check answers + if (.not. check_model_times()) then + write(6, *) 'Model times error!' + ccpp_info%errflg = -1 + else if (compare_data()) then + write(6, *) 'Answers are correct!' + ccpp_info%errflg = 0 + else + write(6, *) 'Answers are not correct!' + ccpp_info%errflg = -1 + end if + end if - retval = ccpp_info%errflg == 0 + retval = ccpp_info%errflg == 0 - end subroutine test_host + end subroutine test_host - end module test_prog +end module test_prog diff --git a/test/ddthost_test/test_host_data.F90 b/test/ddthost_test/test_host_data.F90 index 7a651fca..88812719 100644 --- a/test/ddthost_test/test_host_data.F90 +++ b/test/ddthost_test/test_host_data.F90 @@ -5,15 +5,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 - 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 + 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 allocate_physics_state @@ -21,29 +21,29 @@ module test_host_data contains subroutine allocate_physics_state(cols, levels, constituents, state) - integer, intent(in) :: cols - integer, intent(in) :: levels - integer, intent(in) :: constituents + integer, intent(in) :: cols + integer, intent(in) :: levels + integer, intent(in) :: constituents 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)) diff --git a/test/ddthost_test/test_host_mod.F90 b/test/ddthost_test/test_host_mod.F90 index 43be333a..02eb4991 100644 --- a/test/ddthost_test/test_host_mod.F90 +++ b/test/ddthost_test/test_host_mod.F90 @@ -1,39 +1,40 @@ 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 :: DiagDimStart = 2 - integer, parameter :: index_qv = 1 - real(kind_phys), allocatable :: temp_midpoints(:,:) - real(kind_phys) :: temp_interfaces(ncols, pverP) - real(kind_phys) :: coeffs(ncols) - 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 :: diagdimstart = 2 + integer, parameter :: index_qv = 1 + real(kind=kind_phys), allocatable :: temp_midpoints(:, :) + real(kind=kind_phys) :: temp_interfaces(ncols, pverp) + real(kind=kind_phys) :: coeffs(ncols) + 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 @@ -47,22 +48,22 @@ 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 + 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, 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 @@ -71,68 +72,68 @@ 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 /) compare_data = .true. 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) + 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) + 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 end function compare_data diff --git a/test/hash_table_tests/test_hash.F90 b/test/hash_table_tests/test_hash.F90 index 35536cdd..b7faa074 100644 --- a/test/hash_table_tests/test_hash.F90 +++ b/test/hash_table_tests/test_hash.F90 @@ -1,215 +1,218 @@ module test_hash_utils - use ccpp_hashable, only: ccpp_hashable_char_t - - implicit none - private - - public :: test_table - - integer, parameter, public :: max_terrs = 16 - - type, public :: hash_object_t - type(ccpp_hashable_char_t), pointer :: item => NULL() - end type hash_object_t - - private add_error - -CONTAINS - - subroutine add_error(msg, num_errs, errors) - ! Dummy arguments - character(len=*), intent(in) :: msg - integer, intent(inout) :: num_errs - character(len=*), intent(inout) :: errors(:) - - if (num_errs < max_terrs) then - num_errs = num_errs + 1 - write(errors(num_errs), *) trim(msg) + use ccpp_hashable, only: ccpp_hashable_char_t + + implicit none + private + + public :: test_table + + integer, parameter, public :: max_terrs = 16 + + type, public :: hash_object_t + type(ccpp_hashable_char_t), pointer :: item => null() + end type hash_object_t + + private add_error + +contains + + subroutine add_error(msg, num_errs, errors) + ! Dummy arguments + character(len=*), intent(in) :: msg + integer, intent(inout) :: num_errs + character(len=*), intent(inout) :: errors(:) + + if (num_errs < max_terrs) then + num_errs = num_errs + 1 + write(errors(num_errs), *) trim(msg) + end if + + end subroutine add_error + + subroutine test_table(hash_table, table_size, num_tests, num_errs, errors) + use ccpp_hash_table, only: ccpp_hash_table_t, & + ccpp_hash_iterator_t + use ccpp_hashable, only: ccpp_hashable_t, & + new_hashable_char + + ! Dummy arguments + type(ccpp_hash_table_t), target, intent(inout) :: hash_table + integer, intent(in) :: table_size + integer, intent(out) :: num_tests + integer, intent(out) :: num_errs + character(len=*), intent(inout) :: errors(:) + ! Local variables + integer, parameter :: num_test_entries = 4 + integer, parameter :: key_len = 10 + character(len=key_len) :: hash_names(num_test_entries) = (/ & + 'foo ', 'bar ', 'foobar ', 'big daddy ' /) + logical :: hash_found(num_test_entries) + + type(hash_object_t) :: hash_chars(num_test_entries) + class(ccpp_hashable_t), pointer :: test_ptr => null() + type(ccpp_hash_iterator_t) :: hash_iter + character(len=key_len) :: test_key + character(len=len(errors(1))) :: errmsg + integer :: index + + write(6, '(a,i0)') "Testing hash table, size = ", table_size + num_tests = 0 + num_errs = 0 + ! Make sure hash table is *not* initialized + if (hash_table%is_initialized()) then + call add_error("Error: hash table initialized too early", & + num_errs, errors) + end if + num_tests = num_tests + 1 + ! Initialize hash table + call hash_table%initialize(table_size) + ! Make sure hash table is *is* initialized + if (.not. hash_table%is_initialized()) then + call add_error("Error: hash table *not* initialized", num_errs, errors) + end if + num_tests = num_tests + 1 + do index = 1, num_test_entries + call new_hashable_char(hash_names(index), hash_chars(index)%item) + call hash_table%add_hash_key(hash_chars(index)%item, & + errmsg=errors(num_errs + 1)) + if (len_trim(errors(num_errs + 1)) > 0) then + num_errs = num_errs + 1 end if - - end subroutine add_error - - subroutine test_table(hash_table, table_size, num_tests, num_errs, errors) - use ccpp_hash_table, only: ccpp_hash_table_t, ccpp_hash_iterator_t - use ccpp_hashable, only: ccpp_hashable_t, new_hashable_char - - ! Dummy arguments - type(ccpp_hash_table_t), target, intent(inout) :: hash_table - integer, intent(in) :: table_size - integer, intent(out) :: num_tests - integer, intent(out) :: num_errs - character(len=*), intent(inout) :: errors(:) - ! Local variables - integer, parameter :: num_test_entries = 4 - integer, parameter :: key_len = 10 - character(len=key_len) :: hash_names(num_test_entries) = (/ & - 'foo ', 'bar ', 'foobar ', 'big daddy ' /) - logical :: hash_found(num_test_entries) - - type(hash_object_t) :: hash_chars(num_test_entries) - class(ccpp_hashable_t), pointer :: test_ptr => NULL() - type(ccpp_hash_iterator_t) :: hash_iter - character(len=key_len) :: test_key - character(len=len(errors(1))) :: errmsg - integer :: index - - write(6, '(a,i0)') "Testing hash table, size = ", table_size - num_tests = 0 - num_errs = 0 - ! Make sure hash table is *not* initialized - if (hash_table%is_initialized()) then - call add_error("Error: hash table initialized too early", & - num_errs, errors) + if (num_errs > max_terrs) then + exit end if + end do + + if (num_errs == 0) then + ! We have populated the table, let's do some tests + ! First, make sure we can find existing entries + do index = 1, num_test_entries + test_ptr => hash_table%table_value(hash_names(index), & + errmsg=errors(num_errs + 1)) + if (len_trim(errors(num_errs + 1)) > 0) then + num_errs = num_errs + 1 + else if (trim(test_ptr%key()) /= trim(hash_names(index))) then + num_errs = num_errs + 1 + write(errmsg, *) "ERROR: Found '", trim(test_ptr%key()), & + "', expected '", trim(hash_names(index)), "'" + call add_error(trim(errmsg), num_errs, errors) + end if + if (num_errs > max_terrs) then + exit + end if + end do num_tests = num_tests + 1 - ! Initialize hash table - call hash_table%initialize(table_size) - ! Make sure hash table is *is* initialized - if (.not. hash_table%is_initialized()) then - call add_error("Error: hash table *not* initialized", num_errs, errors) + ! Next, make sure we do not find a non-existent entry + test_ptr => hash_table%table_value(trim(hash_names(1)) // '_oops', & + errmsg=errors(num_errs + 1)) + if (len_trim(errors(num_errs + 1)) == 0) then + write(errmsg, *) "ERROR: Found an entry for '", & + trim(hash_names(1)) // '_oops', "'" + call add_error(trim(errmsg), num_errs, errors) end if num_tests = num_tests + 1 - do index = 1, num_test_entries - call new_hashable_char(hash_names(index), hash_chars(index)%item) - call hash_table%add_hash_key(hash_chars(index)%item, & - errmsg=errors(num_errs + 1)) - if (len_trim(errors(num_errs + 1)) > 0) then - num_errs = num_errs + 1 - end if - if (num_errs > max_terrs) then - exit - end if - end do - - if (num_errs == 0) then - ! We have populated the table, let's do some tests - ! First, make sure we can find existing entries - do index = 1, num_test_entries - test_ptr => hash_table%table_value(hash_names(index), & - errmsg=errors(num_errs + 1)) - if (len_trim(errors(num_errs + 1)) > 0) then - num_errs = num_errs + 1 - else if (trim(test_ptr%key()) /= trim(hash_names(index))) then - num_errs = num_errs + 1 - write(errmsg, *) "ERROR: Found '", trim(test_ptr%key()), & - "', expected '", trim(hash_names(index)), "'" - call add_error(trim(errmsg), num_errs, errors) - end if - if (num_errs > max_terrs) then - exit - end if - end do - num_tests = num_tests + 1 - ! Next, make sure we do not find a non-existent entry - test_ptr => hash_table%table_value(trim(hash_names(1))//'_oops', & - errmsg=errors(num_errs + 1)) - if (len_trim(errors(num_errs + 1)) == 0) then - write(errmsg, *) "ERROR: Found an entry for '", & - trim(hash_names(1))//'_oops', "'" - call add_error(trim(errmsg), num_errs, errors) - end if - num_tests = num_tests + 1 - ! Make sure we get an error if we try to add a duplicate key - call hash_table%add_hash_key(hash_chars(2)%item, & - errmsg=errors(num_errs + 1)) - if (len_trim(errors(num_errs + 1)) == 0) then - num_errs = num_errs + 1 - write(errors(num_errs), *) & - "ERROR: Allowed duplicate entry for '", & - hash_chars(2)%item%key(), "'" - end if - num_tests = num_tests + 1 - ! Check that the total number of table entries is correct - if (hash_table%num_values() /= num_test_entries) then - write(errmsg, '(2(a,i0))') "ERROR: Wrong table value count, ", & - hash_table%num_values(), ', should be ', num_test_entries - call add_error(errmsg, num_errs, errors) - end if - num_tests = num_tests + 1 - ! Test iteration through hash table - hash_found(:) = .false. - call hash_iter%initialize(hash_table) - num_tests = num_tests + 1 - do - if (hash_iter%valid()) then - test_key = hash_iter%key() - index = 1 - do - if (trim(test_key) == trim(hash_names(index))) then - hash_found(index) = .true. - exit - else if (index >= num_test_entries) then - write(errmsg, '(3a)') & - "ERROR: Unexpected table entry, '", & - trim(test_key), "'" - call add_error(errmsg, num_errs, errors) - end if - index = index + 1 - end do - call hash_iter%next() - else - exit - end if - end do - call hash_iter%finalize() - if (ANY(.not. hash_found)) then - write(errmsg, '(a,i0,a)') "ERROR: ", & - COUNT(.not. hash_found), " test keys not found in table." - call add_error(errmsg, num_errs, errors) - end if + ! Make sure we get an error if we try to add a duplicate key + call hash_table%add_hash_key(hash_chars(2)%item, & + errmsg=errors(num_errs + 1)) + if (len_trim(errors(num_errs + 1)) == 0) then + num_errs = num_errs + 1 + write(errors(num_errs), *) & + "ERROR: Allowed duplicate entry for '", & + hash_chars(2)%item%key(), "'" end if - ! Finally, clear the hash table (should deallocate everything) - call hash_table%clear() - ! Make sure hash table is *not* initialized - if (hash_table%is_initialized()) then - call add_error("Error: hash table initialized after clear", & - num_errs, errors) + num_tests = num_tests + 1 + ! Check that the total number of table entries is correct + if (hash_table%num_values() /= num_test_entries) then + write(errmsg, '(2(a,i0))') "ERROR: Wrong table value count, ", & + hash_table%num_values(), ', should be ', num_test_entries + call add_error(errmsg, num_errs, errors) end if num_tests = num_tests + 1 - ! Cleanup - do index = 1, num_test_entries - deallocate(hash_chars(index)%item) + ! Test iteration through hash table + hash_found(:) = .false. + call hash_iter%initialize(hash_table) + num_tests = num_tests + 1 + do + if (hash_iter%valid()) then + test_key = hash_iter%key() + index = 1 + do + if (trim(test_key) == trim(hash_names(index))) then + hash_found(index) = .true. + exit + else if (index >= num_test_entries) then + write(errmsg, '(3a)') & + "ERROR: Unexpected table entry, '", & + trim(test_key), "'" + call add_error(errmsg, num_errs, errors) + end if + index = index + 1 + end do + call hash_iter%next() + else + exit + end if end do - - end subroutine test_table + call hash_iter%finalize() + if (any(.not. hash_found)) then + write(errmsg, '(a,i0,a)') "ERROR: ", & + count(.not. hash_found), " test keys not found in table." + call add_error(errmsg, num_errs, errors) + end if + end if + ! Finally, clear the hash table (should deallocate everything) + call hash_table%clear() + ! Make sure hash table is *not* initialized + if (hash_table%is_initialized()) then + call add_error("Error: hash table initialized after clear", & + num_errs, errors) + end if + num_tests = num_tests + 1 + ! Cleanup + do index = 1, num_test_entries + deallocate(hash_chars(index)%item) + end do + + end subroutine test_table end module test_hash_utils program test_hash - use ccpp_hash_table, only: ccpp_hash_table_t - use test_hash_utils, only: test_table, max_terrs - - integer, parameter :: num_table_sizes = 5 - integer, parameter :: max_errs = max_terrs * num_table_sizes - integer, parameter :: err_size = 128 - integer, parameter :: test_sizes(num_table_sizes) = (/ & - 0, 1, 2, 4, 20 /) - - type(ccpp_hash_table_t), target :: hash_table - integer :: index - integer :: errcnt = 0 - integer :: num_tests = 0 - integer :: total_errcnt = 0 - integer :: total_tests = 0 - character(len=err_size) :: errors(max_errs) - - errors = '' - do index = 1, num_table_sizes - call test_table(hash_table, test_sizes(index), num_tests, errcnt, & - errors(total_errcnt+1:)) - total_tests = total_tests + num_tests - total_errcnt = total_errcnt + errcnt - end do - - if (total_errcnt > 0) then - write(6, '(a,i0,a)') 'FAIL, ', total_errcnt, ' errors found' - do index = 1, total_errcnt - write(6, *) trim(errors(index)) - end do - STOP 1 - else - write(6, '(a,i0,a)') "All ", total_tests, " hash table tests passed!" - STOP 0 - end if + use ccpp_hash_table, only: ccpp_hash_table_t + use test_hash_utils, only: test_table, & + max_terrs + + integer, parameter :: num_table_sizes = 5 + integer, parameter :: max_errs = max_terrs * num_table_sizes + integer, parameter :: err_size = 128 + integer, parameter :: test_sizes(num_table_sizes) = (/ & + 0, 1, 2, 4, 20 /) + + type(ccpp_hash_table_t), target :: hash_table + integer :: index + integer :: errcnt = 0 + integer :: num_tests = 0 + integer :: total_errcnt = 0 + integer :: total_tests = 0 + character(len=err_size) :: errors(max_errs) + + errors = '' + do index = 1, num_table_sizes + call test_table(hash_table, test_sizes(index), num_tests, errcnt, & + errors(total_errcnt + 1:)) + total_tests = total_tests + num_tests + total_errcnt = total_errcnt + errcnt + end do + + if (total_errcnt > 0) then + write(6, '(a,i0,a)') 'FAIL, ', total_errcnt, ' errors found' + do index = 1, total_errcnt + write(6, *) trim(errors(index)) + end do + stop 1 + else + write(6, '(a,i0,a)') "All ", total_tests, " hash table tests passed!" + stop 0 + end if end program test_hash diff --git a/test/nested_suite_test/ccpp_kinds.F90 b/test/nested_suite_test/ccpp_kinds.F90 index b2923935..2eed03c9 100644 --- a/test/nested_suite_test/ccpp_kinds.F90 +++ b/test/nested_suite_test/ccpp_kinds.F90 @@ -10,18 +10,18 @@ ! IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ! CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - !> !! @brief Auto-generated kinds for CCPP !! ! module ccpp_kinds - use ISO_FORTRAN_ENV, only: kind_phys => REAL64 + use iso_fortran_env, only: & + kind_phys => real64 - implicit none - private + implicit none + private - public :: kind_phys + public :: kind_phys end module ccpp_kinds diff --git a/test/nested_suite_test/effr_calc.F90 b/test/nested_suite_test/effr_calc.F90 index 0b626c16..b8fc43ed 100644 --- a/test/nested_suite_test/effr_calc.F90 +++ b/test/nested_suite_test/effr_calc.F90 @@ -3,82 +3,82 @@ module effr_calc - use ccpp_kinds, only: kind_phys - - implicit none - private - - public :: effr_calc_run, effr_calc_init - - contains - !> \section arg_table_effr_calc_init Argument Table - !! \htmlinclude arg_table_effr_calc_init.html - !! - subroutine effr_calc_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order .ne. 2) then - errflg = 1 - errmsg = 'ERROR: effr_calc_init() needs to be called second' - return - else - scheme_order = scheme_order + 1 - endif - - end subroutine effr_calc_init - - !> \section arg_table_effr_calc_run Argument Table - !! \htmlinclude arg_table_effr_calc_run.html - !! - subroutine effr_calc_run(ncol, nlev, effrr_in, effrg_in, ncg_in, nci_out, & - effrl_inout, effri_out, effrs_inout, ncl_out, & - has_graupel, scalar_var, tke_inout, tke2_inout, & - errmsg, errflg) - - integer, intent(in) :: ncol - integer, intent(in) :: nlev - real(kind_phys), intent(in) :: effrr_in(:,:) - real(kind_phys), intent(in),optional :: effrg_in(:,:) - real(kind_phys), intent(in),optional :: ncg_in(:,:) - real(kind_phys), intent(out),optional :: nci_out(:,:) - real(kind_phys), intent(inout) :: effrl_inout(:,:) - real(kind_phys), intent(out),optional :: effri_out(:,:) - real(8),intent(inout) :: effrs_inout(:,:) - logical, intent(in) :: has_graupel - real(kind_phys), intent(inout) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - real(kind_phys), intent(out),optional :: ncl_out(:,:) - real(kind_phys), intent(inout) :: tke_inout - real(kind_phys), intent(inout) :: tke2_inout - - !---------------------------------------------------------------- - - real(kind_phys), parameter :: re_qc_min = 2.5 ! microns - real(kind_phys), parameter :: re_qc_max = 50. ! microns - real(kind_phys), parameter :: re_qi_avg = 75. ! microns - real(kind_phys) :: effrr_local(ncol,nlev) - real(kind_phys) :: effrg_local(ncol,nlev) - real(kind_phys) :: ncg_in_local(ncol,nlev) - real(kind_phys) :: nci_out_local(ncol,nlev) - - errmsg = '' - errflg = 0 - - effrr_local = effrr_in - if (present(effrg_in)) effrg_local = effrg_in - if (present(ncg_in)) ncg_in_local = ncg_in - if (present(nci_out)) nci_out_local = nci_out - effrl_inout = min(max(effrl_inout,re_qc_min),re_qc_max) - if (present(effri_out)) effri_out = re_qi_avg - effrs_inout = effrs_inout + (10.0 / 6.0) ! in micrometer - scalar_var = 2.0 ! in km - - end subroutine effr_calc_run + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: effr_calc_run, effr_calc_init + +contains + !> \section arg_table_effr_calc_init Argument Table + !! \htmlinclude arg_table_effr_calc_init.html + !! + subroutine effr_calc_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order /= 2) then + errflg = 1 + errmsg = 'ERROR: effr_calc_init() needs to be called second' + return + else + scheme_order = scheme_order + 1 + end if + + end subroutine effr_calc_init + + !> \section arg_table_effr_calc_run Argument Table + !! \htmlinclude arg_table_effr_calc_run.html + !! + subroutine effr_calc_run(ncol, nlev, effrr_in, effrg_in, ncg_in, nci_out, & + effrl_inout, effri_out, effrs_inout, ncl_out, & + has_graupel, scalar_var, tke_inout, tke2_inout, & + errmsg, errflg) + + integer, intent(in) :: ncol + integer, intent(in) :: nlev + real(kind=kind_phys), intent(in) :: effrr_in(:, :) + real(kind=kind_phys), intent(in), optional :: effrg_in(:, :) + real(kind=kind_phys), intent(in), optional :: ncg_in(:, :) + real(kind=kind_phys), intent(out), optional :: nci_out(:, :) + real(kind=kind_phys), intent(inout) :: effrl_inout(:, :) + real(kind=kind_phys), intent(out), optional :: effri_out(:, :) + real(kind=8), intent(inout) :: effrs_inout(:, :) + logical, intent(in) :: has_graupel + real(kind=kind_phys), intent(inout) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind=kind_phys), intent(out), optional :: ncl_out(:, :) + real(kind=kind_phys), intent(inout) :: tke_inout + real(kind=kind_phys), intent(inout) :: tke2_inout + + !---------------------------------------------------------------- + + real(kind=kind_phys), parameter :: re_qc_min = 2.5 ! microns + real(kind=kind_phys), parameter :: re_qc_max = 50. ! microns + real(kind=kind_phys), parameter :: re_qi_avg = 75. ! microns + real(kind=kind_phys) :: effrr_local(ncol, nlev) + real(kind=kind_phys) :: effrg_local(ncol, nlev) + real(kind=kind_phys) :: ncg_in_local(ncol, nlev) + real(kind=kind_phys) :: nci_out_local(ncol, nlev) + + errmsg = '' + errflg = 0 + + effrr_local = effrr_in + if (present(effrg_in)) effrg_local = effrg_in + if (present(ncg_in)) ncg_in_local = ncg_in + if (present(nci_out)) nci_out_local = nci_out + effrl_inout = min(max(effrl_inout, re_qc_min), re_qc_max) + if (present(effri_out)) effri_out = re_qi_avg + effrs_inout = effrs_inout + (10.0 / 6.0) ! in micrometer + scalar_var = 2.0 ! in km + + end subroutine effr_calc_run end module effr_calc diff --git a/test/nested_suite_test/effr_diag.F90 b/test/nested_suite_test/effr_diag.F90 index 409ff2f9..75da29c7 100644 --- a/test/nested_suite_test/effr_diag.F90 +++ b/test/nested_suite_test/effr_diag.F90 @@ -3,12 +3,12 @@ module effr_diag - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_diag_run, effr_diag_init + public :: effr_diag_run, effr_diag_init contains @@ -16,53 +16,53 @@ module effr_diag !! \htmlinclude arg_table_effr_diag_init.html !! subroutine effr_diag_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + errmsg = '' errflg = 0 - if (scheme_order .ne. 4) then - errflg = 1 - errmsg = 'ERROR: effr_diag_init() needs to be called fourth' - return - else - scheme_order = scheme_order + 1 - endif + if (scheme_order /= 4) then + errflg = 1 + errmsg = 'ERROR: effr_diag_init() needs to be called fourth' + return + else + scheme_order = scheme_order + 1 + end if end subroutine effr_diag_init - !> \section arg_table_effr_diag_run Argument Table - !! \htmlinclude arg_table_effr_diag_run.html - !! - subroutine effr_diag_run( effrr_in, scalar_var, errmsg, errflg) - - real(kind_phys), intent(in) :: effrr_in(:,:) - integer, intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - call cmp_effr_diag(effrr_in, effrr_min, effrr_max) - - if (scalar_var .ne. 380) then - errmsg = 'ERROR: effr_diag_run(): scalar_var should be 380' - errflg = 1 - endif - end subroutine effr_diag_run - - subroutine cmp_effr_diag(effr, effr_min, effr_max) - real(kind_phys), intent(in) :: effr(:,:) - real(kind_phys), intent(out) :: effr_min, effr_max - - ! Do some diagnostic calcualtions... - effr_min = minval(effr) - effr_max = maxval(effr) - - end subroutine cmp_effr_diag + !> \section arg_table_effr_diag_run Argument Table + !! \htmlinclude arg_table_effr_diag_run.html + !! + subroutine effr_diag_run(effrr_in, scalar_var, errmsg, errflg) + + real(kind=kind_phys), intent(in) :: effrr_in(:, :) + integer, intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind=kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + call cmp_effr_diag(effrr_in, effrr_min, effrr_max) + + if (scalar_var /= 380) then + errmsg = 'ERROR: effr_diag_run(): scalar_var should be 380' + errflg = 1 + end if + end subroutine effr_diag_run + + subroutine cmp_effr_diag(effr, effr_min, effr_max) + real(kind=kind_phys), intent(in) :: effr(:, :) + real(kind=kind_phys), intent(out) :: effr_min, effr_max + + ! Do some diagnostic calcualtions... + effr_min = minval(effr) + effr_max = maxval(effr) + + end subroutine cmp_effr_diag end module effr_diag diff --git a/test/nested_suite_test/effr_post.F90 b/test/nested_suite_test/effr_post.F90 index d42a574c..01357350 100644 --- a/test/nested_suite_test/effr_post.F90 +++ b/test/nested_suite_test/effr_post.F90 @@ -3,59 +3,59 @@ module effr_post - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_post_run, effr_post_init + public :: effr_post_run, effr_post_init contains - !> \section arg_table_effr_post_init Argument Table - !! \htmlinclude arg_table_effr_post_init.html - !! - subroutine effr_post_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order .ne. 3) then - errflg = 1 - errmsg = 'ERROR: effr_post_init() needs to be called third' - return - else - scheme_order = scheme_order + 1 - endif - - end subroutine effr_post_init - - !> \section arg_table_effr_post_run Argument Table - !! \htmlinclude arg_table_effr_post_run.html - !! - subroutine effr_post_run( effrr_inout, scalar_var, errmsg, errflg) - - real(kind_phys), intent(inout) :: effrr_inout(:,:) - real(kind_phys), intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - ! Do some post-processing on effrr... - effrr_inout(:,:) = effrr_inout(:,:)*1._kind_phys - - if (scalar_var .ne. 1013.0) then - errmsg = 'ERROR: effr_post_run(): scalar_var should be 1013.0' - errflg = 1 - endif - - end subroutine effr_post_run - - end module effr_post + !> \section arg_table_effr_post_init Argument Table + !! \htmlinclude arg_table_effr_post_init.html + !! + subroutine effr_post_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order /= 3) then + errflg = 1 + errmsg = 'ERROR: effr_post_init() needs to be called third' + return + else + scheme_order = scheme_order + 1 + end if + + end subroutine effr_post_init + + !> \section arg_table_effr_post_run Argument Table + !! \htmlinclude arg_table_effr_post_run.html + !! + subroutine effr_post_run(effrr_inout, scalar_var, errmsg, errflg) + + real(kind=kind_phys), intent(inout) :: effrr_inout(:, :) + real(kind=kind_phys), intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind=kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + ! Do some post-processing on effrr... + effrr_inout(:, :) = effrr_inout(:, :) * 1._kind_phys + + if (scalar_var /= 1013.0) then + errmsg = 'ERROR: effr_post_run(): scalar_var should be 1013.0' + errflg = 1 + end if + + end subroutine effr_post_run + +end module effr_post diff --git a/test/nested_suite_test/effr_pre.F90 b/test/nested_suite_test/effr_pre.F90 index 17a3b187..a2fe2f5c 100644 --- a/test/nested_suite_test/effr_pre.F90 +++ b/test/nested_suite_test/effr_pre.F90 @@ -3,58 +3,58 @@ module mod_effr_pre - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_pre_run, effr_pre_init + public :: effr_pre_run, effr_pre_init contains - !> \section arg_table_effr_pre_init Argument Table - !! \htmlinclude arg_table_effr_pre_init.html - !! - subroutine effr_pre_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order .ne. 1) then - errflg = 1 - errmsg = 'ERROR: effr_pre_init() needs to be called first' - return - else - scheme_order = scheme_order + 1 - endif - - end subroutine effr_pre_init - - !> \section arg_table_effr_pre_run Argument Table - !! \htmlinclude arg_table_effr_pre_run.html - !! - subroutine effr_pre_run( effrr_inout, scalar_var, errmsg, errflg) - - real(kind_phys), intent(inout) :: effrr_inout(:,:) - real(kind_phys), intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - ! Do some pre-processing on effrr... - effrr_inout(:,:) = effrr_inout(:,:)*1._kind_phys - - if (scalar_var .ne. 273.15) then - errmsg = 'ERROR: effr_pre_run(): scalar_var should be 273.15' - errflg = 1 - endif - - end subroutine effr_pre_run + !> \section arg_table_effr_pre_init Argument Table + !! \htmlinclude arg_table_effr_pre_init.html + !! + subroutine effr_pre_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order /= 1) then + errflg = 1 + errmsg = 'ERROR: effr_pre_init() needs to be called first' + return + else + scheme_order = scheme_order + 1 + end if + + end subroutine effr_pre_init + + !> \section arg_table_effr_pre_run Argument Table + !! \htmlinclude arg_table_effr_pre_run.html + !! + subroutine effr_pre_run(effrr_inout, scalar_var, errmsg, errflg) + + real(kind=kind_phys), intent(inout) :: effrr_inout(:, :) + real(kind=kind_phys), intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind=kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + ! Do some pre-processing on effrr... + effrr_inout(:, :) = effrr_inout(:, :) * 1._kind_phys + + if (scalar_var /= 273.15) then + errmsg = 'ERROR: effr_pre_run(): scalar_var should be 273.15' + errflg = 1 + end if + + end subroutine effr_pre_run end module mod_effr_pre diff --git a/test/nested_suite_test/effrs_calc.F90 b/test/nested_suite_test/effrs_calc.F90 index e9266905..3aa8d196 100644 --- a/test/nested_suite_test/effrs_calc.F90 +++ b/test/nested_suite_test/effrs_calc.F90 @@ -3,30 +3,30 @@ module effrs_calc - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effrs_calc_run + public :: effrs_calc_run - contains - !> \section arg_table_effrs_calc_run Argument Table - !! \htmlinclude arg_table_effrs_calc_run.html - !! - subroutine effrs_calc_run(effrs_inout, errmsg, errflg) +contains + !> \section arg_table_effrs_calc_run Argument Table + !! \htmlinclude arg_table_effrs_calc_run.html + !! + subroutine effrs_calc_run(effrs_inout, errmsg, errflg) - real(kind_phys), intent(inout) :: effrs_inout(:,:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(inout) :: effrs_inout(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - !---------------------------------------------------------------- + !---------------------------------------------------------------- - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 - effrs_inout = effrs_inout + (10.E-6_kind_phys / 3._kind_phys) ! in meters + effrs_inout = effrs_inout + (10.E-6_kind_phys / 3._kind_phys) ! in meters - end subroutine effrs_calc_run + end subroutine effrs_calc_run end module effrs_calc diff --git a/test/nested_suite_test/module_rad_ddt.F90 b/test/nested_suite_test/module_rad_ddt.F90 index 21a1a0ec..6e992250 100644 --- a/test/nested_suite_test/module_rad_ddt.F90 +++ b/test/nested_suite_test/module_rad_ddt.F90 @@ -1,5 +1,5 @@ module mod_rad_ddt - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys implicit none public ty_rad_lw, ty_rad_sw @@ -8,16 +8,16 @@ module mod_rad_ddt !! \htmlinclude arg_table_ty_rad_lw.html !! type ty_rad_lw - real(kind_phys) :: sfc_up_lw - real(kind_phys) :: sfc_down_lw + real(kind=kind_phys) :: sfc_up_lw + real(kind=kind_phys) :: sfc_down_lw end type ty_rad_lw !> \section arg_table_ty_rad_sw Argument Table !! \htmlinclude arg_table_ty_rad_sw.html !! type ty_rad_sw - real(kind_phys), pointer :: sfc_up_sw(:) => null() - real(kind_phys), pointer :: sfc_down_sw(:) => null() + real(kind=kind_phys), pointer :: sfc_up_sw(:) => null() + real(kind=kind_phys), pointer :: sfc_down_sw(:) => null() end type ty_rad_sw end module mod_rad_ddt diff --git a/test/nested_suite_test/rad_lw.F90 b/test/nested_suite_test/rad_lw.F90 index 5859f8bf..ded4861f 100644 --- a/test/nested_suite_test/rad_lw.F90 +++ b/test/nested_suite_test/rad_lw.F90 @@ -12,12 +12,12 @@ module rad_lw !> \section arg_table_rad_lw_run Argument Table !! \htmlinclude arg_table_rad_lw_run.html !! - subroutine rad_lw_run(ncol, fluxLW, errmsg, errflg) + subroutine rad_lw_run(ncol, fluxlw, errmsg, errflg) - integer, intent(in) :: ncol - type(ty_rad_lw), intent(inout) :: fluxLW(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + type(ty_rad_lw), intent(inout) :: fluxlw(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg ! Locals integer :: icol @@ -25,10 +25,10 @@ subroutine rad_lw_run(ncol, fluxLW, errmsg, errflg) errmsg = '' errflg = 0 - do icol=1,ncol - fluxLW(icol)%sfc_up_lw = 300._kind_phys - fluxLW(icol)%sfc_down_lw = 50._kind_phys - enddo + do icol = 1, ncol + fluxlw(icol)%sfc_up_lw = 300._kind_phys + fluxlw(icol)%sfc_down_lw = 50._kind_phys + end do end subroutine rad_lw_run diff --git a/test/nested_suite_test/rad_sw.F90 b/test/nested_suite_test/rad_sw.F90 index ddf35224..64756217 100644 --- a/test/nested_suite_test/rad_sw.F90 +++ b/test/nested_suite_test/rad_sw.F90 @@ -13,11 +13,11 @@ module rad_sw !! subroutine rad_sw_run(ncol, sfc_up_sw, sfc_down_sw, errmsg, errflg) - integer, intent(in) :: ncol - real(kind_phys), intent(inout) :: sfc_up_sw(:) - real(kind_phys), intent(inout) :: sfc_down_sw(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + real(kind=kind_phys), intent(inout) :: sfc_up_sw(:) + real(kind=kind_phys), intent(inout) :: sfc_down_sw(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg ! Locals integer :: icol @@ -25,10 +25,10 @@ subroutine rad_sw_run(ncol, sfc_up_sw, sfc_down_sw, errmsg, errflg) errmsg = '' errflg = 0 - do icol=1,ncol - sfc_up_sw(icol) = 100._kind_phys - sfc_down_sw(icol) = 400._kind_phys - enddo + do icol = 1, ncol + sfc_up_sw(icol) = 100._kind_phys + sfc_down_sw(icol) = 400._kind_phys + end do end subroutine rad_sw_run diff --git a/test/nested_suite_test/test_host.F90 b/test/nested_suite_test/test_host.F90 index f3a389e8..67c7a1ac 100644 --- a/test/nested_suite_test/test_host.F90 +++ b/test/nested_suite_test/test_host.F90 @@ -1,264 +1,264 @@ 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 = 32 - integer, public, parameter :: cm = 60 + ! Public data and interfaces + integer, public, parameter :: cs = 32 + integer, public, parameter :: cm = 60 - !> \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) + use test_host_mod, only: ncols + 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 + use test_utils, only: check_list - use test_host_mod, only: ncols - 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 - 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 :: index, sind + 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 :: 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 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 - ! 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 - - ! 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 + ! 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 - 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 - 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 col_start = 1, ncols, 5 + if (errflg /= 0) then + exit + end if + col_end = min(col_start + 4, ncols) - do sind = 1, num_suites + 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 + exit end if if (errflg == 0) then - call test_host_ccpp_physics_timestep_final( & - test_suites(sind)%suite_name, errmsg, errflg) + 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, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(errmsg) - exit + 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 + 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 - if (errflg == 0) then - ! Run finished without error, check answers - if (compare_data()) then - write(6, *) 'Answers are correct!' - errflg = 0 - else - write(6, *) 'Answers are not correct!' - errflg = -1 - end if - end if + 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 (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/nested_suite_test/test_host_data.F90 b/test/nested_suite_test/test_host_data.F90 index c46bbfff..ece60034 100644 --- a/test/nested_suite_test/test_host_data.F90 +++ b/test/nested_suite_test/test_host_data.F90 @@ -1,32 +1,33 @@ module test_host_data - use ccpp_kinds, only: kind_phys - use mod_rad_ddt, only: ty_rad_lw, ty_rad_sw + use ccpp_kinds, only: kind_phys + use mod_rad_ddt, only: ty_rad_lw, & + ty_rad_sw - implicit none - private + implicit none + private !> \section arg_table_physics_state Argument Table !! \htmlinclude arg_table_physics_state.html type physics_state - real(kind_phys), dimension(:,:), allocatable :: & - effrr, & ! effective radius of cloud rain - effrl, & ! effective radius of cloud liquid water - effri, & ! effective radius of cloud ice - effrg, & ! effective radius of cloud graupel - ncg, & ! number concentration of cloud graupel - nci ! number concentration of cloud ice - real(kind_phys) :: scalar_var - type(ty_rad_lw), dimension(:), allocatable :: & - fluxLW ! Longwave radiation fluxes - type(ty_rad_sw) :: & - fluxSW ! Shortwave radiation fluxes - real(kind_phys) :: scalar_varA - real(kind_phys) :: scalar_varB - real(kind_phys) :: tke, tke2 - integer :: scalar_varC - integer :: scheme_order - integer :: num_subcycles + real(kind=kind_phys), dimension(:, :), allocatable :: & + effrr, & ! effective radius of cloud rain + effrl, & ! effective radius of cloud liquid water + effri, & ! effective radius of cloud ice + effrg, & ! effective radius of cloud graupel + ncg, & ! number concentration of cloud graupel + nci ! number concentration of cloud ice + real(kind=kind_phys) :: scalar_var + type(ty_rad_lw), dimension(:), allocatable :: & + fluxlw ! Longwave radiation fluxes + type(ty_rad_sw) :: & + fluxsw ! Shortwave radiation fluxes + real(kind=kind_phys) :: scalar_vara + real(kind=kind_phys) :: scalar_varb + real(kind=kind_phys) :: tke, tke2 + integer :: scalar_varc + integer :: scheme_order + integer :: num_subcycles end type physics_state public :: physics_state @@ -35,62 +36,62 @@ module test_host_data contains subroutine allocate_physics_state(cols, levels, state, has_graupel, has_ice) - integer, intent(in) :: cols - integer, intent(in) :: levels + integer, intent(in) :: cols + integer, intent(in) :: levels type(physics_state), intent(out) :: state - logical, intent(in) :: has_graupel - logical, intent(in) :: has_ice + logical, intent(in) :: has_graupel + logical, intent(in) :: has_ice if (allocated(state%effrr)) then - deallocate(state%effrr) + deallocate(state%effrr) end if allocate(state%effrr(cols, levels)) if (allocated(state%effrl)) then - deallocate(state%effrl) + deallocate(state%effrl) end if allocate(state%effrl(cols, levels)) if (has_ice) then - if (allocated(state%effri)) then - deallocate(state%effri) - end if - allocate(state%effri(cols, levels)) - endif + if (allocated(state%effri)) then + deallocate(state%effri) + end if + allocate(state%effri(cols, levels)) + end if if (has_graupel) then - if (allocated(state%effrg)) then - deallocate(state%effrg) - end if - allocate(state%effrg(cols, levels)) - - if (allocated(state%ncg)) then - deallocate(state%ncg) - end if - allocate(state%ncg(cols, levels)) - endif + if (allocated(state%effrg)) then + deallocate(state%effrg) + end if + allocate(state%effrg(cols, levels)) + + if (allocated(state%ncg)) then + deallocate(state%ncg) + end if + allocate(state%ncg(cols, levels)) + end if if (has_ice) then - if (allocated(state%nci)) then - deallocate(state%nci) - end if - allocate(state%nci(cols, levels)) - endif - - if (allocated(state%fluxLW)) then - deallocate(state%fluxLW) + if (allocated(state%nci)) then + deallocate(state%nci) + end if + allocate(state%nci(cols, levels)) + end if + + if (allocated(state%fluxlw)) then + deallocate(state%fluxlw) end if - allocate(state%fluxLW(cols)) + allocate(state%fluxlw(cols)) - if (associated(state%fluxSW%sfc_up_sw)) then - nullify(state%fluxSW%sfc_up_sw) + if (associated(state%fluxsw%sfc_up_sw)) then + nullify(state%fluxsw%sfc_up_sw) end if - allocate(state%fluxSW%sfc_up_sw(cols)) + allocate(state%fluxsw%sfc_up_sw(cols)) - if (associated(state%fluxSW%sfc_down_sw)) then - nullify(state%fluxSW%sfc_down_sw) + if (associated(state%fluxsw%sfc_down_sw)) then + nullify(state%fluxsw%sfc_down_sw) end if - allocate(state%fluxSW%sfc_down_sw(cols)) + allocate(state%fluxsw%sfc_down_sw(cols)) ! Initialize scheme counter. state%scheme_order = 1 diff --git a/test/nested_suite_test/test_host_mod.F90 b/test/nested_suite_test/test_host_mod.F90 index 09d1fdb5..d3bde866 100644 --- a/test/nested_suite_test/test_host_mod.F90 +++ b/test/nested_suite_test/test_host_mod.F90 @@ -1,23 +1,24 @@ 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 = 12 - integer, parameter :: pver = 4 - type(physics_state) :: phys_state - real(kind_phys) :: effrs(ncols, pver) - logical, parameter :: has_ice = .true. - logical, parameter :: has_graupel = .true. - - public :: init_data - public :: compare_data + 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 = 12 + integer, parameter :: pver = 4 + type(physics_state) :: phys_state + real(kind=kind_phys) :: effrs(ncols, pver) + logical, parameter :: has_ice = .true. + logical, parameter :: has_graupel = .true. + + public :: init_data + public :: compare_data contains @@ -27,19 +28,19 @@ subroutine init_data() call allocate_physics_state(ncols, pver, phys_state, has_graupel, has_ice) phys_state%effrr = 1.0E-3 ! 1000 microns, in meter phys_state%effrl = 1.0E-4 ! 100 microns, in meter - phys_state%scalar_var = 1.0 ! in m - phys_state%scalar_varA = 273.15 ! in K - phys_state%scalar_varB = 1013.0 ! in mb - phys_state%scalar_varC = 380 ! in ppmv - effrs = 5.0E-4 ! 500 microns, in meter + phys_state%scalar_var = 1.0 ! in m + phys_state%scalar_vara = 273.15 ! in K + phys_state%scalar_varb = 1013.0 ! in mb + phys_state%scalar_varc = 380 ! in ppmv + effrs = 5.0E-4 ! 500 microns, in meter if (has_graupel) then - phys_state%effrg = 2.5E-4 ! 250 microns, in meter - phys_state%ncg = 40 - endif + phys_state%effrg = 2.5E-4 ! 250 microns, in meter + phys_state%ncg = 40 + end if if (has_ice) then - phys_state%effri = 5.0E-5 ! 50 microns, in meter - phys_state%nci = 80 - endif + phys_state%effri = 5.0E-5 ! 50 microns, in meter + phys_state%nci = 80 + end if phys_state%tke = 10.0 !J kg-1 phys_state%tke2 = 42.0 !J kg-1 @@ -47,80 +48,85 @@ end subroutine init_data logical function compare_data() - real(kind_phys), parameter :: effrr_expected = 1.0E-3 ! 1000 microns, in meter - real(kind_phys), parameter :: effrl_expected = 5.0E-5 ! 50 microns, in meter - real(kind_phys), parameter :: effri_expected = 7.5E-5 ! 75 microns, in meter - real(kind_phys), parameter :: effrs_expected = 5.3E-4 ! 530 microns, in meter - real(kind_phys), parameter :: scalar_expected = 2.0E3 ! 2 km, in meter - real(kind_phys), parameter :: tke_expected = 10.0 ! 10 J kg-1 - real(kind_phys), parameter :: tolerance = 1.0E-6 ! used as scaling factor for expected value - real(kind_phys), parameter :: sfc_up_sw_expected = 100. ! W/m2 - real(kind_phys), parameter :: sfc_down_sw_expected = 400. ! W/m2 - real(kind_phys), parameter :: sfc_up_lw_expected = 300. ! W/m2 - real(kind_phys), parameter :: sfc_down_lw_expected = 50. ! W/m2 + real(kind=kind_phys), parameter :: effrr_expected = 1.0E-3 ! 1000 microns, in meter + real(kind=kind_phys), parameter :: effrl_expected = 5.0E-5 ! 50 microns, in meter + real(kind=kind_phys), parameter :: effri_expected = 7.5E-5 ! 75 microns, in meter + real(kind=kind_phys), parameter :: effrs_expected = 5.3E-4 ! 530 microns, in meter + real(kind=kind_phys), parameter :: scalar_expected = 2.0E3 ! 2 km, in meter + real(kind=kind_phys), parameter :: tke_expected = 10.0 ! 10 J kg-1 + real(kind=kind_phys), parameter :: tolerance = 1.0E-6 ! used as scaling factor for expected value + real(kind=kind_phys), parameter :: sfc_up_sw_expected = 100. ! W/m2 + real(kind=kind_phys), parameter :: sfc_down_sw_expected = 400. ! W/m2 + real(kind=kind_phys), parameter :: sfc_up_lw_expected = 300. ! W/m2 + real(kind=kind_phys), parameter :: sfc_down_lw_expected = 50. ! W/m2 compare_data = .true. - if (maxval(abs(phys_state%effrr - effrr_expected)) > tolerance*effrr_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrr from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effrr - effrr_expected)), ' > ', tolerance*effrr_expected - compare_data = .false. + if (maxval(abs(phys_state%effrr - effrr_expected)) > tolerance * effrr_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrr from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effrr - effrr_expected)), ' > ', tolerance * effrr_expected + compare_data = .false. + end if + + if (maxval(abs(phys_state%effrl - effrl_expected)) > tolerance * effrl_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrl from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effrl - effrl_expected)), ' > ', tolerance * effrl_expected + compare_data = .false. + end if + + if (maxval(abs(phys_state%effri - effri_expected)) > tolerance * effri_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effri from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effri - effri_expected)), ' > ', tolerance * effri_expected + compare_data = .false. + end if + + if (maxval(abs(effrs - effrs_expected)) > tolerance * effrs_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of effrs from expected value exceeds tolerance: ', & + maxval(abs(effrs - effrs_expected)), ' > ', tolerance * effrs_expected + compare_data = .false. + end if + + if (abs(phys_state%scalar_var - scalar_expected) > tolerance * scalar_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of scalar_var from expected value exceeds tolerance: ', & + abs(phys_state%scalar_var - scalar_expected), ' > ', tolerance * scalar_expected + compare_data = .false. end if - if (maxval(abs(phys_state%effrl - effrl_expected)) > tolerance*effrl_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrl from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effrl - effrl_expected)), ' > ', tolerance*effrl_expected - compare_data = .false. + if (abs(phys_state%tke - tke_expected) > tolerance * tke_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of tke from expected value exceeds tolerance: ', & + abs(phys_state%tke - tke_expected), ' > ', tolerance * tke_expected + compare_data = .false. end if - if (maxval(abs(phys_state%effri - effri_expected)) > tolerance*effri_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effri from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effri - effri_expected)), ' > ', tolerance*effri_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxsw%sfc_up_sw - sfc_up_sw_expected)) > tolerance * sfc_up_sw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_up_sw from expected value exceeds tolerance: ', & + abs(phys_state%fluxsw%sfc_up_sw - sfc_up_sw_expected), ' > ', tolerance * sfc_up_sw_expected + compare_data = .false. end if - if (maxval(abs( effrs - effrs_expected)) > tolerance*effrs_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of effrs from expected value exceeds tolerance: ', & - maxval(abs( effrs - effrs_expected)), ' > ', tolerance*effrs_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxsw%sfc_down_sw - sfc_down_sw_expected)) > tolerance * sfc_down_sw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_down_sw from expected value exceeds tolerance: ', & + abs(phys_state%fluxsw%sfc_down_sw - sfc_down_sw_expected), ' > ', tolerance * sfc_down_sw_expected + compare_data = .false. end if - if (abs( phys_state%scalar_var - scalar_expected) > tolerance*scalar_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of scalar_var from expected value exceeds tolerance: ', & - abs( phys_state%scalar_var - scalar_expected), ' > ', tolerance*scalar_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxlw%sfc_up_lw - sfc_up_lw_expected)) > tolerance * sfc_up_lw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_up_lw from expected value exceeds tolerance: ', & + abs(phys_state%fluxlw%sfc_up_lw - sfc_up_lw_expected), ' > ', tolerance * sfc_up_lw_expected + compare_data = .false. end if - if (abs( phys_state%tke - tke_expected) > tolerance*tke_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of tke from expected value exceeds tolerance: ', & - abs( phys_state%tke - tke_expected), ' > ', tolerance*tke_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxlw%sfc_down_lw - sfc_down_lw_expected)) > tolerance * sfc_down_lw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_down_lw from expected value exceeds tolerance: ', & + abs(phys_state%fluxlw%sfc_down_lw - sfc_down_lw_expected), ' > ', tolerance * sfc_down_lw_expected + compare_data = .false. end if - if (maxval(abs( phys_state%fluxSW%sfc_up_sw - sfc_up_sw_expected)) > tolerance*sfc_up_sw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_up_sw from expected value exceeds tolerance: ', & - abs( phys_state%fluxSW%sfc_up_sw - sfc_up_sw_expected), ' > ', tolerance*sfc_up_sw_expected - compare_data = .false. - end if - - if (maxval(abs( phys_state%fluxSW%sfc_down_sw - sfc_down_sw_expected)) > tolerance*sfc_down_sw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_down_sw from expected value exceeds tolerance: ', & - abs( phys_state%fluxSW%sfc_down_sw - sfc_down_sw_expected), ' > ', tolerance*sfc_down_sw_expected - compare_data = .false. - end if - - if (maxval(abs( phys_state%fluxLW%sfc_up_lw - sfc_up_lw_expected)) > tolerance*sfc_up_lw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_up_lw from expected value exceeds tolerance: ', & - abs( phys_state%fluxLW%sfc_up_lw - sfc_up_lw_expected), ' > ', tolerance*sfc_up_lw_expected - compare_data = .false. - end if - - if (maxval(abs( phys_state%fluxLW%sfc_down_lw - sfc_down_lw_expected)) > tolerance*sfc_down_lw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_down_lw from expected value exceeds tolerance: ', & - abs( phys_state%fluxLW%sfc_down_lw - sfc_down_lw_expected), ' > ', tolerance*sfc_down_lw_expected - compare_data = .false. - end if - end function compare_data end module test_host_mod diff --git a/test/nested_suite_test/test_nested_suite_integration.F90 b/test/nested_suite_test/test_nested_suite_integration.F90 index 09dfea10..5e9c3009 100644 --- a/test/nested_suite_test/test_nested_suite_integration.F90 +++ b/test/nested_suite_test/test_nested_suite_integration.F90 @@ -1,88 +1,91 @@ program test_nested_suite_integration - 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(3) = (/ & - 'radiation1 ', & - 'rad_lw_group ', & - 'rad_sw_group '/) + character(len=cs), target :: test_parts1(3) = (/ & + 'radiation1 ', & + 'rad_lw_group ', & + 'rad_sw_group '/) - character(len=cm), target :: test_invars1(18) = (/ & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'effective_radius_of_stratiform_cloud_graupel ', & - 'cloud_graupel_number_concentration ', & - 'scalar_variable_for_testing ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'scalar_variable_for_testing_a ', & - 'scalar_variable_for_testing_b ', & - 'scalar_variable_for_testing_c ', & - 'scheme_order_in_suite ', & - 'num_subcycles_for_effr ', & - 'flag_indicating_cloud_microphysics_has_graupel ', & - 'flag_indicating_cloud_microphysics_has_ice ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_invars1(18) = (/ & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'effective_radius_of_stratiform_cloud_graupel ', & + 'cloud_graupel_number_concentration ', & + 'scalar_variable_for_testing ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'scalar_variable_for_testing_a ', & + 'scalar_variable_for_testing_b ', & + 'scalar_variable_for_testing_c ', & + 'scheme_order_in_suite ', & + 'num_subcycles_for_effr ', & + 'flag_indicating_cloud_microphysics_has_graupel ', & + 'flag_indicating_cloud_microphysics_has_ice ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'longwave_radiation_fluxes '/) - character(len=cm), target :: test_outvars1(14) = (/ & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'effective_radius_of_stratiform_cloud_ice_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'cloud_ice_number_concentration ', & - 'scalar_variable_for_testing ', & - 'scheme_order_in_suite ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_outvars1(14) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'effective_radius_of_stratiform_cloud_ice_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'cloud_ice_number_concentration ', & + 'scalar_variable_for_testing ', & + 'scheme_order_in_suite ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'longwave_radiation_fluxes '/) - character(len=cm), target :: test_reqvars1(22) = (/ & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_ice_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'effective_radius_of_stratiform_cloud_graupel ', & - 'cloud_graupel_number_concentration ', & - 'cloud_ice_number_concentration ', & - 'scalar_variable_for_testing ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'scalar_variable_for_testing_a ', & - 'scalar_variable_for_testing_b ', & - 'scalar_variable_for_testing_c ', & - 'scheme_order_in_suite ', & - 'num_subcycles_for_effr ', & - 'flag_indicating_cloud_microphysics_has_graupel ', & - 'flag_indicating_cloud_microphysics_has_ice ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_reqvars1(22) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_ice_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'effective_radius_of_stratiform_cloud_graupel ', & + 'cloud_graupel_number_concentration ', & + 'cloud_ice_number_concentration ', & + 'scalar_variable_for_testing ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'scalar_variable_for_testing_a ', & + 'scalar_variable_for_testing_b ', & + 'scalar_variable_for_testing_c ', & + 'scheme_order_in_suite ', & + 'num_subcycles_for_effr ', & + 'flag_indicating_cloud_microphysics_has_graupel ', & + 'flag_indicating_cloud_microphysics_has_ice ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'longwave_radiation_fluxes '/) - type(suite_info) :: test_suites(1) - logical :: run_okay + type(suite_info) :: test_suites(1) + logical :: run_okay - ! Setup expected test suite info - test_suites(1)%suite_name = 'main_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 + ! Setup expected test suite info + test_suites(1)%suite_name = 'main_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 - 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_nested_suite_integration diff --git a/test/utils/test_utils.F90 b/test/utils/test_utils.F90 index 088c347d..3ae8d549 100644 --- a/test/utils/test_utils.F90 +++ b/test/utils/test_utils.F90 @@ -1,88 +1,88 @@ module test_utils - public :: check_list + public :: check_list contains - logical function check_list(test_list, chk_list, list_desc, suite_name) + logical function check_list(test_list, chk_list, list_desc, suite_name) ! Check a list () against its expected value () - ! Dummy arguments - character(len=*), intent(in) :: test_list(:) - character(len=*), intent(in) :: chk_list(:) - character(len=*), intent(in) :: list_desc - character(len=*), optional, intent(in) :: suite_name + ! Dummy arguments + character(len=*), intent(in) :: test_list(:) + character(len=*), intent(in) :: chk_list(:) + character(len=*), intent(in) :: list_desc + character(len=*), optional, intent(in) :: suite_name - ! Local variables - logical :: found - integer :: num_items - integer :: lindex, tindex - integer, allocatable :: check_unique(:) - character(len=2) :: sep - character(len=256) :: errmsg + ! Local variables + logical :: found + integer :: num_items + integer :: lindex, tindex + integer, allocatable :: check_unique(:) + character(len=2) :: sep + character(len=256) :: errmsg - check_list = .true. - errmsg = '' + check_list = .true. + errmsg = '' - ! Check the list size - num_items = size(chk_list) - if (size(test_list) /= num_items) then - write(errmsg, '(a,i0,2a)') 'ERROR: Found ', size(test_list), & - ' ', trim(list_desc) - if (present(suite_name)) then - write(errmsg(len_trim(errmsg)+1:), '(2a)') ' for suite, ', & - trim(suite_name) - end if - write(errmsg(len_trim(errmsg)+1:), '(a,i0)') ', should be ', num_items - write(6, *) trim(errmsg) - errmsg = '' - check_list = .false. - end if + ! Check the list size + num_items = size(chk_list) + if (size(test_list) /= num_items) then + write(errmsg, '(a,i0,2a)') 'ERROR: Found ', size(test_list), & + ' ', trim(list_desc) + if (present(suite_name)) then + write(errmsg(len_trim(errmsg) + 1:), '(2a)') ' for suite, ', & + trim(suite_name) + end if + write(errmsg(len_trim(errmsg) + 1:), '(a,i0)') ', should be ', num_items + write(6, *) trim(errmsg) + errmsg = '' + check_list = .false. + end if - ! Now, check the list contents for 1-1 correspondence - if (check_list) then - allocate(check_unique(num_items)) - check_unique = -1 - do lindex = 1, num_items - found = .false. - do tindex = 1, num_items - if (trim(test_list(lindex)) == trim(chk_list(tindex))) then - check_unique(tindex) = lindex - found = .true. - exit - end if - end do - if (.not. found) then - check_list = .false. - write(errmsg, '(5a)') 'ERROR: ', trim(list_desc), ' item, ', & - trim(test_list(lindex)), ', was not found' - if (present(suite_name)) then - write(errmsg(len_trim(errmsg)+1:), '(2a)') ' in suite, ', & - trim(suite_name) - end if - write(6, *) trim(errmsg) - errmsg = '' - end if - end do - if (check_list .and. any(check_unique < 0)) then - check_list = .false. - write(errmsg, '(3a)') 'ERROR: The following ', trim(list_desc), & - ' items were not found' - if (present(suite_name)) then - write(errmsg(len_trim(errmsg)+1:), '(2a)') ' in suite, ', & - trim(suite_name) - end if - sep = '; ' - do lindex = 1, num_items - if (check_unique(lindex) < 0) then - write(errmsg(len_trim(errmsg)+1:), '(2a)') sep, & - trim(chk_list(lindex)) - sep = ', ' - end if - end do - write(6, *) trim(errmsg) - errmsg = '' - end if + ! Now, check the list contents for 1-1 correspondence + if (check_list) then + allocate(check_unique(num_items)) + check_unique = -1 + do lindex = 1, num_items + found = .false. + do tindex = 1, num_items + if (trim(test_list(lindex)) == trim(chk_list(tindex))) then + check_unique(tindex) = lindex + found = .true. + exit + end if + end do + if (.not. found) then + check_list = .false. + write(errmsg, '(5a)') 'ERROR: ', trim(list_desc), ' item, ', & + trim(test_list(lindex)), ', was not found' + if (present(suite_name)) then + write(errmsg(len_trim(errmsg) + 1:), '(2a)') ' in suite, ', & + trim(suite_name) + end if + write(6, *) trim(errmsg) + errmsg = '' end if + end do + if (check_list .and. any(check_unique < 0)) then + check_list = .false. + write(errmsg, '(3a)') 'ERROR: The following ', trim(list_desc), & + ' items were not found' + if (present(suite_name)) then + write(errmsg(len_trim(errmsg) + 1:), '(2a)') ' in suite, ', & + trim(suite_name) + end if + sep = '; ' + do lindex = 1, num_items + if (check_unique(lindex) < 0) then + write(errmsg(len_trim(errmsg) + 1:), '(2a)') sep, & + trim(chk_list(lindex)) + sep = ', ' + end if + end do + write(6, *) trim(errmsg) + errmsg = '' + end if + end if - end function check_list + end function check_list end module test_utils diff --git a/test/var_compatibility_test/effr_calc.F90 b/test/var_compatibility_test/effr_calc.F90 index 0b626c16..b8fc43ed 100644 --- a/test/var_compatibility_test/effr_calc.F90 +++ b/test/var_compatibility_test/effr_calc.F90 @@ -3,82 +3,82 @@ module effr_calc - use ccpp_kinds, only: kind_phys - - implicit none - private - - public :: effr_calc_run, effr_calc_init - - contains - !> \section arg_table_effr_calc_init Argument Table - !! \htmlinclude arg_table_effr_calc_init.html - !! - subroutine effr_calc_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order .ne. 2) then - errflg = 1 - errmsg = 'ERROR: effr_calc_init() needs to be called second' - return - else - scheme_order = scheme_order + 1 - endif - - end subroutine effr_calc_init - - !> \section arg_table_effr_calc_run Argument Table - !! \htmlinclude arg_table_effr_calc_run.html - !! - subroutine effr_calc_run(ncol, nlev, effrr_in, effrg_in, ncg_in, nci_out, & - effrl_inout, effri_out, effrs_inout, ncl_out, & - has_graupel, scalar_var, tke_inout, tke2_inout, & - errmsg, errflg) - - integer, intent(in) :: ncol - integer, intent(in) :: nlev - real(kind_phys), intent(in) :: effrr_in(:,:) - real(kind_phys), intent(in),optional :: effrg_in(:,:) - real(kind_phys), intent(in),optional :: ncg_in(:,:) - real(kind_phys), intent(out),optional :: nci_out(:,:) - real(kind_phys), intent(inout) :: effrl_inout(:,:) - real(kind_phys), intent(out),optional :: effri_out(:,:) - real(8),intent(inout) :: effrs_inout(:,:) - logical, intent(in) :: has_graupel - real(kind_phys), intent(inout) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - real(kind_phys), intent(out),optional :: ncl_out(:,:) - real(kind_phys), intent(inout) :: tke_inout - real(kind_phys), intent(inout) :: tke2_inout - - !---------------------------------------------------------------- - - real(kind_phys), parameter :: re_qc_min = 2.5 ! microns - real(kind_phys), parameter :: re_qc_max = 50. ! microns - real(kind_phys), parameter :: re_qi_avg = 75. ! microns - real(kind_phys) :: effrr_local(ncol,nlev) - real(kind_phys) :: effrg_local(ncol,nlev) - real(kind_phys) :: ncg_in_local(ncol,nlev) - real(kind_phys) :: nci_out_local(ncol,nlev) - - errmsg = '' - errflg = 0 - - effrr_local = effrr_in - if (present(effrg_in)) effrg_local = effrg_in - if (present(ncg_in)) ncg_in_local = ncg_in - if (present(nci_out)) nci_out_local = nci_out - effrl_inout = min(max(effrl_inout,re_qc_min),re_qc_max) - if (present(effri_out)) effri_out = re_qi_avg - effrs_inout = effrs_inout + (10.0 / 6.0) ! in micrometer - scalar_var = 2.0 ! in km - - end subroutine effr_calc_run + use ccpp_kinds, only: kind_phys + + implicit none + private + + public :: effr_calc_run, effr_calc_init + +contains + !> \section arg_table_effr_calc_init Argument Table + !! \htmlinclude arg_table_effr_calc_init.html + !! + subroutine effr_calc_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order /= 2) then + errflg = 1 + errmsg = 'ERROR: effr_calc_init() needs to be called second' + return + else + scheme_order = scheme_order + 1 + end if + + end subroutine effr_calc_init + + !> \section arg_table_effr_calc_run Argument Table + !! \htmlinclude arg_table_effr_calc_run.html + !! + subroutine effr_calc_run(ncol, nlev, effrr_in, effrg_in, ncg_in, nci_out, & + effrl_inout, effri_out, effrs_inout, ncl_out, & + has_graupel, scalar_var, tke_inout, tke2_inout, & + errmsg, errflg) + + integer, intent(in) :: ncol + integer, intent(in) :: nlev + real(kind=kind_phys), intent(in) :: effrr_in(:, :) + real(kind=kind_phys), intent(in), optional :: effrg_in(:, :) + real(kind=kind_phys), intent(in), optional :: ncg_in(:, :) + real(kind=kind_phys), intent(out), optional :: nci_out(:, :) + real(kind=kind_phys), intent(inout) :: effrl_inout(:, :) + real(kind=kind_phys), intent(out), optional :: effri_out(:, :) + real(kind=8), intent(inout) :: effrs_inout(:, :) + logical, intent(in) :: has_graupel + real(kind=kind_phys), intent(inout) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind=kind_phys), intent(out), optional :: ncl_out(:, :) + real(kind=kind_phys), intent(inout) :: tke_inout + real(kind=kind_phys), intent(inout) :: tke2_inout + + !---------------------------------------------------------------- + + real(kind=kind_phys), parameter :: re_qc_min = 2.5 ! microns + real(kind=kind_phys), parameter :: re_qc_max = 50. ! microns + real(kind=kind_phys), parameter :: re_qi_avg = 75. ! microns + real(kind=kind_phys) :: effrr_local(ncol, nlev) + real(kind=kind_phys) :: effrg_local(ncol, nlev) + real(kind=kind_phys) :: ncg_in_local(ncol, nlev) + real(kind=kind_phys) :: nci_out_local(ncol, nlev) + + errmsg = '' + errflg = 0 + + effrr_local = effrr_in + if (present(effrg_in)) effrg_local = effrg_in + if (present(ncg_in)) ncg_in_local = ncg_in + if (present(nci_out)) nci_out_local = nci_out + effrl_inout = min(max(effrl_inout, re_qc_min), re_qc_max) + if (present(effri_out)) effri_out = re_qi_avg + effrs_inout = effrs_inout + (10.0 / 6.0) ! in micrometer + scalar_var = 2.0 ! in km + + end subroutine effr_calc_run end module effr_calc diff --git a/test/var_compatibility_test/effr_diag.F90 b/test/var_compatibility_test/effr_diag.F90 index 409ff2f9..75da29c7 100644 --- a/test/var_compatibility_test/effr_diag.F90 +++ b/test/var_compatibility_test/effr_diag.F90 @@ -3,12 +3,12 @@ module effr_diag - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_diag_run, effr_diag_init + public :: effr_diag_run, effr_diag_init contains @@ -16,53 +16,53 @@ module effr_diag !! \htmlinclude arg_table_effr_diag_init.html !! subroutine effr_diag_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + errmsg = '' errflg = 0 - if (scheme_order .ne. 4) then - errflg = 1 - errmsg = 'ERROR: effr_diag_init() needs to be called fourth' - return - else - scheme_order = scheme_order + 1 - endif + if (scheme_order /= 4) then + errflg = 1 + errmsg = 'ERROR: effr_diag_init() needs to be called fourth' + return + else + scheme_order = scheme_order + 1 + end if end subroutine effr_diag_init - !> \section arg_table_effr_diag_run Argument Table - !! \htmlinclude arg_table_effr_diag_run.html - !! - subroutine effr_diag_run( effrr_in, scalar_var, errmsg, errflg) - - real(kind_phys), intent(in) :: effrr_in(:,:) - integer, intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - call cmp_effr_diag(effrr_in, effrr_min, effrr_max) - - if (scalar_var .ne. 380) then - errmsg = 'ERROR: effr_diag_run(): scalar_var should be 380' - errflg = 1 - endif - end subroutine effr_diag_run - - subroutine cmp_effr_diag(effr, effr_min, effr_max) - real(kind_phys), intent(in) :: effr(:,:) - real(kind_phys), intent(out) :: effr_min, effr_max - - ! Do some diagnostic calcualtions... - effr_min = minval(effr) - effr_max = maxval(effr) - - end subroutine cmp_effr_diag + !> \section arg_table_effr_diag_run Argument Table + !! \htmlinclude arg_table_effr_diag_run.html + !! + subroutine effr_diag_run(effrr_in, scalar_var, errmsg, errflg) + + real(kind=kind_phys), intent(in) :: effrr_in(:, :) + integer, intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind=kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + call cmp_effr_diag(effrr_in, effrr_min, effrr_max) + + if (scalar_var /= 380) then + errmsg = 'ERROR: effr_diag_run(): scalar_var should be 380' + errflg = 1 + end if + end subroutine effr_diag_run + + subroutine cmp_effr_diag(effr, effr_min, effr_max) + real(kind=kind_phys), intent(in) :: effr(:, :) + real(kind=kind_phys), intent(out) :: effr_min, effr_max + + ! Do some diagnostic calcualtions... + effr_min = minval(effr) + effr_max = maxval(effr) + + end subroutine cmp_effr_diag end module effr_diag diff --git a/test/var_compatibility_test/effr_post.F90 b/test/var_compatibility_test/effr_post.F90 index d42a574c..01357350 100644 --- a/test/var_compatibility_test/effr_post.F90 +++ b/test/var_compatibility_test/effr_post.F90 @@ -3,59 +3,59 @@ module effr_post - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_post_run, effr_post_init + public :: effr_post_run, effr_post_init contains - !> \section arg_table_effr_post_init Argument Table - !! \htmlinclude arg_table_effr_post_init.html - !! - subroutine effr_post_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order .ne. 3) then - errflg = 1 - errmsg = 'ERROR: effr_post_init() needs to be called third' - return - else - scheme_order = scheme_order + 1 - endif - - end subroutine effr_post_init - - !> \section arg_table_effr_post_run Argument Table - !! \htmlinclude arg_table_effr_post_run.html - !! - subroutine effr_post_run( effrr_inout, scalar_var, errmsg, errflg) - - real(kind_phys), intent(inout) :: effrr_inout(:,:) - real(kind_phys), intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - ! Do some post-processing on effrr... - effrr_inout(:,:) = effrr_inout(:,:)*1._kind_phys - - if (scalar_var .ne. 1013.0) then - errmsg = 'ERROR: effr_post_run(): scalar_var should be 1013.0' - errflg = 1 - endif - - end subroutine effr_post_run - - end module effr_post + !> \section arg_table_effr_post_init Argument Table + !! \htmlinclude arg_table_effr_post_init.html + !! + subroutine effr_post_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order /= 3) then + errflg = 1 + errmsg = 'ERROR: effr_post_init() needs to be called third' + return + else + scheme_order = scheme_order + 1 + end if + + end subroutine effr_post_init + + !> \section arg_table_effr_post_run Argument Table + !! \htmlinclude arg_table_effr_post_run.html + !! + subroutine effr_post_run(effrr_inout, scalar_var, errmsg, errflg) + + real(kind=kind_phys), intent(inout) :: effrr_inout(:, :) + real(kind=kind_phys), intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind=kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + ! Do some post-processing on effrr... + effrr_inout(:, :) = effrr_inout(:, :) * 1._kind_phys + + if (scalar_var /= 1013.0) then + errmsg = 'ERROR: effr_post_run(): scalar_var should be 1013.0' + errflg = 1 + end if + + end subroutine effr_post_run + +end module effr_post diff --git a/test/var_compatibility_test/effr_pre.F90 b/test/var_compatibility_test/effr_pre.F90 index 17a3b187..a2fe2f5c 100644 --- a/test/var_compatibility_test/effr_pre.F90 +++ b/test/var_compatibility_test/effr_pre.F90 @@ -3,58 +3,58 @@ module mod_effr_pre - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effr_pre_run, effr_pre_init + public :: effr_pre_run, effr_pre_init contains - !> \section arg_table_effr_pre_init Argument Table - !! \htmlinclude arg_table_effr_pre_init.html - !! - subroutine effr_pre_init(scheme_order, errmsg, errflg) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: scheme_order - - errmsg = '' - errflg = 0 - - if (scheme_order .ne. 1) then - errflg = 1 - errmsg = 'ERROR: effr_pre_init() needs to be called first' - return - else - scheme_order = scheme_order + 1 - endif - - end subroutine effr_pre_init - - !> \section arg_table_effr_pre_run Argument Table - !! \htmlinclude arg_table_effr_pre_run.html - !! - subroutine effr_pre_run( effrr_inout, scalar_var, errmsg, errflg) - - real(kind_phys), intent(inout) :: effrr_inout(:,:) - real(kind_phys), intent(in) :: scalar_var - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg - !---------------------------------------------------------------- - real(kind_phys) :: effrr_min, effrr_max - - errmsg = '' - errflg = 0 - - ! Do some pre-processing on effrr... - effrr_inout(:,:) = effrr_inout(:,:)*1._kind_phys - - if (scalar_var .ne. 273.15) then - errmsg = 'ERROR: effr_pre_run(): scalar_var should be 273.15' - errflg = 1 - endif - - end subroutine effr_pre_run + !> \section arg_table_effr_pre_init Argument Table + !! \htmlinclude arg_table_effr_pre_init.html + !! + subroutine effr_pre_init(scheme_order, errmsg, errflg) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: scheme_order + + errmsg = '' + errflg = 0 + + if (scheme_order /= 1) then + errflg = 1 + errmsg = 'ERROR: effr_pre_init() needs to be called first' + return + else + scheme_order = scheme_order + 1 + end if + + end subroutine effr_pre_init + + !> \section arg_table_effr_pre_run Argument Table + !! \htmlinclude arg_table_effr_pre_run.html + !! + subroutine effr_pre_run(effrr_inout, scalar_var, errmsg, errflg) + + real(kind=kind_phys), intent(inout) :: effrr_inout(:, :) + real(kind=kind_phys), intent(in) :: scalar_var + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg + !---------------------------------------------------------------- + real(kind=kind_phys) :: effrr_min, effrr_max + + errmsg = '' + errflg = 0 + + ! Do some pre-processing on effrr... + effrr_inout(:, :) = effrr_inout(:, :) * 1._kind_phys + + if (scalar_var /= 273.15) then + errmsg = 'ERROR: effr_pre_run(): scalar_var should be 273.15' + errflg = 1 + end if + + end subroutine effr_pre_run end module mod_effr_pre diff --git a/test/var_compatibility_test/effrs_calc.F90 b/test/var_compatibility_test/effrs_calc.F90 index e9266905..3aa8d196 100644 --- a/test/var_compatibility_test/effrs_calc.F90 +++ b/test/var_compatibility_test/effrs_calc.F90 @@ -3,30 +3,30 @@ module effrs_calc - use ccpp_kinds, only: kind_phys + use ccpp_kinds, only: kind_phys - implicit none - private + implicit none + private - public :: effrs_calc_run + public :: effrs_calc_run - contains - !> \section arg_table_effrs_calc_run Argument Table - !! \htmlinclude arg_table_effrs_calc_run.html - !! - subroutine effrs_calc_run(effrs_inout, errmsg, errflg) +contains + !> \section arg_table_effrs_calc_run Argument Table + !! \htmlinclude arg_table_effrs_calc_run.html + !! + subroutine effrs_calc_run(effrs_inout, errmsg, errflg) - real(kind_phys), intent(inout) :: effrs_inout(:,:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind=kind_phys), intent(inout) :: effrs_inout(:, :) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg - !---------------------------------------------------------------- + !---------------------------------------------------------------- - errmsg = '' - errflg = 0 + errmsg = '' + errflg = 0 - effrs_inout = effrs_inout + (10.E-6_kind_phys / 3._kind_phys) ! in meters + effrs_inout = effrs_inout + (10.E-6_kind_phys / 3._kind_phys) ! in meters - end subroutine effrs_calc_run + end subroutine effrs_calc_run end module effrs_calc diff --git a/test/var_compatibility_test/module_rad_ddt.F90 b/test/var_compatibility_test/module_rad_ddt.F90 index 21a1a0ec..6e992250 100644 --- a/test/var_compatibility_test/module_rad_ddt.F90 +++ b/test/var_compatibility_test/module_rad_ddt.F90 @@ -1,5 +1,5 @@ module mod_rad_ddt - USE ccpp_kinds, ONLY: kind_phys + use ccpp_kinds, only: kind_phys implicit none public ty_rad_lw, ty_rad_sw @@ -8,16 +8,16 @@ module mod_rad_ddt !! \htmlinclude arg_table_ty_rad_lw.html !! type ty_rad_lw - real(kind_phys) :: sfc_up_lw - real(kind_phys) :: sfc_down_lw + real(kind=kind_phys) :: sfc_up_lw + real(kind=kind_phys) :: sfc_down_lw end type ty_rad_lw !> \section arg_table_ty_rad_sw Argument Table !! \htmlinclude arg_table_ty_rad_sw.html !! type ty_rad_sw - real(kind_phys), pointer :: sfc_up_sw(:) => null() - real(kind_phys), pointer :: sfc_down_sw(:) => null() + real(kind=kind_phys), pointer :: sfc_up_sw(:) => null() + real(kind=kind_phys), pointer :: sfc_down_sw(:) => null() end type ty_rad_sw end module mod_rad_ddt diff --git a/test/var_compatibility_test/rad_lw.F90 b/test/var_compatibility_test/rad_lw.F90 index 5859f8bf..ded4861f 100644 --- a/test/var_compatibility_test/rad_lw.F90 +++ b/test/var_compatibility_test/rad_lw.F90 @@ -12,12 +12,12 @@ module rad_lw !> \section arg_table_rad_lw_run Argument Table !! \htmlinclude arg_table_rad_lw_run.html !! - subroutine rad_lw_run(ncol, fluxLW, errmsg, errflg) + subroutine rad_lw_run(ncol, fluxlw, errmsg, errflg) - integer, intent(in) :: ncol - type(ty_rad_lw), intent(inout) :: fluxLW(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + type(ty_rad_lw), intent(inout) :: fluxlw(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg ! Locals integer :: icol @@ -25,10 +25,10 @@ subroutine rad_lw_run(ncol, fluxLW, errmsg, errflg) errmsg = '' errflg = 0 - do icol=1,ncol - fluxLW(icol)%sfc_up_lw = 300._kind_phys - fluxLW(icol)%sfc_down_lw = 50._kind_phys - enddo + do icol = 1, ncol + fluxlw(icol)%sfc_up_lw = 300._kind_phys + fluxlw(icol)%sfc_down_lw = 50._kind_phys + end do end subroutine rad_lw_run diff --git a/test/var_compatibility_test/rad_sw.F90 b/test/var_compatibility_test/rad_sw.F90 index ddf35224..64756217 100644 --- a/test/var_compatibility_test/rad_sw.F90 +++ b/test/var_compatibility_test/rad_sw.F90 @@ -13,11 +13,11 @@ module rad_sw !! subroutine rad_sw_run(ncol, sfc_up_sw, sfc_down_sw, errmsg, errflg) - integer, intent(in) :: ncol - real(kind_phys), intent(inout) :: sfc_up_sw(:) - real(kind_phys), intent(inout) :: sfc_down_sw(:) - character(len=512), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(in) :: ncol + real(kind=kind_phys), intent(inout) :: sfc_up_sw(:) + real(kind=kind_phys), intent(inout) :: sfc_down_sw(:) + character(len=512), intent(out) :: errmsg + integer, intent(out) :: errflg ! Locals integer :: icol @@ -25,10 +25,10 @@ subroutine rad_sw_run(ncol, sfc_up_sw, sfc_down_sw, errmsg, errflg) errmsg = '' errflg = 0 - do icol=1,ncol - sfc_up_sw(icol) = 100._kind_phys - sfc_down_sw(icol) = 400._kind_phys - enddo + do icol = 1, ncol + sfc_up_sw(icol) = 100._kind_phys + sfc_down_sw(icol) = 400._kind_phys + end do end subroutine rad_sw_run diff --git a/test/var_compatibility_test/test_host.F90 b/test/var_compatibility_test/test_host.F90 index f3a389e8..67c7a1ac 100644 --- a/test/var_compatibility_test/test_host.F90 +++ b/test/var_compatibility_test/test_host.F90 @@ -1,264 +1,264 @@ 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 = 32 - integer, public, parameter :: cm = 60 + ! Public data and interfaces + integer, public, parameter :: cs = 32 + integer, public, parameter :: cm = 60 - !> \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) + use test_host_mod, only: ncols + 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 + use test_utils, only: check_list - use test_host_mod, only: ncols - 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 - 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 :: index, sind + 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 :: 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 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 - ! 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 - - ! 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 + ! 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 - 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 - 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 col_start = 1, ncols, 5 + if (errflg /= 0) then + exit + end if + col_end = min(col_start + 4, ncols) - do sind = 1, num_suites + 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 + exit end if if (errflg == 0) then - call test_host_ccpp_physics_timestep_final( & - test_suites(sind)%suite_name, errmsg, errflg) + 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, '(3a)') trim(test_suites(sind)%suite_name), ': ', & - trim(errmsg) - exit + 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 + 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 - if (errflg == 0) then - ! Run finished without error, check answers - if (compare_data()) then - write(6, *) 'Answers are correct!' - errflg = 0 - else - write(6, *) 'Answers are not correct!' - errflg = -1 - end if - end if + 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 (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/var_compatibility_test/test_host_data.F90 b/test/var_compatibility_test/test_host_data.F90 index c46bbfff..ece60034 100644 --- a/test/var_compatibility_test/test_host_data.F90 +++ b/test/var_compatibility_test/test_host_data.F90 @@ -1,32 +1,33 @@ module test_host_data - use ccpp_kinds, only: kind_phys - use mod_rad_ddt, only: ty_rad_lw, ty_rad_sw + use ccpp_kinds, only: kind_phys + use mod_rad_ddt, only: ty_rad_lw, & + ty_rad_sw - implicit none - private + implicit none + private !> \section arg_table_physics_state Argument Table !! \htmlinclude arg_table_physics_state.html type physics_state - real(kind_phys), dimension(:,:), allocatable :: & - effrr, & ! effective radius of cloud rain - effrl, & ! effective radius of cloud liquid water - effri, & ! effective radius of cloud ice - effrg, & ! effective radius of cloud graupel - ncg, & ! number concentration of cloud graupel - nci ! number concentration of cloud ice - real(kind_phys) :: scalar_var - type(ty_rad_lw), dimension(:), allocatable :: & - fluxLW ! Longwave radiation fluxes - type(ty_rad_sw) :: & - fluxSW ! Shortwave radiation fluxes - real(kind_phys) :: scalar_varA - real(kind_phys) :: scalar_varB - real(kind_phys) :: tke, tke2 - integer :: scalar_varC - integer :: scheme_order - integer :: num_subcycles + real(kind=kind_phys), dimension(:, :), allocatable :: & + effrr, & ! effective radius of cloud rain + effrl, & ! effective radius of cloud liquid water + effri, & ! effective radius of cloud ice + effrg, & ! effective radius of cloud graupel + ncg, & ! number concentration of cloud graupel + nci ! number concentration of cloud ice + real(kind=kind_phys) :: scalar_var + type(ty_rad_lw), dimension(:), allocatable :: & + fluxlw ! Longwave radiation fluxes + type(ty_rad_sw) :: & + fluxsw ! Shortwave radiation fluxes + real(kind=kind_phys) :: scalar_vara + real(kind=kind_phys) :: scalar_varb + real(kind=kind_phys) :: tke, tke2 + integer :: scalar_varc + integer :: scheme_order + integer :: num_subcycles end type physics_state public :: physics_state @@ -35,62 +36,62 @@ module test_host_data contains subroutine allocate_physics_state(cols, levels, state, has_graupel, has_ice) - integer, intent(in) :: cols - integer, intent(in) :: levels + integer, intent(in) :: cols + integer, intent(in) :: levels type(physics_state), intent(out) :: state - logical, intent(in) :: has_graupel - logical, intent(in) :: has_ice + logical, intent(in) :: has_graupel + logical, intent(in) :: has_ice if (allocated(state%effrr)) then - deallocate(state%effrr) + deallocate(state%effrr) end if allocate(state%effrr(cols, levels)) if (allocated(state%effrl)) then - deallocate(state%effrl) + deallocate(state%effrl) end if allocate(state%effrl(cols, levels)) if (has_ice) then - if (allocated(state%effri)) then - deallocate(state%effri) - end if - allocate(state%effri(cols, levels)) - endif + if (allocated(state%effri)) then + deallocate(state%effri) + end if + allocate(state%effri(cols, levels)) + end if if (has_graupel) then - if (allocated(state%effrg)) then - deallocate(state%effrg) - end if - allocate(state%effrg(cols, levels)) - - if (allocated(state%ncg)) then - deallocate(state%ncg) - end if - allocate(state%ncg(cols, levels)) - endif + if (allocated(state%effrg)) then + deallocate(state%effrg) + end if + allocate(state%effrg(cols, levels)) + + if (allocated(state%ncg)) then + deallocate(state%ncg) + end if + allocate(state%ncg(cols, levels)) + end if if (has_ice) then - if (allocated(state%nci)) then - deallocate(state%nci) - end if - allocate(state%nci(cols, levels)) - endif - - if (allocated(state%fluxLW)) then - deallocate(state%fluxLW) + if (allocated(state%nci)) then + deallocate(state%nci) + end if + allocate(state%nci(cols, levels)) + end if + + if (allocated(state%fluxlw)) then + deallocate(state%fluxlw) end if - allocate(state%fluxLW(cols)) + allocate(state%fluxlw(cols)) - if (associated(state%fluxSW%sfc_up_sw)) then - nullify(state%fluxSW%sfc_up_sw) + if (associated(state%fluxsw%sfc_up_sw)) then + nullify(state%fluxsw%sfc_up_sw) end if - allocate(state%fluxSW%sfc_up_sw(cols)) + allocate(state%fluxsw%sfc_up_sw(cols)) - if (associated(state%fluxSW%sfc_down_sw)) then - nullify(state%fluxSW%sfc_down_sw) + if (associated(state%fluxsw%sfc_down_sw)) then + nullify(state%fluxsw%sfc_down_sw) end if - allocate(state%fluxSW%sfc_down_sw(cols)) + allocate(state%fluxsw%sfc_down_sw(cols)) ! Initialize scheme counter. state%scheme_order = 1 diff --git a/test/var_compatibility_test/test_host_mod.F90 b/test/var_compatibility_test/test_host_mod.F90 index 09d1fdb5..d3bde866 100644 --- a/test/var_compatibility_test/test_host_mod.F90 +++ b/test/var_compatibility_test/test_host_mod.F90 @@ -1,23 +1,24 @@ 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 = 12 - integer, parameter :: pver = 4 - type(physics_state) :: phys_state - real(kind_phys) :: effrs(ncols, pver) - logical, parameter :: has_ice = .true. - logical, parameter :: has_graupel = .true. - - public :: init_data - public :: compare_data + 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 = 12 + integer, parameter :: pver = 4 + type(physics_state) :: phys_state + real(kind=kind_phys) :: effrs(ncols, pver) + logical, parameter :: has_ice = .true. + logical, parameter :: has_graupel = .true. + + public :: init_data + public :: compare_data contains @@ -27,19 +28,19 @@ subroutine init_data() call allocate_physics_state(ncols, pver, phys_state, has_graupel, has_ice) phys_state%effrr = 1.0E-3 ! 1000 microns, in meter phys_state%effrl = 1.0E-4 ! 100 microns, in meter - phys_state%scalar_var = 1.0 ! in m - phys_state%scalar_varA = 273.15 ! in K - phys_state%scalar_varB = 1013.0 ! in mb - phys_state%scalar_varC = 380 ! in ppmv - effrs = 5.0E-4 ! 500 microns, in meter + phys_state%scalar_var = 1.0 ! in m + phys_state%scalar_vara = 273.15 ! in K + phys_state%scalar_varb = 1013.0 ! in mb + phys_state%scalar_varc = 380 ! in ppmv + effrs = 5.0E-4 ! 500 microns, in meter if (has_graupel) then - phys_state%effrg = 2.5E-4 ! 250 microns, in meter - phys_state%ncg = 40 - endif + phys_state%effrg = 2.5E-4 ! 250 microns, in meter + phys_state%ncg = 40 + end if if (has_ice) then - phys_state%effri = 5.0E-5 ! 50 microns, in meter - phys_state%nci = 80 - endif + phys_state%effri = 5.0E-5 ! 50 microns, in meter + phys_state%nci = 80 + end if phys_state%tke = 10.0 !J kg-1 phys_state%tke2 = 42.0 !J kg-1 @@ -47,80 +48,85 @@ end subroutine init_data logical function compare_data() - real(kind_phys), parameter :: effrr_expected = 1.0E-3 ! 1000 microns, in meter - real(kind_phys), parameter :: effrl_expected = 5.0E-5 ! 50 microns, in meter - real(kind_phys), parameter :: effri_expected = 7.5E-5 ! 75 microns, in meter - real(kind_phys), parameter :: effrs_expected = 5.3E-4 ! 530 microns, in meter - real(kind_phys), parameter :: scalar_expected = 2.0E3 ! 2 km, in meter - real(kind_phys), parameter :: tke_expected = 10.0 ! 10 J kg-1 - real(kind_phys), parameter :: tolerance = 1.0E-6 ! used as scaling factor for expected value - real(kind_phys), parameter :: sfc_up_sw_expected = 100. ! W/m2 - real(kind_phys), parameter :: sfc_down_sw_expected = 400. ! W/m2 - real(kind_phys), parameter :: sfc_up_lw_expected = 300. ! W/m2 - real(kind_phys), parameter :: sfc_down_lw_expected = 50. ! W/m2 + real(kind=kind_phys), parameter :: effrr_expected = 1.0E-3 ! 1000 microns, in meter + real(kind=kind_phys), parameter :: effrl_expected = 5.0E-5 ! 50 microns, in meter + real(kind=kind_phys), parameter :: effri_expected = 7.5E-5 ! 75 microns, in meter + real(kind=kind_phys), parameter :: effrs_expected = 5.3E-4 ! 530 microns, in meter + real(kind=kind_phys), parameter :: scalar_expected = 2.0E3 ! 2 km, in meter + real(kind=kind_phys), parameter :: tke_expected = 10.0 ! 10 J kg-1 + real(kind=kind_phys), parameter :: tolerance = 1.0E-6 ! used as scaling factor for expected value + real(kind=kind_phys), parameter :: sfc_up_sw_expected = 100. ! W/m2 + real(kind=kind_phys), parameter :: sfc_down_sw_expected = 400. ! W/m2 + real(kind=kind_phys), parameter :: sfc_up_lw_expected = 300. ! W/m2 + real(kind=kind_phys), parameter :: sfc_down_lw_expected = 50. ! W/m2 compare_data = .true. - if (maxval(abs(phys_state%effrr - effrr_expected)) > tolerance*effrr_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrr from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effrr - effrr_expected)), ' > ', tolerance*effrr_expected - compare_data = .false. + if (maxval(abs(phys_state%effrr - effrr_expected)) > tolerance * effrr_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrr from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effrr - effrr_expected)), ' > ', tolerance * effrr_expected + compare_data = .false. + end if + + if (maxval(abs(phys_state%effrl - effrl_expected)) > tolerance * effrl_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrl from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effrl - effrl_expected)), ' > ', tolerance * effrl_expected + compare_data = .false. + end if + + if (maxval(abs(phys_state%effri - effri_expected)) > tolerance * effri_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effri from expected value exceeds tolerance: ', & + maxval(abs(phys_state%effri - effri_expected)), ' > ', tolerance * effri_expected + compare_data = .false. + end if + + if (maxval(abs(effrs - effrs_expected)) > tolerance * effrs_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of effrs from expected value exceeds tolerance: ', & + maxval(abs(effrs - effrs_expected)), ' > ', tolerance * effrs_expected + compare_data = .false. + end if + + if (abs(phys_state%scalar_var - scalar_expected) > tolerance * scalar_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of scalar_var from expected value exceeds tolerance: ', & + abs(phys_state%scalar_var - scalar_expected), ' > ', tolerance * scalar_expected + compare_data = .false. end if - if (maxval(abs(phys_state%effrl - effrl_expected)) > tolerance*effrl_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effrl from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effrl - effrl_expected)), ' > ', tolerance*effrl_expected - compare_data = .false. + if (abs(phys_state%tke - tke_expected) > tolerance * tke_expected) then + write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of tke from expected value exceeds tolerance: ', & + abs(phys_state%tke - tke_expected), ' > ', tolerance * tke_expected + compare_data = .false. end if - if (maxval(abs(phys_state%effri - effri_expected)) > tolerance*effri_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of phys_state%effri from expected value exceeds tolerance: ', & - maxval(abs(phys_state%effri - effri_expected)), ' > ', tolerance*effri_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxsw%sfc_up_sw - sfc_up_sw_expected)) > tolerance * sfc_up_sw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_up_sw from expected value exceeds tolerance: ', & + abs(phys_state%fluxsw%sfc_up_sw - sfc_up_sw_expected), ' > ', tolerance * sfc_up_sw_expected + compare_data = .false. end if - if (maxval(abs( effrs - effrs_expected)) > tolerance*effrs_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of effrs from expected value exceeds tolerance: ', & - maxval(abs( effrs - effrs_expected)), ' > ', tolerance*effrs_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxsw%sfc_down_sw - sfc_down_sw_expected)) > tolerance * sfc_down_sw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_down_sw from expected value exceeds tolerance: ', & + abs(phys_state%fluxsw%sfc_down_sw - sfc_down_sw_expected), ' > ', tolerance * sfc_down_sw_expected + compare_data = .false. end if - if (abs( phys_state%scalar_var - scalar_expected) > tolerance*scalar_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of scalar_var from expected value exceeds tolerance: ', & - abs( phys_state%scalar_var - scalar_expected), ' > ', tolerance*scalar_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxlw%sfc_up_lw - sfc_up_lw_expected)) > tolerance * sfc_up_lw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_up_lw from expected value exceeds tolerance: ', & + abs(phys_state%fluxlw%sfc_up_lw - sfc_up_lw_expected), ' > ', tolerance * sfc_up_lw_expected + compare_data = .false. end if - if (abs( phys_state%tke - tke_expected) > tolerance*tke_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of tke from expected value exceeds tolerance: ', & - abs( phys_state%tke - tke_expected), ' > ', tolerance*tke_expected - compare_data = .false. + if (maxval(abs(phys_state%fluxlw%sfc_down_lw - sfc_down_lw_expected)) > tolerance * sfc_down_lw_expected) then + write(6, '(a,e16.7,a,e16.7)') & + 'Error: max diff of sfc_down_lw from expected value exceeds tolerance: ', & + abs(phys_state%fluxlw%sfc_down_lw - sfc_down_lw_expected), ' > ', tolerance * sfc_down_lw_expected + compare_data = .false. end if - if (maxval(abs( phys_state%fluxSW%sfc_up_sw - sfc_up_sw_expected)) > tolerance*sfc_up_sw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_up_sw from expected value exceeds tolerance: ', & - abs( phys_state%fluxSW%sfc_up_sw - sfc_up_sw_expected), ' > ', tolerance*sfc_up_sw_expected - compare_data = .false. - end if - - if (maxval(abs( phys_state%fluxSW%sfc_down_sw - sfc_down_sw_expected)) > tolerance*sfc_down_sw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_down_sw from expected value exceeds tolerance: ', & - abs( phys_state%fluxSW%sfc_down_sw - sfc_down_sw_expected), ' > ', tolerance*sfc_down_sw_expected - compare_data = .false. - end if - - if (maxval(abs( phys_state%fluxLW%sfc_up_lw - sfc_up_lw_expected)) > tolerance*sfc_up_lw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_up_lw from expected value exceeds tolerance: ', & - abs( phys_state%fluxLW%sfc_up_lw - sfc_up_lw_expected), ' > ', tolerance*sfc_up_lw_expected - compare_data = .false. - end if - - if (maxval(abs( phys_state%fluxLW%sfc_down_lw - sfc_down_lw_expected)) > tolerance*sfc_down_lw_expected) then - write(6, '(a,e16.7,a,e16.7)') 'Error: max diff of sfc_down_lw from expected value exceeds tolerance: ', & - abs( phys_state%fluxLW%sfc_down_lw - sfc_down_lw_expected), ' > ', tolerance*sfc_down_lw_expected - compare_data = .false. - end if - end function compare_data end module test_host_mod diff --git a/test/var_compatibility_test/test_var_compatibility_integration.F90 b/test/var_compatibility_test/test_var_compatibility_integration.F90 index 1e081e10..4115face 100644 --- a/test/var_compatibility_test/test_var_compatibility_integration.F90 +++ b/test/var_compatibility_test/test_var_compatibility_integration.F90 @@ -1,85 +1,88 @@ program test_var_compatibility_integration - 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(1) = (/ 'radiation ' /) + character(len=cs), target :: test_parts1(1) = (/ 'radiation ' /) - character(len=cm), target :: test_invars1(18) = (/ & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'effective_radius_of_stratiform_cloud_graupel ', & - 'cloud_graupel_number_concentration ', & - 'scalar_variable_for_testing ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'scalar_variable_for_testing_a ', & - 'scalar_variable_for_testing_b ', & - 'scalar_variable_for_testing_c ', & - 'scheme_order_in_suite ', & - 'num_subcycles_for_effr ', & - 'flag_indicating_cloud_microphysics_has_graupel ', & - 'flag_indicating_cloud_microphysics_has_ice ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_invars1(18) = (/ & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'effective_radius_of_stratiform_cloud_graupel ', & + 'cloud_graupel_number_concentration ', & + 'scalar_variable_for_testing ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'scalar_variable_for_testing_a ', & + 'scalar_variable_for_testing_b ', & + 'scalar_variable_for_testing_c ', & + 'scheme_order_in_suite ', & + 'num_subcycles_for_effr ', & + 'flag_indicating_cloud_microphysics_has_graupel ', & + 'flag_indicating_cloud_microphysics_has_ice ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'longwave_radiation_fluxes '/) - character(len=cm), target :: test_outvars1(14) = (/ & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'effective_radius_of_stratiform_cloud_ice_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'cloud_ice_number_concentration ', & - 'scalar_variable_for_testing ', & - 'scheme_order_in_suite ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_outvars1(14) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'effective_radius_of_stratiform_cloud_ice_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'cloud_ice_number_concentration ', & + 'scalar_variable_for_testing ', & + 'scheme_order_in_suite ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'longwave_radiation_fluxes '/) - character(len=cm), target :: test_reqvars1(22) = (/ & - 'ccpp_error_code ', & - 'ccpp_error_message ', & - 'effective_radius_of_stratiform_cloud_rain_particle ', & - 'effective_radius_of_stratiform_cloud_ice_particle ', & - 'effective_radius_of_stratiform_cloud_liquid_water_particle', & - 'effective_radius_of_stratiform_cloud_snow_particle ', & - 'effective_radius_of_stratiform_cloud_graupel ', & - 'cloud_graupel_number_concentration ', & - 'cloud_ice_number_concentration ', & - 'scalar_variable_for_testing ', & - 'turbulent_kinetic_energy ', & - 'turbulent_kinetic_energy2 ', & - 'scalar_variable_for_testing_a ', & - 'scalar_variable_for_testing_b ', & - 'scalar_variable_for_testing_c ', & - 'scheme_order_in_suite ', & - 'num_subcycles_for_effr ', & - 'flag_indicating_cloud_microphysics_has_graupel ', & - 'flag_indicating_cloud_microphysics_has_ice ', & - 'surface_downwelling_shortwave_radiation_flux ', & - 'surface_upwelling_shortwave_radiation_flux ', & - 'longwave_radiation_fluxes '/) + character(len=cm), target :: test_reqvars1(22) = (/ & + 'ccpp_error_code ', & + 'ccpp_error_message ', & + 'effective_radius_of_stratiform_cloud_rain_particle ', & + 'effective_radius_of_stratiform_cloud_ice_particle ', & + 'effective_radius_of_stratiform_cloud_liquid_water_particle', & + 'effective_radius_of_stratiform_cloud_snow_particle ', & + 'effective_radius_of_stratiform_cloud_graupel ', & + 'cloud_graupel_number_concentration ', & + 'cloud_ice_number_concentration ', & + 'scalar_variable_for_testing ', & + 'turbulent_kinetic_energy ', & + 'turbulent_kinetic_energy2 ', & + 'scalar_variable_for_testing_a ', & + 'scalar_variable_for_testing_b ', & + 'scalar_variable_for_testing_c ', & + 'scheme_order_in_suite ', & + 'num_subcycles_for_effr ', & + 'flag_indicating_cloud_microphysics_has_graupel ', & + 'flag_indicating_cloud_microphysics_has_ice ', & + 'surface_downwelling_shortwave_radiation_flux ', & + 'surface_upwelling_shortwave_radiation_flux ', & + 'longwave_radiation_fluxes '/) - type(suite_info) :: test_suites(1) - logical :: run_okay + type(suite_info) :: test_suites(1) + logical :: run_okay - ! Setup expected test suite info - test_suites(1)%suite_name = 'var_compatibility_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 + ! Setup expected test suite info + test_suites(1)%suite_name = 'var_compatibility_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 - 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_var_compatibility_integration diff --git a/test_prebuild/test_blocked_data/blocked_data_scheme.F90 b/test_prebuild/test_blocked_data/blocked_data_scheme.F90 index eeda2206..77e1e687 100644 --- a/test_prebuild/test_blocked_data/blocked_data_scheme.F90 +++ b/test_prebuild/test_blocked_data/blocked_data_scheme.F90 @@ -4,115 +4,123 @@ module blocked_data_scheme - use, intrinsic :: iso_fortran_env, only: error_unit - implicit none + use, intrinsic :: iso_fortran_env, only: error_unit + implicit none - private - public :: blocked_data_scheme_init, & - blocked_data_scheme_timestep_init, & - blocked_data_scheme_run, & - blocked_data_scheme_timestep_finalize, & - blocked_data_scheme_finalize + private + public :: blocked_data_scheme_init, & + blocked_data_scheme_timestep_init, & + blocked_data_scheme_run, & + blocked_data_scheme_timestep_finalize, & + blocked_data_scheme_finalize - ! This is for unit testing only - integer, parameter, dimension(4) :: data_array_sizes = (/6,6,6,3/) + ! This is for unit testing only + integer, parameter, dimension(4) :: data_array_sizes = (/6, 6, 6, 3/) - contains +contains -!! \section arg_table_blocked_data_scheme_init Argument Table -!! \htmlinclude blocked_data_scheme_init.html -!! - subroutine blocked_data_scheme_init(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In blocked_data_scheme_init: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_init + !! \section arg_table_blocked_data_scheme_init Argument Table + !! \htmlinclude blocked_data_scheme_init.html + !! + subroutine blocked_data_scheme_init(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In blocked_data_scheme_init: checking size of data array to be', sum(data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_init -!! \section arg_table_blocked_data_scheme_timestep_init Argument Table -!! \htmlinclude blocked_data_scheme_timestep_init.html -!! - subroutine blocked_data_scheme_timestep_init(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In blocked_data_scheme_timestep_init: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), " but got ", size(data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_timestep_init + !! \section arg_table_blocked_data_scheme_timestep_init Argument Table + !! \htmlinclude blocked_data_scheme_timestep_init.html + !! + subroutine blocked_data_scheme_timestep_init(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In blocked_data_scheme_timestep_init: checking size of data array to be', sum(& + data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), " but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_timestep_init -!! \section arg_table_blocked_data_scheme_run Argument Table -!! \htmlinclude blocked_data_scheme_run.html -!! - subroutine blocked_data_scheme_run(nb, data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nb - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(2(a,i3))') 'In blocked_data_scheme_run: checking size of data array for block', nb, ' to be', data_array_sizes(nb) - if (size(data_array)/=data_array_sizes(nb)) then - write(errmsg,'(a,i4)') "Error in blocked_data_scheme_run, expected size(data_array)==6, got ", size(data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_run + !! \section arg_table_blocked_data_scheme_run Argument Table + !! \htmlinclude blocked_data_scheme_run.html + !! + subroutine blocked_data_scheme_run(nb, data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nb + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(2(a,i3))') 'In blocked_data_scheme_run: checking size of data array for block', nb, & + ' to be', data_array_sizes(nb) + if (size(data_array)/=data_array_sizes(nb)) then + write(errmsg, '(a,i4)') "Error in blocked_data_scheme_run, expected size(data_array)==6, got ", size(data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_run - !! \section arg_table_blocked_data_scheme_timestep_finalize Argument Table - !! \htmlinclude blocked_data_scheme_timestep_finalize.html - !! - subroutine blocked_data_scheme_timestep_finalize(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In blocked_data_scheme_timestep_finalize: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_timestep_finalize + !! \section arg_table_blocked_data_scheme_timestep_finalize Argument Table + !! \htmlinclude blocked_data_scheme_timestep_finalize.html + !! + subroutine blocked_data_scheme_timestep_finalize(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In blocked_data_scheme_timestep_finalize: checking size of data array to be', sum(& + data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_timestep_finalize -!! \section arg_table_blocked_data_scheme_finalize Argument Table -!! \htmlinclude blocked_data_scheme_finalize.html -!! - subroutine blocked_data_scheme_finalize(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In blocked_data_scheme_finalize: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) - errflg = 1 - return - end if - end subroutine blocked_data_scheme_finalize + !! \section arg_table_blocked_data_scheme_finalize Argument Table + !! \htmlinclude blocked_data_scheme_finalize.html + !! + subroutine blocked_data_scheme_finalize(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In blocked_data_scheme_finalize: checking size of data array to be', sum(& + data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine blocked_data_scheme_finalize end module blocked_data_scheme diff --git a/test_prebuild/test_blocked_data/data.F90 b/test_prebuild/test_blocked_data/data.F90 index 97ad051e..0d399f27 100644 --- a/test_prebuild/test_blocked_data/data.F90 +++ b/test_prebuild/test_blocked_data/data.F90 @@ -1,41 +1,41 @@ module data -!! \section arg_table_data Argument Table -!! \htmlinclude data.html -!! - use ccpp_types, only: ccpp_t + !! \section arg_table_data Argument Table + !! \htmlinclude data.html + !! + use ccpp_types, only: ccpp_t - implicit none + implicit none - private + private - public nblks, blksz, ncols - public ccpp_data_domain, ccpp_data_blocks, blocked_data_type, blocked_data_instance + public nblks, blksz, ncols + public ccpp_data_domain, ccpp_data_blocks, blocked_data_type, blocked_data_instance - integer, parameter :: nblks = 4 - type(ccpp_t), target :: ccpp_data_domain - type(ccpp_t), dimension(nblks), target :: ccpp_data_blocks + integer, parameter :: nblks = 4 + type(ccpp_t), target :: ccpp_data_domain + type(ccpp_t), dimension(nblks), target :: ccpp_data_blocks - integer, parameter, dimension(nblks) :: blksz = (/6,6,6,3/) - integer, parameter :: ncols = sum(blksz) + integer, parameter, dimension(nblks) :: blksz = (/6, 6, 6, 3/) + integer, parameter :: ncols = sum(blksz) -!! \section arg_table_blocked_data_type -!! \htmlinclude blocked_data_type.html -!! - type blocked_data_type - integer, dimension(:), allocatable :: array_data - contains - procedure :: create => blocked_data_create - end type blocked_data_type + !! \section arg_table_blocked_data_type + !! \htmlinclude blocked_data_type.html + !! + type blocked_data_type + integer, dimension(:), allocatable :: array_data + contains + procedure :: create => blocked_data_create + end type blocked_data_type - type(blocked_data_type), dimension(nblks) :: blocked_data_instance + type(blocked_data_type), dimension(nblks) :: blocked_data_instance contains - subroutine blocked_data_create(blocked_data_instance, ncol) - class(blocked_data_type), intent(inout) :: blocked_data_instance - integer, intent(in) :: ncol - allocate(blocked_data_instance%array_data(ncol)) - end subroutine blocked_data_create + subroutine blocked_data_create(blocked_data_instance, ncol) + class(blocked_data_type), intent(inout) :: blocked_data_instance + integer, intent(in) :: ncol + allocate(blocked_data_instance%array_data(ncol)) + end subroutine blocked_data_create end module data diff --git a/test_prebuild/test_blocked_data/main.F90 b/test_prebuild/test_blocked_data/main.F90 index 4711b3c9..a6d86a35 100644 --- a/test_prebuild/test_blocked_data/main.F90 +++ b/test_prebuild/test_blocked_data/main.F90 @@ -1,112 +1,117 @@ program test_blocked_data - use, intrinsic :: iso_fortran_env, only: error_unit - - use ccpp_types, only: ccpp_t - use data, only: nblks, blksz, ncols - use data, only: ccpp_data_domain, ccpp_data_blocks, & - blocked_data_type, blocked_data_instance - - use ccpp_static_api, only: ccpp_physics_init, & - ccpp_physics_timestep_init, & - ccpp_physics_run, & - ccpp_physics_timestep_finalize, & - ccpp_physics_finalize - - implicit none - - character(len=*), parameter :: ccpp_suite = 'blocked_data_suite' - integer :: ib, ierr - type(ccpp_t), pointer :: cdata => null() - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! For physics running over the entire domain, - ! ccpp_thread_number and ccpp_chunk_number are - ! set to 1, indicating that arrays are to be sent - ! following their dimension specification in the - ! metadata (must match horizontal_dimension). - ccpp_data_domain%blk_no = 1 - ccpp_data_domain%thrd_no = 1 - ccpp_data_domain%thrd_cnt = 1 - - ! Loop over all blocks and threads for ccpp_data_blocks - do ib=1,nblks - ! Assign the correct block numbers, only one thread - ccpp_data_blocks(ib)%blk_no = ib - ccpp_data_blocks(ib)%thrd_no = 1 - ccpp_data_blocks(ib)%thrd_cnt = 1 - end do - - do ib=1,size(blocked_data_instance) - allocate(blocked_data_instance(ib)%array_data(blksz(ib))) - write(error_unit,'(2(a,i3))') "Allocated array_data for block", ib, " to size", size(blocked_data_instance(ib)%array_data) - end do - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_init:" - write(error_unit,'(a)') trim(cdata%errmsg) + use, intrinsic :: iso_fortran_env, only: error_unit + + use ccpp_types, only: ccpp_t + use data, only: nblks, & + blksz, & + ncols + use data, only: ccpp_data_domain, & + ccpp_data_blocks, & + blocked_data_type, & + blocked_data_instance + + use ccpp_static_api, only: ccpp_physics_init, & + ccpp_physics_timestep_init, & + ccpp_physics_run, & + ccpp_physics_timestep_finalize, & + ccpp_physics_finalize + + implicit none + + character(len=*), parameter :: ccpp_suite = 'blocked_data_suite' + integer :: ib, ierr + type(ccpp_t), pointer :: cdata => null() + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! For physics running over the entire domain, + ! ccpp_thread_number and ccpp_chunk_number are + ! set to 1, indicating that arrays are to be sent + ! following their dimension specification in the + ! metadata (must match horizontal_dimension). + ccpp_data_domain%blk_no = 1 + ccpp_data_domain%thrd_no = 1 + ccpp_data_domain%thrd_cnt = 1 + + ! Loop over all blocks and threads for ccpp_data_blocks + do ib = 1, nblks + ! Assign the correct block numbers, only one thread + ccpp_data_blocks(ib)%blk_no = ib + ccpp_data_blocks(ib)%thrd_no = 1 + ccpp_data_blocks(ib)%thrd_cnt = 1 + end do + + do ib = 1, size(blocked_data_instance) + allocate(blocked_data_instance(ib)%array_data(blksz(ib))) + write(error_unit, '(2(a,i3))') "Allocated array_data for block", ib, " to size", size(blocked_data_instance(ib)%& + array_data) + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics run step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do ib = 1, nblks + cdata => ccpp_data_blocks(ib) + call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a,i3,a)') "An error occurred in ccpp_physics_run for block", ib, ":" + write(error_unit, '(a)') trim(cdata%errmsg) stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics run step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - do ib=1,nblks - cdata => ccpp_data_blocks(ib) - call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a,i3,a)') "An error occurred in ccpp_physics_run for block", ib, ":" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - end do - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_finalize:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_finalize:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if + end if + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_finalize:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_finalize:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if contains -end program test_blocked_data \ No newline at end of file +end program test_blocked_data diff --git a/test_prebuild/test_chunked_data/chunked_data_scheme.F90 b/test_prebuild/test_chunked_data/chunked_data_scheme.F90 index 1bb2a266..392167b2 100644 --- a/test_prebuild/test_chunked_data/chunked_data_scheme.F90 +++ b/test_prebuild/test_chunked_data/chunked_data_scheme.F90 @@ -4,115 +4,123 @@ module chunked_data_scheme - use, intrinsic :: iso_fortran_env, only: error_unit - implicit none + use, intrinsic :: iso_fortran_env, only: error_unit + implicit none - private - public :: chunked_data_scheme_init, & - chunked_data_scheme_timestep_init, & - chunked_data_scheme_run, & - chunked_data_scheme_timestep_finalize, & - chunked_data_scheme_finalize + private + public :: chunked_data_scheme_init, & + chunked_data_scheme_timestep_init, & + chunked_data_scheme_run, & + chunked_data_scheme_timestep_finalize, & + chunked_data_scheme_finalize - ! This is for unit testing only - integer, parameter, dimension(4) :: data_array_sizes = (/6,6,6,3/) + ! This is for unit testing only + integer, parameter, dimension(4) :: data_array_sizes = (/6, 6, 6, 3/) - contains +contains -!! \section arg_table_chunked_data_scheme_init Argument Table -!! \htmlinclude chunked_data_scheme_init.html -!! - subroutine chunked_data_scheme_init(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In chunked_data_scheme_init: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_init + !! \section arg_table_chunked_data_scheme_init Argument Table + !! \htmlinclude chunked_data_scheme_init.html + !! + subroutine chunked_data_scheme_init(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In chunked_data_scheme_init: checking size of data array to be', sum(data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_init -!! \section arg_table_chunked_data_scheme_timestep_init Argument Table -!! \htmlinclude chunked_data_scheme_timestep_init.html -!! - subroutine chunked_data_scheme_timestep_init(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In chunked_data_scheme_timestep_init: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), " but got ", size(data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_timestep_init + !! \section arg_table_chunked_data_scheme_timestep_init Argument Table + !! \htmlinclude chunked_data_scheme_timestep_init.html + !! + subroutine chunked_data_scheme_timestep_init(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In chunked_data_scheme_timestep_init: checking size of data array to be', sum(& + data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), " but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_timestep_init -!! \section arg_table_chunked_data_scheme_run Argument Table -!! \htmlinclude chunked_data_scheme_run.html -!! - subroutine chunked_data_scheme_run(nchunk, data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nchunk - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(2(a,i3))') 'In chunked_data_scheme_run: checking size of data array for chunk', nchunk, ' to be', data_array_sizes(nchunk) - if (size(data_array)/=data_array_sizes(nchunk)) then - write(errmsg,'(a,i4)') "Error in chunked_data_scheme_run, expected size(data_array)==6, got ", size(data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_run + !! \section arg_table_chunked_data_scheme_run Argument Table + !! \htmlinclude chunked_data_scheme_run.html + !! + subroutine chunked_data_scheme_run(nchunk, data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nchunk + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(2(a,i3))') 'In chunked_data_scheme_run: checking size of data array for chunk', nchunk, & + ' to be', data_array_sizes(nchunk) + if (size(data_array)/=data_array_sizes(nchunk)) then + write(errmsg, '(a,i4)') "Error in chunked_data_scheme_run, expected size(data_array)==6, got ", size(data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_run - !! \section arg_table_chunked_data_scheme_timestep_finalize Argument Table - !! \htmlinclude chunked_data_scheme_timestep_finalize.html - !! - subroutine chunked_data_scheme_timestep_finalize(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In chunked_data_scheme_timestep_finalize: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_timestep_finalize + !! \section arg_table_chunked_data_scheme_timestep_finalize Argument Table + !! \htmlinclude chunked_data_scheme_timestep_finalize.html + !! + subroutine chunked_data_scheme_timestep_finalize(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In chunked_data_scheme_timestep_finalize: checking size of data array to be', sum(& + data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_timestep_finalize -!! \section arg_table_chunked_data_scheme_finalize Argument Table -!! \htmlinclude chunked_data_scheme_finalize.html -!! - subroutine chunked_data_scheme_finalize(data_array, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: data_array(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check size of data array - write(error_unit,'(a,i3)') 'In chunked_data_scheme_finalize: checking size of data array to be', sum(data_array_sizes) - if (size(data_array)/=sum(data_array_sizes)) then - write(errmsg,'(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(data_array) - errflg = 1 - return - end if - end subroutine chunked_data_scheme_finalize + !! \section arg_table_chunked_data_scheme_finalize Argument Table + !! \htmlinclude chunked_data_scheme_finalize.html + !! + subroutine chunked_data_scheme_finalize(data_array, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: data_array(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check size of data array + write(error_unit, '(a,i3)') 'In chunked_data_scheme_finalize: checking size of data array to be', sum(& + data_array_sizes) + if (size(data_array)/=sum(data_array_sizes)) then + write(errmsg, '(2(a,i3))') "Error, expected size(data_array)==", sum(data_array_sizes), "but got ", size(& + data_array) + errflg = 1 + return + end if + end subroutine chunked_data_scheme_finalize end module chunked_data_scheme diff --git a/test_prebuild/test_chunked_data/data.F90 b/test_prebuild/test_chunked_data/data.F90 index 8fbf21ed..82c4abac 100644 --- a/test_prebuild/test_chunked_data/data.F90 +++ b/test_prebuild/test_chunked_data/data.F90 @@ -1,43 +1,43 @@ module data -!! \section arg_table_dATa Argument Table -!! \htmlinclude datA.Html -!! - use ccpp_types, only: ccpp_t + !! \section arg_table_dATa Argument Table + !! \htmlinclude datA.Html + !! + use ccpp_types, only: ccpp_t - implicit none + implicit none - private + private - public nchunks, chunksize, chunk_begin, chunk_end, ncols - public ccpp_data_domain, ccpp_data_chunks, chunked_data_type, chunked_data_instance + public nchunks, chunksize, chunk_begin, chunk_end, ncols + public ccpp_data_domain, ccpp_data_chunks, chunked_data_type, chunked_data_instance - integer, parameter :: nchunks = 4 - type(ccpp_t), target :: ccpp_data_domain - type(ccpp_t), dimension(nchunks), target :: ccpp_data_chunks + integer, parameter :: nchunks = 4 + type(ccpp_t), target :: ccpp_data_domain + type(ccpp_t), dimension(nchunks), target :: ccpp_data_chunks - integer, parameter, dimension(nchunks) :: chunksize = (/6,6,6,3/) - integer, parameter, dimension(nchunks) :: chunk_begin = (/1,7,13,19/) - integer, parameter, dimension(nchunks) :: chunk_end = (/6,12,18,21/) - integer, parameter :: ncols = sum(chunksize) + integer, parameter, dimension(nchunks) :: chunksize = (/6, 6, 6, 3/) + integer, parameter, dimension(nchunks) :: chunk_begin = (/1, 7, 13, 19/) + integer, parameter, dimension(nchunks) :: chunk_end = (/6, 12, 18, 21/) + integer, parameter :: ncols = sum(chunksize) -!! \section arg_table_cHuNkEd_dATa_TYPe -!! \htmlinclude CHuNKed_Data_tYpe.hTMl -!! - type chunked_data_type - integer, dimension(:), allocatable :: array_data - contains - procedure :: create => chunked_data_create - end type chunked_data_type + !! \section arg_table_cHuNkEd_dATa_TYPe + !! \htmlinclude CHuNKed_Data_tYpe.hTMl + !! + type chunked_data_type + integer, dimension(:), allocatable :: array_data + contains + procedure :: create => chunked_data_create + end type chunked_data_type - type(chunked_data_type) :: chunked_data_instance + type(chunked_data_type) :: chunked_data_instance contains - subroutine chunked_data_create(chunked_data_instance, ncol) - class(chunked_data_type), intent(inout) :: chunked_data_instance - integer, intent(in) :: ncol - allocate(chunked_data_instance%array_data(ncol)) - end subroutine chunked_data_create + subroutine chunked_data_create(chunked_data_instance, ncol) + class(chunked_data_type), intent(inout) :: chunked_data_instance + integer, intent(in) :: ncol + allocate(chunked_data_instance%array_data(ncol)) + end subroutine chunked_data_create end module data diff --git a/test_prebuild/test_chunked_data/main.F90 b/test_prebuild/test_chunked_data/main.F90 index a1af449b..739ebf8b 100644 --- a/test_prebuild/test_chunked_data/main.F90 +++ b/test_prebuild/test_chunked_data/main.F90 @@ -1,110 +1,114 @@ program test_chunked_data - use, intrinsic :: iso_fortran_env, only: error_unit - - use ccpp_types, only: ccpp_t - use data, only: nchunks, chunksize, ncols - use data, only: ccpp_data_domain, ccpp_data_chunks, & - chunked_data_type, chunked_data_instance - - use ccpp_static_api, only: ccpp_physics_init, & - ccpp_physics_timestep_init, & - ccpp_physics_run, & - ccpp_physics_timestep_finalize, & - ccpp_physics_finalize - - implicit none - - character(len=*), parameter :: ccpp_suite = 'chunked_data_suite' - integer :: ic, ierr - type(ccpp_t), pointer :: cdata => null() - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! For physics running over the entire domain, - ! ccpp_thread_number and ccpp_chunk_number are - ! set to 1, indicating that arrays are to be sent - ! following their dimension specification in the - ! metadata (must match horizontal_dimension). - ccpp_data_domain%thrd_no = 1 - ccpp_data_domain%chunk_no = 1 - ccpp_data_domain%thrd_cnt = 1 - - ! Loop over all chunks and threads for ccpp_data_chunks - do ic=1,nchunks - ! Assign the correct chunk numbers, only one thread - ccpp_data_chunks(ic)%chunk_no = ic - ccpp_data_chunks(ic)%thrd_no = 1 - ccpp_data_chunks(ic)%thrd_cnt = 1 - end do - - call chunked_data_instance%create(ncols) - write(error_unit,'(2(a,i3))') "Chunked_data_instance%array_data to size", size(chunked_data_instance%array_data) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_init:" - write(error_unit,'(a)') trim(cdata%errmsg) + use, intrinsic :: iso_fortran_env, only: error_unit + + use ccpp_types, only: ccpp_t + use data, only: nchunks, & + chunksize, & + ncols + use data, only: ccpp_data_domain, & + ccpp_data_chunks, & + chunked_data_type, & + chunked_data_instance + + use ccpp_static_api, only: ccpp_physics_init, & + ccpp_physics_timestep_init, & + ccpp_physics_run, & + ccpp_physics_timestep_finalize, & + ccpp_physics_finalize + + implicit none + + character(len=*), parameter :: ccpp_suite = 'chunked_data_suite' + integer :: ic, ierr + type(ccpp_t), pointer :: cdata => null() + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! For physics running over the entire domain, + ! ccpp_thread_number and ccpp_chunk_number are + ! set to 1, indicating that arrays are to be sent + ! following their dimension specification in the + ! metadata (must match horizontal_dimension). + ccpp_data_domain%thrd_no = 1 + ccpp_data_domain%chunk_no = 1 + ccpp_data_domain%thrd_cnt = 1 + + ! Loop over all chunks and threads for ccpp_data_chunks + do ic = 1, nchunks + ! Assign the correct chunk numbers, only one thread + ccpp_data_chunks(ic)%chunk_no = ic + ccpp_data_chunks(ic)%thrd_no = 1 + ccpp_data_chunks(ic)%thrd_cnt = 1 + end do + + call chunked_data_instance%create(ncols) + write(error_unit, '(2(a,i3))') "Chunked_data_instance%array_data to size", size(chunked_data_instance%array_data) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics run step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do ic = 1, nchunks + cdata => ccpp_data_chunks(ic) + call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a,i3,a)') "An error occurred in ccpp_physics_run for chunk", ic, ":" + write(error_unit, '(a)') trim(cdata%errmsg) stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics run step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - do ic=1,nchunks - cdata => ccpp_data_chunks(ic) - call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a,i3,a)') "An error occurred in ccpp_physics_run for chunk", ic, ":" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - end do - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_finalize:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata => ccpp_data_domain - call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_finalize:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if + end if + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_finalize:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata => ccpp_data_domain + call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_finalize:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if contains -end program test_chunked_data \ No newline at end of file +end program test_chunked_data diff --git a/test_prebuild/test_opt_arg/ccpp_kinds.F90 b/test_prebuild/test_opt_arg/ccpp_kinds.F90 index cf6bfeaf..a07ded9b 100644 --- a/test_prebuild/test_opt_arg/ccpp_kinds.F90 +++ b/test_prebuild/test_opt_arg/ccpp_kinds.F90 @@ -1,13 +1,13 @@ module ccpp_kinds -!! \section arg_table_ccpp_kinds -!! \htmlinclude ccpp_kinds.html -!! + !! \section arg_table_ccpp_kinds + !! \htmlinclude ccpp_kinds.html + !! - use iso_fortran_env, only: real64 + use iso_fortran_env, only: real64 - implicit none + implicit none - integer, parameter :: kind_phys = real64 + integer, parameter :: kind_phys = real64 end module ccpp_kinds diff --git a/test_prebuild/test_opt_arg/data.F90 b/test_prebuild/test_opt_arg/data.F90 index e16051fd..f66cf8c1 100644 --- a/test_prebuild/test_opt_arg/data.F90 +++ b/test_prebuild/test_opt_arg/data.F90 @@ -1,23 +1,23 @@ module data -!! \section arg_table_data Argument Table -!! \htmlinclude data.html -!! - use ccpp_types, only: ccpp_t - use ccpp_kinds, only: kind_phys + !! \section arg_table_data Argument Table + !! \htmlinclude data.html + !! + use ccpp_types, only: ccpp_t + use ccpp_kinds, only: kind_phys - implicit none + implicit none - private + private - public cdata, nx, flag_for_opt_arg, std_arg, opt_arg, opt_arg_2 + public cdata, nx, flag_for_opt_arg, std_arg, opt_arg, opt_arg_2 - type(ccpp_t), target :: cdata - integer, parameter :: nx = 3 - logical :: flag_for_opt_arg + type(ccpp_t), target :: cdata + integer, parameter :: nx = 3 + logical :: flag_for_opt_arg - integer, dimension(nx) :: std_arg - integer, dimension(:), allocatable :: opt_arg - real(kind=kind_phys), dimension(:), allocatable :: opt_arg_2 + integer, dimension(nx) :: std_arg + integer, dimension(:), allocatable :: opt_arg + real(kind=kind_phys), dimension(:), allocatable :: opt_arg_2 end module data diff --git a/test_prebuild/test_opt_arg/main.F90 b/test_prebuild/test_opt_arg/main.F90 index 932958bc..8d08619a 100644 --- a/test_prebuild/test_opt_arg/main.F90 +++ b/test_prebuild/test_opt_arg/main.F90 @@ -1,119 +1,125 @@ program test_opt_arg - use, intrinsic :: iso_fortran_env, only: output_unit, error_unit - - use ccpp_types, only: ccpp_t - use data, only: cdata, nx, flag_for_opt_arg, std_arg, opt_arg, opt_arg_2 - - use ccpp_static_api, only: ccpp_physics_init, & - ccpp_physics_timestep_init, & - ccpp_physics_run, & - ccpp_physics_timestep_finalize, & - ccpp_physics_finalize - - implicit none - - character(len=*), parameter :: ccpp_suite = 'opt_arg_suite' - integer :: ierr - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - cdata%blk_no = 1 - cdata%thrd_no = 1 - cdata%thrd_cnt = 1 - - std_arg = 1 - flag_for_opt_arg = .true. - allocate(opt_arg(nx)) - allocate(opt_arg_2(nx)) - - ! std_arg must all be 1, opt_arg must all be 0 - write(output_unit,'(a)') "After ccpp_init: check std_arg(:)==1, opt_arg(:)==0, opt_arg_2(:)==0" - if (.not. all(std_arg .eq. 1)) write(error_unit,'(a,3i3)') "Error after ccpp_init: std_arg=", std_arg - if (.not. all(opt_arg .eq. 0)) write(error_unit,'(a,3i3)') "Error after ccpp_init: opt_arg=", opt_arg - if (.not. all(opt_arg_2 .eq. 0)) write(error_unit,'(a,3i3)') "Error after ccpp_init: opt_arg_2=", opt_arg_2 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 1, opt_arg must all be 0 - write(output_unit,'(a)') "After ccpp_physics_init: check std_arg(:)==1 and opt_arg(:)==0" - if (.not. all(std_arg .eq. 1)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_init: std_arg=", std_arg - if (.not. all(opt_arg .eq. 0)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_init: opt_arg=", opt_arg - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 1, opt_arg must all be 2 - write(output_unit,'(a)') "After ccpp_physics_timestep_init: check std_arg(:)==1 and opt_arg(:)==2" - if (.not. all(std_arg .eq. 1)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_timestep_init: std_arg=", std_arg - if (.not. all(opt_arg .eq. 2)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_timestep_init: opt_arg=", opt_arg - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics run step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_run:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 1, opt_arg must all be 3 - write(output_unit,'(a)') "After ccpp_physics_run: check std_arg(:)==1 and opt_arg(:)==3" - if (.not. all(std_arg .eq. 1)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_run: std_arg=", std_arg - if (.not. all(opt_arg .eq. 3)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_run: opt_arg=", opt_arg - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - deallocate(opt_arg) - flag_for_opt_arg = .false. - - call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 7, opt_arg no longer allocated - write(output_unit,'(a)') "After ccpp_physics_timestep_final: check std_arg(:)==7; opt_arg not allocated" - if (.not. all(std_arg .eq. 7)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_timestep_final: std_arg=", std_arg - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - ! std_arg must all be 7, opt_arg no longer allocated - write(output_unit,'(a)') "After ccpp_physics_timestep_final: check std_arg(:)==7; opt_arg not allocated" - if (.not. all(std_arg .eq. 7)) write(error_unit,'(a,3i3)') "Error after ccpp_physics_timestep_final: std_arg=", std_arg + use, intrinsic :: iso_fortran_env, only: output_unit, & + error_unit + + use ccpp_types, only: ccpp_t + use data, only: cdata, & + nx, & + flag_for_opt_arg, & + std_arg, & + opt_arg, & + opt_arg_2 + + use ccpp_static_api, only: ccpp_physics_init, & + ccpp_physics_timestep_init, & + ccpp_physics_run, & + ccpp_physics_timestep_finalize, & + ccpp_physics_finalize + + implicit none + + character(len=*), parameter :: ccpp_suite = 'opt_arg_suite' + integer :: ierr + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + cdata%blk_no = 1 + cdata%thrd_no = 1 + cdata%thrd_cnt = 1 + + std_arg = 1 + flag_for_opt_arg = .true. + allocate(opt_arg(nx)) + allocate(opt_arg_2(nx)) + + ! std_arg must all be 1, opt_arg must all be 0 + write(output_unit, '(a)') "After ccpp_init: check std_arg(:)==1, opt_arg(:)==0, opt_arg_2(:)==0" + if (.not. all(std_arg == 1)) write(error_unit, '(a,3i3)') "Error after ccpp_init: std_arg=", std_arg + if (.not. all(opt_arg == 0)) write(error_unit, '(a,3i3)') "Error after ccpp_init: opt_arg=", opt_arg + if (.not. all(opt_arg_2 == 0)) write(error_unit, '(a,3i3)') "Error after ccpp_init: opt_arg_2=", opt_arg_2 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 1, opt_arg must all be 0 + write(output_unit, '(a)') "After ccpp_physics_init: check std_arg(:)==1 and opt_arg(:)==0" + if (.not. all(std_arg == 1)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_init: std_arg=", std_arg + if (.not. all(opt_arg == 0)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_init: opt_arg=", opt_arg + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 1, opt_arg must all be 2 + write(output_unit, '(a)') "After ccpp_physics_timestep_init: check std_arg(:)==1 and opt_arg(:)==2" + if (.not. all(std_arg == 1)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_timestep_init: std_arg=", std_arg + if (.not. all(opt_arg == 2)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_timestep_init: opt_arg=", opt_arg + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics run step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_run:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 1, opt_arg must all be 3 + write(output_unit, '(a)') "After ccpp_physics_run: check std_arg(:)==1 and opt_arg(:)==3" + if (.not. all(std_arg == 1)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_run: std_arg=", std_arg + if (.not. all(opt_arg == 3)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_run: opt_arg=", opt_arg + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + deallocate(opt_arg) + flag_for_opt_arg = .false. + + call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 7, opt_arg no longer allocated + write(output_unit, '(a)') "After ccpp_physics_timestep_final: check std_arg(:)==7; opt_arg not allocated" + if (.not. all(std_arg == 7)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_timestep_final: std_arg=", std_arg + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + ! std_arg must all be 7, opt_arg no longer allocated + write(output_unit, '(a)') "After ccpp_physics_timestep_final: check std_arg(:)==7; opt_arg not allocated" + if (.not. all(std_arg == 7)) write(error_unit, '(a,3i3)') "Error after ccpp_physics_timestep_final: std_arg=", std_arg end program test_opt_arg diff --git a/test_prebuild/test_opt_arg/opt_arg_scheme.F90 b/test_prebuild/test_opt_arg/opt_arg_scheme.F90 index 1a36fffd..33be0973 100644 --- a/test_prebuild/test_opt_arg/opt_arg_scheme.F90 +++ b/test_prebuild/test_opt_arg/opt_arg_scheme.F90 @@ -4,87 +4,87 @@ module opt_arg_scheme - use, intrinsic :: iso_fortran_env, only: error_unit - use ccpp_kinds, only: kind_phys + use, intrinsic :: iso_fortran_env, only: error_unit + use ccpp_kinds, only: kind_phys - implicit none + implicit none - private - public :: opt_arg_scheme_timestep_init, & - opt_arg_scheme_run, & - opt_arg_scheme_timestep_finalize + private + public :: opt_arg_scheme_timestep_init, & + opt_arg_scheme_run, & + opt_arg_scheme_timestep_finalize - contains +contains -!! \section arg_table_opt_arg_scheme_timestep_init Argument Table -!! \htmlinclude opt_arg_scheme_timestep_init.html -!! - subroutine opt_arg_scheme_timestep_init(nx, var, opt_var, opt_var_2, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nx - integer, intent(in) :: var(:) - integer, optional, intent(out) :: opt_var(:) - real(kind=kind_phys), optional, intent(out) :: opt_var_2(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Initialize opt_var from var if opt_var if present - if (present(opt_var)) then - opt_var = 2*var - end if - ! Initialize opt_var_2 from var if opt_var_2 present - if (present(opt_var_2)) then - opt_var_2 = 3.0_kind_phys*var - end if - end subroutine opt_arg_scheme_timestep_init + !! \section arg_table_opt_arg_scheme_timestep_init Argument Table + !! \htmlinclude opt_arg_scheme_timestep_init.html + !! + subroutine opt_arg_scheme_timestep_init(nx, var, opt_var, opt_var_2, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nx + integer, intent(in) :: var(:) + integer, optional, intent(out) :: opt_var(:) + real(kind=kind_phys), optional, intent(out) :: opt_var_2(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Initialize opt_var from var if opt_var if present + if (present(opt_var)) then + opt_var = 2 * var + end if + ! Initialize opt_var_2 from var if opt_var_2 present + if (present(opt_var_2)) then + opt_var_2 = 3.0_kind_phys * var + end if + end subroutine opt_arg_scheme_timestep_init -!! \section arg_table_opt_arg_scheme_run Argument Table -!! \htmlinclude opt_arg_scheme_run.html -!! - subroutine opt_arg_scheme_run(nx, var, opt_var, opt_var_2, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nx - integer, intent(in) :: var(:) - integer, optional, intent(inout) :: opt_var(:) - real(kind=kind_phys), optional, intent(inout) :: opt_var_2(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Update opt_var from var if opt_var present - if (present(opt_var)) then - opt_var = 3*var - end if - ! Update opt_var_2 from var if opt_var_2 present - if (present(opt_var_2)) then - opt_var_2 = 4.0_kind_phys*var - end if - end subroutine opt_arg_scheme_run + !! \section arg_table_opt_arg_scheme_run Argument Table + !! \htmlinclude opt_arg_scheme_run.html + !! + subroutine opt_arg_scheme_run(nx, var, opt_var, opt_var_2, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nx + integer, intent(in) :: var(:) + integer, optional, intent(inout) :: opt_var(:) + real(kind=kind_phys), optional, intent(inout) :: opt_var_2(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Update opt_var from var if opt_var present + if (present(opt_var)) then + opt_var = 3 * var + end if + ! Update opt_var_2 from var if opt_var_2 present + if (present(opt_var_2)) then + opt_var_2 = 4.0_kind_phys * var + end if + end subroutine opt_arg_scheme_run -!! \section arg_table_opt_arg_scheme_timestep_finalize Argument Table -!! \htmlinclude opt_arg_scheme_timestep_finalize.html -!! - subroutine opt_arg_scheme_timestep_finalize(nx, var, opt_var, opt_var_2, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(in) :: nx - integer, intent(inout) :: var(:) - integer, optional, intent(in) :: opt_var(:) - real(kind=kind_phys), optional, intent(inout) :: opt_var_2(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Update var from opt_var if opt_var is present - if (present(opt_var)) then - var = 4*opt_var - else - var = 7*var - end if - ! Update opt_var_2 if present - if (present(opt_var_2)) then - opt_var_2 = opt_var_2 + 5.0_kind_phys - end if - end subroutine opt_arg_scheme_timestep_finalize + !! \section arg_table_opt_arg_scheme_timestep_finalize Argument Table + !! \htmlinclude opt_arg_scheme_timestep_finalize.html + !! + subroutine opt_arg_scheme_timestep_finalize(nx, var, opt_var, opt_var_2, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(in) :: nx + integer, intent(inout) :: var(:) + integer, optional, intent(in) :: opt_var(:) + real(kind=kind_phys), optional, intent(inout) :: opt_var_2(:) + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Update var from opt_var if opt_var is present + if (present(opt_var)) then + var = 4 * opt_var + else + var = 7 * var + end if + ! Update opt_var_2 if present + if (present(opt_var_2)) then + opt_var_2 = opt_var_2 + 5.0_kind_phys + end if + end subroutine opt_arg_scheme_timestep_finalize end module opt_arg_scheme diff --git a/test_prebuild/test_unit_conv/ccpp_kinds.F90 b/test_prebuild/test_unit_conv/ccpp_kinds.F90 index cf6bfeaf..a07ded9b 100644 --- a/test_prebuild/test_unit_conv/ccpp_kinds.F90 +++ b/test_prebuild/test_unit_conv/ccpp_kinds.F90 @@ -1,13 +1,13 @@ module ccpp_kinds -!! \section arg_table_ccpp_kinds -!! \htmlinclude ccpp_kinds.html -!! + !! \section arg_table_ccpp_kinds + !! \htmlinclude ccpp_kinds.html + !! - use iso_fortran_env, only: real64 + use iso_fortran_env, only: real64 - implicit none + implicit none - integer, parameter :: kind_phys = real64 + integer, parameter :: kind_phys = real64 end module ccpp_kinds diff --git a/test_prebuild/test_unit_conv/data.F90 b/test_prebuild/test_unit_conv/data.F90 index 645a531b..ad6db921 100644 --- a/test_prebuild/test_unit_conv/data.F90 +++ b/test_prebuild/test_unit_conv/data.F90 @@ -1,24 +1,24 @@ module data -!! \section arg_table_data Argument Table -!! \htmlinclude data.html -!! - use ccpp_kinds, only : kind_phys - use ccpp_types, only: ccpp_t + !! \section arg_table_data Argument Table + !! \htmlinclude data.html + !! + use ccpp_kinds, only : kind_phys + use ccpp_types, only: ccpp_t - implicit none + implicit none - private + private - public ncols, ncolsrun, nspecies - public cdata, data_array, data_array2, opt_array_flag + public ncols, ncolsrun, nspecies + public cdata, data_array, data_array2, opt_array_flag - integer, parameter :: ncols = 4 - integer, parameter :: ncolsrun = ncols - integer, parameter :: nspecies = 2 - type(ccpp_t), target :: cdata - real(kind_phys), dimension(1:ncols,1:nspecies) :: data_array - real(kind_phys), dimension(1:ncols) :: data_array2 - logical :: opt_array_flag + integer, parameter :: ncols = 4 + integer, parameter :: ncolsrun = ncols + integer, parameter :: nspecies = 2 + type(ccpp_t), target :: cdata + real(kind=kind_phys), dimension(1:ncols, 1:nspecies) :: data_array + real(kind=kind_phys), dimension(1:ncols) :: data_array2 + logical :: opt_array_flag end module data diff --git a/test_prebuild/test_unit_conv/main.F90 b/test_prebuild/test_unit_conv/main.F90 index 3eb6462e..f414eeda 100644 --- a/test_prebuild/test_unit_conv/main.F90 +++ b/test_prebuild/test_unit_conv/main.F90 @@ -1,92 +1,96 @@ program test_unit_conv - use, intrinsic :: iso_fortran_env, only: error_unit - - use ccpp_types, only: ccpp_t - use data, only: ncols, nspecies - use data, only: cdata, data_array, data_array2, opt_array_flag - - use ccpp_static_api, only: ccpp_physics_init, & - ccpp_physics_timestep_init, & - ccpp_physics_run, & - ccpp_physics_timestep_finalize, & - ccpp_physics_finalize - - implicit none - - character(len=*), parameter :: ccpp_suite = 'unit_conv_suite' - integer :: ierr - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! For physics running over the entire domain, - ! ccpp_thread_number and ccpp_chunk_number are - ! set to 1, indicating that arrays are to be sent - ! following their dimension specification in the - ! metadata (must match horizontal_dimension). - cdata%thrd_no = 1 - cdata%chunk_no = 1 - cdata%thrd_cnt = 1 - - data_array = 1.0_8 - data_array2 = 42.0_8 - opt_array_flag = .true. - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep init step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics run step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_run:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics timestep finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_finalize:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! CCPP physics finalize step ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) - if (ierr/=0) then - write(error_unit,'(a)') "An error occurred in ccpp_physics_timestep_init:" - write(error_unit,'(a)') trim(cdata%errmsg) - stop 1 - end if + use, intrinsic :: iso_fortran_env, only: error_unit + + use ccpp_types, only: ccpp_t + use data, only: ncols, & + nspecies + use data, only: cdata, & + data_array, & + data_array2, & + opt_array_flag + + use ccpp_static_api, only: ccpp_physics_init, & + ccpp_physics_timestep_init, & + ccpp_physics_run, & + ccpp_physics_timestep_finalize, & + ccpp_physics_finalize + + implicit none + + character(len=*), parameter :: ccpp_suite = 'unit_conv_suite' + integer :: ierr + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ! For physics running over the entire domain, + ! ccpp_thread_number and ccpp_chunk_number are + ! set to 1, indicating that arrays are to be sent + ! following their dimension specification in the + ! metadata (must match horizontal_dimension). + cdata%thrd_no = 1 + cdata%chunk_no = 1 + cdata%thrd_cnt = 1 + + data_array = 1.0_8 + data_array2 = 42.0_8 + opt_array_flag = .true. + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep init step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_timestep_init(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics run step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_run(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_run:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics timestep finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_timestep_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_finalize:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CCPP physics finalize step ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + call ccpp_physics_finalize(cdata, suite_name=trim(ccpp_suite), ierr=ierr) + if (ierr/=0) then + write(error_unit, '(a)') "An error occurred in ccpp_physics_timestep_init:" + write(error_unit, '(a)') trim(cdata%errmsg) + stop 1 + end if contains diff --git a/test_prebuild/test_unit_conv/unit_conv_scheme_1.F90 b/test_prebuild/test_unit_conv/unit_conv_scheme_1.F90 index 9ef178ff..42df267e 100644 --- a/test_prebuild/test_unit_conv/unit_conv_scheme_1.F90 +++ b/test_prebuild/test_unit_conv/unit_conv_scheme_1.F90 @@ -4,62 +4,67 @@ module unit_conv_scheme_1 - use, intrinsic :: iso_fortran_env, only: error_unit - use ccpp_kinds, only : kind_phys - implicit none + use, intrinsic :: iso_fortran_env, only: error_unit + use ccpp_kinds, only : kind_phys + implicit none - private - public :: unit_conv_scheme_1_run + private + public :: unit_conv_scheme_1_run - !! This is for unit testing only - real(kind_phys), parameter :: target_value = 1.0_kind_phys - real(kind_phys), parameter :: target_value2 = 42.0_kind_phys + !! This is for unit testing only + real(kind=kind_phys), parameter :: target_value = 1.0_kind_phys + real(kind=kind_phys), parameter :: target_value2 = 42.0_kind_phys - contains +contains -!! \section arg_table_unit_conv_scheme_1_run Argument Table -!! \htmlinclude unit_conv_scheme_1_run.html -!! - subroutine unit_conv_scheme_1_run(data_array, data_array2, data_array_opt, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - real(kind_phys), intent(inout) :: data_array(:) - real(kind_phys), intent(inout) :: data_array2(:) - real(kind_phys), intent(inout), optional :: data_array_opt(:) + !! \section arg_table_unit_conv_scheme_1_run Argument Table + !! \htmlinclude unit_conv_scheme_1_run.html + !! + subroutine unit_conv_scheme_1_run(data_array, data_array2, data_array_opt, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind=kind_phys), intent(inout) :: data_array(:) + real(kind=kind_phys), intent(inout) :: data_array2(:) + real(kind=kind_phys), intent(inout), optional :: data_array_opt(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check values in data array - write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_1_run: checking min/max values of data array to be approximately ', target_value - if (minval(data_array)<0.99*target_value .or. maxval(data_array)>1.01*target_value) then - write(errmsg,'(3(a,e12.4),a)') "Error in unit_conv_scheme_1_run, expected values for data_array of approximately ", & - target_value, " but got [ ", minval(data_array), " : ", maxval(data_array), " ]" - errflg = 1 - return - end if - ! Check values in data array2 - write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_1_run: checking min/max values of data array 2 to be approximately ', target_value2 - if (minval(data_array2)<0.99*target_value2 .or. maxval(data_array2)>1.01*target_value2) then - write(errmsg,'(3(a,e12.4),a)') "Error in unit_conv_scheme_1_run, expected values for data array 2 of approximately ", & - target_value2, " but got [ ", minval(data_array2), " : ", maxval(data_array2), " ]" - errflg = 1 - return - end if - ! Check for presence of optional data array, then check its values - write(error_unit,'(a)') 'In unit_conv_scheme_1_run: checking for presence of optional data array' - if (.not. present(data_array_opt)) then - write(error_unit,'(a)') 'Error in unit_conv_scheme_1_run, optional data array expected but not present' - errflg = 1 - return - endif - write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_1_run: checking min/max values of optional data array to be approximately ', target_value - if (minval(data_array_opt)<0.99*target_value .or. maxval(data_array_opt)>1.01*target_value) then - write(errmsg,'(3(a,e12.4),a)') 'Error in unit_conv_scheme_1_run, expected values of approximately ', & - target_value, ' but got [ ', minval(data_array_opt), ' : ', maxval(data_array_opt), ' ]' - errflg = 1 - return - end if - end subroutine unit_conv_scheme_1_run + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check values in data array + write(error_unit, '(a,e12.4)') & + 'In unit_conv_scheme_1_run: checking min/max values of data array to be approximately ', target_value + if (minval(data_array) < 0.99 * target_value .or. maxval(data_array) > 1.01 * target_value) then + write(errmsg, '(3(a,e12.4),a)') & + "Error in unit_conv_scheme_1_run, expected values for data_array of approximately ", & + target_value, " but got [ ", minval(data_array), " : ", maxval(data_array), " ]" + errflg = 1 + return + end if + ! Check values in data array2 + write(error_unit, '(a,e12.4)') & + 'In unit_conv_scheme_1_run: checking min/max values of data array 2 to be approximately ', target_value2 + if (minval(data_array2) < 0.99 * target_value2 .or. maxval(data_array2) > 1.01 * target_value2) then + write(errmsg, '(3(a,e12.4),a)') & + "Error in unit_conv_scheme_1_run, expected values for data array 2 of approximately ", & + target_value2, " but got [ ", minval(data_array2), " : ", maxval(data_array2), " ]" + errflg = 1 + return + end if + ! Check for presence of optional data array, then check its values + write(error_unit, '(a)') 'In unit_conv_scheme_1_run: checking for presence of optional data array' + if (.not. present(data_array_opt)) then + write(error_unit, '(a)') 'Error in unit_conv_scheme_1_run, optional data array expected but not present' + errflg = 1 + return + end if + write(error_unit, '(a,e12.4)') & + 'In unit_conv_scheme_1_run: checking min/max values of optional data array to be approximately ', target_value + if (minval(data_array_opt) < 0.99 * target_value .or. maxval(data_array_opt) > 1.01 * target_value) then + write(errmsg, '(3(a,e12.4),a)') 'Error in unit_conv_scheme_1_run, expected values of approximately ', & + target_value, ' but got [ ', minval(data_array_opt), ' : ', maxval(data_array_opt), ' ]' + errflg = 1 + return + end if + end subroutine unit_conv_scheme_1_run end module unit_conv_scheme_1 diff --git a/test_prebuild/test_unit_conv/unit_conv_scheme_2.F90 b/test_prebuild/test_unit_conv/unit_conv_scheme_2.F90 index 66f07d93..76f6ef2f 100644 --- a/test_prebuild/test_unit_conv/unit_conv_scheme_2.F90 +++ b/test_prebuild/test_unit_conv/unit_conv_scheme_2.F90 @@ -4,62 +4,66 @@ module unit_conv_scheme_2 - use, intrinsic :: iso_fortran_env, only: error_unit - use ccpp_kinds, only : kind_phys - implicit none + use, intrinsic :: iso_fortran_env, only: error_unit + use ccpp_kinds, only : kind_phys + implicit none - private - public :: unit_conv_scheme_2_run + private + public :: unit_conv_scheme_2_run - !! This is for unit testing only - real(kind_phys), parameter :: target_value = 1.0E-3_kind_phys - real(kind_phys), parameter :: target_value2 = 42.0_kind_phys + !! This is for unit testing only + real(kind=kind_phys), parameter :: target_value = 1.0E-3_kind_phys + real(kind=kind_phys), parameter :: target_value2 = 42.0_kind_phys - contains +contains -!! \section arg_table_unit_conv_scheme_2_run Argument Table -!! \htmlinclude unit_conv_scheme_2_run.html -!! - subroutine unit_conv_scheme_2_run(data_array, data_array2, data_array_opt, errmsg, errflg) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - real(kind_phys), intent(inout) :: data_array(:) - real(kind_phys), intent(inout) :: data_array2(:) - real(kind_phys), intent(inout), optional :: data_array_opt(:) + !! \section arg_table_unit_conv_scheme_2_run Argument Table + !! \htmlinclude unit_conv_scheme_2_run.html + !! + subroutine unit_conv_scheme_2_run(data_array, data_array2, data_array_opt, errmsg, errflg) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind=kind_phys), intent(inout) :: data_array(:) + real(kind=kind_phys), intent(inout) :: data_array2(:) + real(kind=kind_phys), intent(inout), optional :: data_array_opt(:) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - ! Check values in data array - write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_2_run: checking min/max values of data array to be approximately ', target_value - if (minval(data_array)<0.99*target_value .or. maxval(data_array)>1.01*target_value) then - write(errmsg,'(3(a,e12.4),a)') 'Error in unit_conv_scheme_2_run, expected values of approximately ', & - target_value, ' but got [ ', minval(data_array), ' : ', maxval(data_array), ' ]' - errflg = 1 - return - end if - ! Check values in data array2 - write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_2_run: checking min/max values of data array 2 to be approximately ', target_value2 - if (minval(data_array2)<0.99*target_value2 .or. maxval(data_array2)>1.01*target_value2) then - write(errmsg,'(3(a,e12.4),a)') "Error in unit_conv_scheme_2_run, expected values for data array 2 of approximately ", & - target_value2, " but got [ ", minval(data_array2), " : ", maxval(data_array2), " ]" - errflg = 1 - return - end if - ! Check for presence of optional data array, then check its values - write(error_unit,'(a)') 'In unit_conv_scheme_2_run: checking for presence of optional data array' - if (.not. present(data_array_opt)) then - write(error_unit,'(a)') 'Error in unit_conv_scheme_2_run, optional data array expected but not present' - errflg = 1 - return - endif - write(error_unit,'(a,e12.4)') 'In unit_conv_scheme_2_run: checking min/max values of optional data array to be approximately ', target_value - if (minval(data_array_opt)<0.99*target_value .or. maxval(data_array_opt)>1.01*target_value) then - write(errmsg,'(3(a,e12.4),a)') 'Error in unit_conv_scheme_2_run, expected values of approximately ', & - target_value, ' but got [ ', minval(data_array_opt), ' : ', maxval(data_array_opt), ' ]' - errflg = 1 - return - end if - end subroutine unit_conv_scheme_2_run + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! Check values in data array + write(error_unit, '(a,e12.4)') & + 'In unit_conv_scheme_2_run: checking min/max values of data array to be approximately ', target_value + if (minval(data_array) < 0.99 * target_value .or. maxval(data_array) > 1.01 * target_value) then + write(errmsg, '(3(a,e12.4),a)') 'Error in unit_conv_scheme_2_run, expected values of approximately ', & + target_value, ' but got [ ', minval(data_array), ' : ', maxval(data_array), ' ]' + errflg = 1 + return + end if + ! Check values in data array2 + write(error_unit, '(a,e12.4)') & + 'In unit_conv_scheme_2_run: checking min/max values of data array 2 to be approximately ', target_value2 + if (minval(data_array2) < 0.99 * target_value2 .or. maxval(data_array2) > 1.01 * target_value2) then + write(errmsg, '(3(a,e12.4),a)') & + "Error in unit_conv_scheme_2_run, expected values for data array 2 of approximately ", & + target_value2, " but got [ ", minval(data_array2), " : ", maxval(data_array2), " ]" + errflg = 1 + return + end if + ! Check for presence of optional data array, then check its values + write(error_unit, '(a)') 'In unit_conv_scheme_2_run: checking for presence of optional data array' + if (.not. present(data_array_opt)) then + write(error_unit, '(a)') 'Error in unit_conv_scheme_2_run, optional data array expected but not present' + errflg = 1 + return + end if + write(error_unit, '(a,e12.4)') & + 'In unit_conv_scheme_2_run: checking min/max values of optional data array to be approximately ', target_value + if (minval(data_array_opt) < 0.99 * target_value .or. maxval(data_array_opt) > 1.01 * target_value) then + write(errmsg, '(3(a,e12.4),a)') 'Error in unit_conv_scheme_2_run, expected values of approximately ', & + target_value, ' but got [ ', minval(data_array_opt), ' : ', maxval(data_array_opt), ' ]' + errflg = 1 + return + end if + end subroutine unit_conv_scheme_2_run end module unit_conv_scheme_2