From 485d63148d1d633ffd923be97787f33942b2316c Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Wed, 1 Feb 2023 08:28:33 -0500 Subject: [PATCH 01/51] fix: misspellings and rename variable in yaml_parser.F90 (#1127) --- parser/yaml_parser.F90 | 50 +++++++++++++++++++++--------------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/parser/yaml_parser.F90 b/parser/yaml_parser.F90 index a24042cfcd..14a494ba02 100644 --- a/parser/yaml_parser.F90 +++ b/parser/yaml_parser.F90 @@ -61,13 +61,13 @@ module yaml_parser_mod interface !> @brief Private c function that opens and parses a yaml file (see yaml_parser_binding.c) -!! @return Flag indicating if the read was sucessful +!! @return Flag indicating if the read was successful function open_and_parse_file_wrap(filename, file_id) bind(c) & - result(sucess) + result(success) use iso_c_binding, only: c_char, c_int, c_bool character(kind=c_char), intent(in) :: filename(*) !< Filename of the yaml file integer(kind=c_int), intent(out) :: file_id !< File id corresponding to the yaml file that was opened - logical(kind=c_bool) :: sucess !< Flag indicating if the read was sucessful + logical(kind=c_bool) :: success !< Flag indicating if the read was successful end function open_and_parse_file_wrap !> @brief Private c function that checks if a file_id is valid (see yaml_parser_binding.c) @@ -127,16 +127,16 @@ function get_value(file_id, key_id) bind(c) & type(c_ptr) :: key_value end function get_value -!> @brief Private c function that determines they value of a key in yaml_file (see yaml_parser_binding.c) +!> @brief Private c function that determines the value of a key in yaml_file (see yaml_parser_binding.c) !! @return c pointer with the value obtained -function get_value_from_key_wrap(file_id, block_id, key_name, sucess) bind(c) & +function get_value_from_key_wrap(file_id, block_id, key_name, success) bind(c) & result(key_value2) use iso_c_binding, only: c_ptr, c_char, c_int, c_bool integer(kind=c_int), intent(in) :: file_id !< File id of the yaml file to search integer(kind=c_int), intent(in) :: block_id !< ID corresponding to the block you want the key for character(kind=c_char), intent(in) :: key_name(*) !< Name of the key you want the value for - integer(kind=c_int), intent(out) :: sucess !< Flag indicating if the call was sucessful + integer(kind=c_int), intent(out) :: success !< Flag indicating if the call was successful type(c_ptr) :: key_value2 end function get_value_from_key_wrap @@ -206,7 +206,7 @@ function open_and_parse_file(filename) & result(file_id) character(len=*), intent(in) :: filename !< Filename of the yaml file - logical :: sucess !< Flag indicating if the read was sucessful + logical :: success !< Flag indicating if the read was successful logical :: yaml_exists !< Flag indicating whether the yaml exists integer :: file_id @@ -217,8 +217,8 @@ function open_and_parse_file(filename) & call mpp_error(NOTE, "The yaml file:"//trim(filename)//" does not exist, hopefully this is your intent!") return end if - sucess = open_and_parse_file_wrap(trim(filename)//c_null_char, file_id) - if (.not. sucess) call mpp_error(FATAL, "Error opening the yaml file:"//trim(filename)//". Check the file!") + success = open_and_parse_file_wrap(trim(filename)//c_null_char, file_id) + if (.not. success) call mpp_error(FATAL, "Error opening the yaml file:"//trim(filename)//". Check the file!") end function open_and_parse_file @@ -258,27 +258,27 @@ subroutine get_value_from_key_0d(file_id, block_id, key_name, key_value, is_opti integer, intent(in) :: block_id !< ID corresponding to the block you want the key for character(len=*), intent(in) :: key_name !< Name of the key you want the value for class(*), intent(inout):: key_value !< Value of the key - logical, intent(in), optional :: is_optional !< Flag indicating if it is okay for they key to not exist. + logical, intent(in), optional :: is_optional !< Flag indicating if it is okay for the key to not exist. !! If the key does not exist key_value will not be set, so it !! is the user's responsibility to initialize it before the call character(len=255) :: buffer !< String buffer with the value type(c_ptr) :: c_buffer !< c pointer with the value - integer(kind=c_int) :: sucess !< Flag indicating if the value was obtained sucessfully - logical :: optional !< Flag indicating that the key was optional + integer(kind=c_int) :: success !< Flag indicating if the value was obtained successfully + logical :: optional_flag !< Flag indicating that the key was optional integer :: err_unit !< integer with io error - optional = .false. - if (present(is_optional)) optional = is_optional + optional_flag = .false. + if (present(is_optional)) optional_flag = is_optional if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, & & "The file id in your get_value_from_key call is invalid! Check your call.") if (.not. is_valid_block_id(file_id, block_id)) call mpp_error(FATAL, & & "The block id in your get_value_from_key call is invalid! Check your call.") - c_buffer = get_value_from_key_wrap(file_id, block_id, trim(key_name)//c_null_char, sucess) - if (sucess == 1) then + c_buffer = get_value_from_key_wrap(file_id, block_id, trim(key_name)//c_null_char, success) + if (success == 1) then buffer = fms_c2f_string(c_buffer) select type (key_value) @@ -313,7 +313,7 @@ subroutine get_value_from_key_0d(file_id, block_id, key_name, key_value, is_opti &" is not supported. Only i4, i8, r4, r8 and strings are supported.") end select else - if(.not. optional) call mpp_error(FATAL, "Error getting the value for key:"//trim(key_name)) + if(.not. optional_flag) call mpp_error(FATAL, "Error getting the value for key:"//trim(key_name)) endif end subroutine get_value_from_key_0d @@ -324,27 +324,27 @@ subroutine get_value_from_key_1d(file_id, block_id, key_name, key_value, is_opti integer, intent(in) :: block_id !< ID corresponding to the block you want the key for character(len=*), intent(in) :: key_name !< Name of the key you want the value for class(*), intent(inout):: key_value(:) !< Value of the key - logical, intent(in), optional :: is_optional !< Flag indicating if it is okay for they key' to not exist. + logical, intent(in), optional :: is_optional !< Flag indicating if it is okay for the key' to not exist. !! If the key does not exist key_value will not be set, so it !! is the user's responsibility to initialize it before the call character(len=255) :: buffer !< String buffer with the value type(c_ptr) :: c_buffer !< c pointer with the value - integer(kind=c_int) :: sucess !< Flag indicating if the value was obtained sucessfully - logical :: optional !< Flag indicating that the key was optional + integer(kind=c_int) :: success !< Flag indicating if the value was obtained successfully + logical :: optional_flag !< Flag indicating that the key was optional integer :: err_unit !< integer with io error - optional=.false. - if (present(is_optional)) optional = is_optional + optional_flag=.false. + if (present(is_optional)) optional_flag = is_optional if (.not. is_valid_file_id(file_id)) call mpp_error(FATAL, & & "The file id in your get_value_from_key call is invalid! Check your call.") if (.not. is_valid_block_id(file_id, block_id)) call mpp_error(FATAL, & & "The block id in your get_value_from_key call is invalid! Check your call.") - c_buffer = get_value_from_key_wrap(file_id, block_id, trim(key_name)//c_null_char, sucess) - if (sucess == 1) then + c_buffer = get_value_from_key_wrap(file_id, block_id, trim(key_name)//c_null_char, success) + if (success == 1) then buffer = fms_c2f_string(c_buffer) select type (key_value) @@ -371,7 +371,7 @@ subroutine get_value_from_key_1d(file_id, block_id, key_name, key_value, is_opti &" is not supported. Only i4, i8, r4, r8 and strings are supported.") end select else - if(.not. optional) call mpp_error(FATAL, "Error getting the value for key:"//trim(key_name)) + if(.not. optional_flag) call mpp_error(FATAL, "Error getting the value for key:"//trim(key_name)) endif end subroutine get_value_from_key_1d From 35a5f2ab592498322fcb6a0882e47e55a7b9bea6 Mon Sep 17 00:00:00 2001 From: MiKyung Lee <58964324+mlee03@users.noreply.github.com> Date: Wed, 1 Feb 2023 08:31:42 -0500 Subject: [PATCH 02/51] fix: module and local variable name conflicts in time_interp (#1125) Co-authored-by: mlee03 --- time_interp/time_interp.F90 | 62 ++++++++++++++++++------------------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/time_interp/time_interp.F90 b/time_interp/time_interp.F90 index a6a31c0425..83cacec3f4 100644 --- a/time_interp/time_interp.F90 +++ b/time_interp/time_interp.F90 @@ -287,7 +287,7 @@ subroutine time_interp_frac ( Time, weight ) type(time_type), intent(in) :: Time real , intent(out) :: weight !< fractional time - integer :: year, month, day, hour, minute, second + integer :: yr, mo, dy, hour, minute, second type(time_type) :: Year_beg, Year_end @@ -295,10 +295,10 @@ subroutine time_interp_frac ( Time, weight ) ! ---- compute fractional time of year ----- - call get_date (Time, year, month, day, hour, minute, second) + call get_date (Time, yr, mo, dy, hour, minute, second) - Year_beg = set_date(year , 1, 1) - Year_end = set_date(year+1, 1, 1) + Year_beg = set_date(yr , 1, 1) + Year_end = set_date(yr+1, 1, 1) weight = real( (Time - Year_beg) // (Year_end - Year_beg) ) @@ -338,27 +338,27 @@ subroutine time_interp_year ( Time, weight, year1, year2 ) real , intent(out) :: weight !< fractional time between midpoints of year1 and year2 integer , intent(out) :: year1, year2 - integer :: year, month, day, hour, minute, second + integer :: yr, mo, dy, hour, minute, second type (time_type) :: Mid_year, Mid_year1, Mid_year2 if ( .not. module_is_initialized ) call time_interp_init() - call get_date (Time, year, month, day, hour, minute, second) + call get_date (Time, yr, mo, dy, hour, minute, second) ! mid point of current year - Mid_year = year_midpt(year) + Mid_year = year_midpt(yr) if ( Time >= Mid_year ) then ! current time is after mid point of current year - year1 = year - year2 = year+1 + year1 = yr + year2 = yr+1 Mid_year2 = year_midpt(year2) weight = real( (Time - Mid_year) // (Mid_year2 - Mid_year) ) else ! current time is before mid point of current year - year2 = year - year1 = year-1 + year2 = yr + year1 = yr-1 Mid_year1 = year_midpt(year1) weight = real( (Time - Mid_year1) // (Mid_year - Mid_year1) ) endif @@ -381,12 +381,12 @@ subroutine time_interp_month ( Time, weight, year1, year2, month1, month2 ) real , intent(out) :: weight integer , intent(out) :: year1, year2, month1, month2 - integer :: year, month, day, hour, minute, second, & + integer :: yr, mo, dy, hour, minute, second, & mid_month, cur_month, mid1, mid2 if ( .not. module_is_initialized ) call time_interp_init() - call get_date (Time, year, month, day, hour, minute, second) + call get_date (Time, yr, mo, dy, hour, minute, second) ! mid point of current month in seconds mid_month = days_in_month(Time) * halfday @@ -395,8 +395,8 @@ subroutine time_interp_month ( Time, weight, year1, year2, month1, month2 ) if ( cur_month >= mid_month ) then ! current time is after mid point of current month - year1 = year; month1 = month - year2 = year; month2 = month+1 + year1 = yr; month1 = mo + year2 = yr; month2 = mo+1 if (month2 > monyear) then year2 = year2+1; month2 = 1 endif @@ -405,8 +405,8 @@ subroutine time_interp_month ( Time, weight, year1, year2, month1, month2 ) weight = real(cur_month - mid1) / real(mid1+mid2) else ! current time is before mid point of current month - year2 = year; month2 = month - year1 = year; month1 = month-1 + year2 = yr; month2 = mo + year1 = yr; month1 = mo-1 if (month1 < 1) then year1 = year1-1; month1 = monyear endif @@ -442,19 +442,19 @@ subroutine time_interp_day ( Time, weight, year1, year2, month1, month2, day1, d real , intent(out) :: weight integer , intent(out) :: year1, year2, month1, month2, day1, day2 - integer :: year, month, day, hour, minute, second, sday + integer :: yr, mo, dy, hour, minute, second, sday if ( .not. module_is_initialized ) call time_interp_init() - call get_date (Time, year, month, day, hour, minute, second) + call get_date (Time, yr, mo, dy, hour, minute, second) ! time into current day in seconds sday = second + secmin*minute + sechour*hour if ( sday >= halfday ) then ! current time is after mid point of day - year1 = year; month1 = month; day1 = day - year2 = year; month2 = month; day2 = day + 1 + year1 = yr; month1 = mo; day1 = dy + year2 = yr; month2 = mo; day2 = dy + 1 weight = real(sday - halfday) / real(secday) if (day2 > days_in_month(Time)) then @@ -841,14 +841,14 @@ end subroutine time_interp_list ! private routines !####################################################################### - function year_midpt (year) + function year_midpt (yr) - integer, intent(in) :: year + integer, intent(in) :: yr type (time_type) :: year_midpt, year_beg, year_end - year_beg = set_date(year , 1, 1) - year_end = set_date(year+1, 1, 1) + year_beg = set_date(yr , 1, 1) + year_end = set_date(yr+1, 1, 1) year_midpt = (year_beg + year_end) / 2 @@ -856,19 +856,19 @@ end function year_midpt !####################################################################### - function month_midpt (year, month) + function month_midpt (yr, mo) - integer, intent(in) :: year, month + integer, intent(in) :: yr, mo type (time_type) :: month_midpt, month_beg, month_end ! --- beginning of this month --- - month_beg = set_date(year, month, 1) + month_beg = set_date(yr, mo, 1) ! --- start of next month --- - if (month < 12) then - month_end = set_date(year, month+1, 1) + if (mo < 12) then + month_end = set_date(yr, mo+1, 1) else - month_end = set_date(year+1, 1, 1) + month_end = set_date(yr+1, 1, 1) endif month_midpt = (month_beg + month_end) / 2 From ba9c712825372eb3dc703685dd5c7e9c7560faa3 Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Wed, 1 Feb 2023 11:48:54 -0500 Subject: [PATCH 03/51] docs: Correct instructions to build without MPI (#1128) --- INSTALL.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/INSTALL.md b/INSTALL.md index 1ec977f2e3..a6ab9858fe 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -28,7 +28,7 @@ to not use an MPI aware compiler, you should pass the include and library locations to the build system. libFMS can be built without MPI support (sometimes called "no-comm mode"). To -build libFMS without MPI support, pass to `configure` the `--disable-mpi` flag. +build libFMS without MPI support, pass to `configure` the `--with-mpi=no` flag. ## Supported Build Systems From 15df841c2d23e5e89cd51ae70068db2a93ce0f38 Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Thu, 9 Feb 2023 14:18:43 -0500 Subject: [PATCH 04/51] fix: pointer to allocatable in amip_interp_type (#1106) --- amip_interp/amip_interp.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/amip_interp/amip_interp.F90 b/amip_interp/amip_interp.F90 index 931a16a745..98914feaa3 100644 --- a/amip_interp/amip_interp.F90 +++ b/amip_interp/amip_interp.F90 @@ -277,8 +277,7 @@ module amip_interp_mod type amip_interp_type private type (horiz_interp_type) :: Hintrp, Hintrp2 ! add by JHC - real, pointer :: data1(:,:) =>NULL(), & - data2(:,:) =>NULL() + real, allocatable :: data1(:,:), data2(:,:) type (date_type) :: Date1, Date2 logical :: use_climo, use_annual logical :: I_am_initialized=.false. @@ -1003,8 +1002,8 @@ end subroutine amip_interp_init !! when calling get_amip_sst and get_amip_ice. subroutine amip_interp_del (Interp) type (amip_interp_type), intent(inout) :: Interp - if(associated(Interp%data1)) deallocate(Interp%data1) - if(associated(Interp%data2)) deallocate(Interp%data2) + if(allocated(Interp%data1)) deallocate(Interp%data1) + if(allocated(Interp%data2)) deallocate(Interp%data2) if(allocated(lon_bnd)) deallocate(lon_bnd) if(allocated(lat_bnd)) deallocate(lat_bnd) call horiz_interp_del ( Interp%Hintrp ) @@ -1536,8 +1535,9 @@ subroutine amip_interp_type_eq(amip_interp_out, amip_interp_in) endif amip_interp_out%Hintrp = amip_interp_in%Hintrp - amip_interp_out%data1 => amip_interp_in%data1 - amip_interp_out%data2 => amip_interp_in%data2 + amip_interp_out%Hintrp2 = amip_interp_in%Hintrp2 !< missing assignment statement; added by GPP + amip_interp_out%data1 = amip_interp_in%data1 + amip_interp_out%data2 = amip_interp_in%data2 amip_interp_out%Date1 = amip_interp_in%Date1 amip_interp_out%Date2 = amip_interp_in%Date2 amip_interp_out%Date1 = amip_interp_in%Date1 From f0e8cab3d8e58195f7c2663b84fd0bed12fa8b64 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Tue, 14 Feb 2023 08:51:17 -0500 Subject: [PATCH 05/51] feat: log_diag_field_info updates from diag rewrite (#1117) --- diag_manager/diag_manager.F90 | 110 ++++++++++++++++++---------------- diag_manager/diag_util.F90 | 95 +++++++++++++---------------- 2 files changed, 102 insertions(+), 103 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 01f0ad6f8b..c726b109f3 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -201,9 +201,6 @@ MODULE diag_manager_mod ! The values are defined as GLO_REG_VAL (-999) and GLO_REG_VAL_ALT ! (-1) in diag_data_mod. ! - ! - ! Set to true, diag_manager uses mpp_io. Default is fms2_io. - ! ! USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& @@ -216,12 +213,12 @@ MODULE diag_manager_mod USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdout, stdlog, write_version_number,& & fms_error_handler, check_nml_error, lowercase USE diag_axis_mod, ONLY: diag_axis_init, get_axis_length, get_axis_num, get_domain2d, get_tile_count,& - & diag_axis_add_attribute, axis_compatible_check, CENTER, NORTH, EAST + & diag_axis_add_attribute, axis_compatible_check, CENTER, NORTH, EAST, get_diag_axis_name USE diag_util_mod, ONLY: get_subfield_size, log_diag_field_info, update_bounds,& & check_out_of_bounds, check_bounds_are_exact_dynamic, check_bounds_are_exact_static,& & diag_time_inc, find_input_field, init_input_field, init_output_field,& & diag_data_out, write_static, get_date_dif, get_subfield_vert_size, sync_file_times,& - & prepend_attribute, attribute_init, diag_util_init + & prepend_attribute, attribute_init, diag_util_init, field_log_separator USE diag_data_mod, ONLY: max_files, CMOR_MISSING_VALUE, DIAG_OTHER, DIAG_OCEAN, DIAG_ALL, EVERY_TIME,& & END_OF_RUN, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, num_files,& & max_input_fields, max_output_fields, num_output_fields, EMPTY, FILL_VALUE, null_axis_id,& @@ -378,17 +375,19 @@ MODULE diag_manager_mod INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, & & long_name, units, missing_value, range, standard_name, do_not_log, err_msg,& & area, volume, realm) - CHARACTER(len=*), INTENT(in) :: module_name, field_name - TYPE(time_type), OPTIONAL, INTENT(in) :: init_time - CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name - CLASS(*), OPTIONAL, INTENT(in) :: missing_value - CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range - LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged - CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg - INTEGER, OPTIONAL, INTENT(in) :: area, volume - CHARACTER(len=*), OPTIONAL, INTENT(in):: realm !< String to set as the value to the modeling_realm attribute - - IF ( PRESENT(err_msg) ) err_msg = '' + CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from + CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field + TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from + CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file + CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute + CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to add a variable attribute + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged + CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call + INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field + INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute ! Fatal error if range is present and its extent is not 2. IF ( PRESENT(range) ) THEN @@ -415,23 +414,27 @@ END FUNCTION register_diag_field_scalar INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_time, & & long_name, units, missing_value, range, mask_variant, standard_name, verbose,& & do_not_log, err_msg, interp_method, tile_count, area, volume, realm) - CHARACTER(len=*), INTENT(in) :: module_name, field_name - INTEGER, INTENT(in) :: axes(:) - TYPE(time_type), INTENT(in) :: init_time - CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name - CLASS(*), OPTIONAL, INTENT(in) :: missing_value - CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range - LOGICAL, OPTIONAL, INTENT(in) :: mask_variant,verbose - LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged - CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg + CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from + CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field + INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis + TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from + CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute + CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute + CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute + CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to add a variable attribute + LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant + CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file + LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged + CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when !! regridding the field in post-processing. !! Valid options are "conserve_order1", !! "conserve_order2", and "none". - INTEGER, OPTIONAL, INTENT(in) :: tile_count - INTEGER, OPTIONAL, INTENT(in) :: area !< diag_field_id containing the cell area field - INTEGER, OPTIONAL, INTENT(in) :: volume !< diag_field_id containing the cell volume field - CHARACTER(len=*), OPTIONAL, INTENT(in):: realm !< String to set as the value to the modeling_realm attribute + INTEGER, OPTIONAL, INTENT(in) :: tile_count !< The current tile number + INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field + INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field + CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute INTEGER :: field, j, ind, file_num, freq INTEGER :: output_units @@ -634,7 +637,8 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, INTEGER :: tile, file_num LOGICAL :: mask_variant1, dynamic1, allow_log CHARACTER(len=128) :: msg - INTEGER :: domain_type + INTEGER :: domain_type, i + character(len=256) :: axes_list, axis_name ! Fatal error if the module has not been initialized. IF ( .NOT.module_is_initialized ) THEN @@ -691,12 +695,16 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, END IF END IF - ! Namelist do_diag_field_log is by default false. Thus to log the - ! registration of the data field, but the OPTIONAL parameter - ! do_not_log == .FALSE. and the namelist variable - ! do_diag_field_log == .TRUE.. + ! only writes log if do_diag_field_log is true in the namelist (default false) + ! if do_diag_field_log is true and do_not_log arg is present as well, it will only print if do_not_log = false IF ( do_diag_field_log.AND.allow_log ) THEN - CALL log_diag_field_info (module_name, field_name, axes, & + axes_list='' + DO i = 1, SIZE(axes) + CALL get_diag_axis_name(axes(i),axis_name) + IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' + axes_list = TRIM(axes_list)//TRIM(axis_name) + END DO + CALL log_diag_field_info (module_name, field_name, axes, axes_list, & & long_name, units, missing_value=missing_value, range=range, & & DYNAMIC=dynamic1) END IF @@ -1094,9 +1102,9 @@ INTEGER FUNCTION get_diag_field_id(module_name, field_name) CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable CHARACTER(len=*), INTENT(in) :: field_name !< Variable name - ! find_input_field will return DIAG_FIELD_NOT_FOUND if the field is not - ! included in the diag_table - get_diag_field_id = find_input_field(module_name, field_name, tile_count=1) + ! find_input_field will return DIAG_FIELD_NOT_FOUND if the field is not + ! included in the diag_table + get_diag_field_id = find_input_field(module_name, field_name, tile_count=1) END FUNCTION get_diag_field_id !> @brief Finds the corresponding related output field and file for a given input field @@ -3645,7 +3653,6 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) INTEGER, DIMENSION(6), OPTIONAL, INTENT(IN) :: time_init !< Model time diag_manager initialized CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg - CHARACTER(len=*), PARAMETER :: SEP = '|' INTEGER, PARAMETER :: FltKind = R4_KIND INTEGER, PARAMETER :: DblKind = R8_KIND @@ -3660,7 +3667,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,& & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,& & oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,& - & max_file_attributes, max_axis_attributes, prepend_date, use_mpp_io + & max_file_attributes, max_axis_attributes, prepend_date, use_mpp_io, field_log_separator ! If the module was already initialized do nothing IF ( module_is_initialized ) RETURN @@ -3755,9 +3762,9 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) ALLOCATE(fileobj(max_files)) ALLOCATE(fileobjND(max_files)) ALLOCATE(fnum_for_domain(max_files)) - !> Initialize fnum_for_domain with "dn" which stands for done + !> Initialize fnum_for_domain with "dn" which stands for done fnum_for_domain(:) = "dn" - CALL error_mesg('diag_manager_mod::diag_manager_init',& + CALL error_mesg('diag_manager_mod::diag_manager_init',& & 'diag_manager is using fms2_io', NOTE) else CALL error_mesg('diag_manager_mod::diag_manager_init',& @@ -3780,23 +3787,24 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) END IF END IF - CALL parse_diag_table(DIAG_SUBSET=diag_subset_output, ISTAT=mystat, ERR_MSG=err_msg_local) - IF ( mystat /= 0 ) THEN + CALL parse_diag_table(DIAG_SUBSET=diag_subset_output, ISTAT=mystat, ERR_MSG=err_msg_local) + IF ( mystat /= 0 ) THEN IF ( fms_error_handler('diag_manager_mod::diag_manager_init',& & 'Error parsing diag_table. '//TRIM(err_msg_local), err_msg) ) RETURN - END IF + END IF !initialize files%bytes_written to zero files(:)%bytes_written = 0 ! open diag field log file IF ( do_diag_field_log.AND.mpp_pe().EQ.mpp_root_pe() ) THEN - open(newunit=diag_log_unit, file='diag_field_log.out', action='WRITE') - WRITE (diag_log_unit,'(777a)') & - & 'Module', SEP, 'Field', SEP, 'Long Name', SEP,& - & 'Units', SEP, 'Number of Axis', SEP, 'Time Axis', SEP,& - & 'Missing Value', SEP, 'Min Value', SEP, 'Max Value', SEP,& - & 'AXES LIST' + open(newunit=diag_log_unit, file='diag_field_log.out', action='WRITE') + WRITE (diag_log_unit,'(777a)') & + & 'Module', FIELD_LOG_SEPARATOR, 'Field', FIELD_LOG_SEPARATOR, & + & 'Long Name', FIELD_LOG_SEPARATOR, 'Units', FIELD_LOG_SEPARATOR, & + & 'Number of Axis', FIELD_LOG_SEPARATOR, 'Time Axis', FIELD_LOG_SEPARATOR, & + & 'Missing Value', FIELD_LOG_SEPARATOR, 'Min Value', FIELD_LOG_SEPARATOR, & + & 'Max Value', FIELD_LOG_SEPARATOR, 'AXES LIST' END IF module_is_initialized = .TRUE. diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index a676fefede..ad9e9ef0ab 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -106,6 +106,9 @@ MODULE diag_util_mod LOGICAL :: module_initialized = .FALSE. + character(len=1), public :: field_log_separator = '|' !< separator used for csv-style log of registered fields + !! set by nml in diag_manager init + CONTAINS @@ -621,11 +624,12 @@ END FUNCTION get_index !! code uses a do_not_log parameter in the registration calls, !! and subsequently calls this subroutine to log field information !! under a generic name. - SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& - & missing_value, range, dynamic) + SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_name, units,& + & missing_value, range, dynamic ) CHARACTER(len=*), INTENT(in) :: module_name !< Module name CHARACTER(len=*), INTENT(in) :: field_name !< Field name INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axis IDs + CHARACTER(len=*), INTENT(in) :: axes_list !< Comma seperated list of axes names CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long name for field. CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Unit of field. CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value value. @@ -636,99 +640,86 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& CHARACTER(len=256) :: lmodule, lfield, lname, lunits CHARACTER(len=64) :: lmissval, lmin, lmax CHARACTER(len=8) :: numaxis, timeaxis - CHARACTER(len=1) :: sep = '|' - CHARACTER(len=256) :: axis_name, axes_list INTEGER :: i REAL :: missing_value_use !< Local copy of missing_value REAL, DIMENSION(2) :: range_use !< Local copy of range - - IF ( .NOT.do_diag_field_log ) RETURN IF ( mpp_pe().NE.mpp_root_pe() ) RETURN ! Fatal error if range is present and its extent is not 2. IF ( PRESENT(range) ) THEN - IF ( SIZE(range) .NE. 2 ) THEN - ! extent of range should be 2 - CALL error_mesg ('diag_util_mod::log_diag_field_info', 'extent of range should be 2', FATAL) - END IF + IF ( SIZE(range) .NE. 2 ) THEN + CALL error_mesg('diag_util_mod::fms_log_field_info', 'extent of range should be 2', FATAL) + END IF END IF lmodule = TRIM(module_name) lfield = TRIM(field_name) IF ( PRESENT(long_name) ) THEN - lname = TRIM(long_name) + lname = TRIM(long_name) ELSE - lname = '' + lname = '' END IF IF ( PRESENT(units) ) THEN - lunits = TRIM(units) + lunits = TRIM(units) ELSE - lunits = '' + lunits = '' END IF WRITE (numaxis,'(i1)') SIZE(axes) IF (PRESENT(missing_value)) THEN - IF ( use_cmor ) THEN - WRITE (lmissval,*) CMOR_MISSING_VALUE - ELSE - SELECT TYPE (missing_value) + IF ( use_cmor ) THEN + WRITE (lmissval,*) CMOR_MISSING_VALUE + ELSE + SELECT TYPE (missing_value) TYPE IS (real(kind=r4_kind)) - missing_value_use = missing_value + missing_value_use = missing_value TYPE IS (real(kind=r8_kind)) - missing_value_use = real(missing_value) + missing_value_use = real(missing_value) CLASS DEFAULT - CALL error_mesg ('diag_util_mod::log_diag_field_info',& - & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - WRITE (lmissval,*) missing_value_use - END IF + CALL error_mesg ('diag_util_mod::log_diag_field_info',& + & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + END SELECT + WRITE (lmissval,*) missing_value_use + END IF ELSE - lmissval = '' + lmissval = '' ENDIF IF ( PRESENT(range) ) THEN - SELECT TYPE (range) - TYPE IS (real(kind=r4_kind)) + SELECT TYPE (range) + TYPE IS (real(kind=r4_kind)) range_use = range - TYPE IS (real(kind=r8_kind)) + TYPE IS (real(kind=r8_kind)) range_use = real(range) - CLASS DEFAULT + CLASS DEFAULT CALL error_mesg ('diag_util_mod::log_diag_field_info',& - & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - WRITE (lmin,*) range_use(1) - WRITE (lmax,*) range_use(2) + & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + END SELECT + WRITE (lmin,*) range_use(1) + WRITE (lmax,*) range_use(2) ELSE - lmin = '' - lmax = '' + lmin = '' + lmax = '' END IF IF ( PRESENT(dynamic) ) THEN - IF (dynamic) THEN + IF (dynamic) THEN timeaxis = 'T' - ELSE + ELSE timeaxis = 'F' - END IF + END IF ELSE - timeaxis = '' + timeaxis = '' END IF - axes_list='' - DO i = 1, SIZE(axes) - CALL get_diag_axis_name(axes(i),axis_name) - IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' - axes_list = TRIM(axes_list)//TRIM(axis_name) - END DO - - !write (diag_log_unit,'(8(a,a),a)') & WRITE (diag_log_unit,'(777a)') & - & TRIM(lmodule), sep, TRIM(lfield), sep, TRIM(lname), sep,& - & TRIM(lunits), sep, TRIM(numaxis), sep, TRIM(timeaxis), sep,& - & TRIM(lmissval), sep, TRIM(lmin), sep, TRIM(lmax), sep,& - & TRIM(axes_list) + & TRIM(lmodule), field_log_separator, TRIM(lfield), field_log_separator, TRIM(lname), field_log_separator,& + & TRIM(lunits), field_log_separator, TRIM(numaxis), field_log_separator, TRIM(timeaxis), field_log_separator,& + & TRIM(lmissval), field_log_separator, TRIM(lmin), field_log_separator, TRIM(lmax), field_log_separator,& + & TRIM(axes_list) END SUBROUTINE log_diag_field_info !> @brief Update the output_fields x, y, and z min and max boundaries (array indices). From ec2020af4c4c16805e8529c6e5c3ddde82d84c65 Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Thu, 16 Feb 2023 12:38:44 -0500 Subject: [PATCH 06/51] fix: remove implied save for valid_types variables in sat_vapor_pres_k (#1120) --- sat_vapor_pres/sat_vapor_pres_k.F90 | 93 +++++++++++++++++++---------- 1 file changed, 62 insertions(+), 31 deletions(-) diff --git a/sat_vapor_pres/sat_vapor_pres_k.F90 b/sat_vapor_pres/sat_vapor_pres_k.F90 index b8ceabfb2b..a9b7a4aee2 100644 --- a/sat_vapor_pres/sat_vapor_pres_k.F90 +++ b/sat_vapor_pres/sat_vapor_pres_k.F90 @@ -491,8 +491,9 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & !! when called with r8 arguments integer :: i, j, k real :: hc_loc - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (press) @@ -823,8 +824,9 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & !! when called with r8 arguments integer :: i, j real :: hc_loc - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (press) @@ -1151,8 +1153,9 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & !! when called with r8 arguments integer :: i real :: hc_loc - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (press) @@ -1472,8 +1475,9 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & real(kind=r4_kind) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments real(kind=r8_kind) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments real :: hc_loc - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (press) @@ -2102,8 +2106,9 @@ subroutine lookup_es_des_k_3d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -2188,8 +2193,9 @@ subroutine lookup_es_des_k_2d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -2270,8 +2276,9 @@ subroutine lookup_es_des_k_1d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -2397,8 +2404,9 @@ subroutine lookup_es_k_3d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -2468,8 +2476,9 @@ subroutine lookup_des_k_3d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (desat) @@ -2538,8 +2547,9 @@ subroutine lookup_des_k_2d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (desat) @@ -2603,8 +2613,9 @@ subroutine lookup_es_k_2d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -2668,8 +2679,9 @@ subroutine lookup_des_k_1d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (desat) @@ -2729,8 +2741,9 @@ subroutine lookup_es_k_1d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -2866,8 +2879,9 @@ subroutine lookup_es2_des2_k_3d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -2952,8 +2966,9 @@ subroutine lookup_es2_des2_k_2d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -3034,8 +3049,9 @@ subroutine lookup_es2_des2_k_1d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -3161,8 +3177,9 @@ subroutine lookup_es2_k_3d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -3232,8 +3249,9 @@ subroutine lookup_des2_k_3d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (desat) @@ -3302,8 +3320,9 @@ subroutine lookup_des2_k_2d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (desat) @@ -3367,8 +3386,9 @@ subroutine lookup_es2_k_2d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -3432,8 +3452,9 @@ subroutine lookup_des2_k_1d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (desat) @@ -3493,8 +3514,9 @@ subroutine lookup_es2_k_1d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -3632,8 +3654,9 @@ subroutine lookup_es3_des3_k_3d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -3718,8 +3741,9 @@ subroutine lookup_es3_des3_k_2d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -3800,8 +3824,9 @@ subroutine lookup_es3_des3_k_1d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -3927,8 +3952,9 @@ subroutine lookup_es3_k_3d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -3998,8 +4024,9 @@ subroutine lookup_des3_k_3d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (desat) @@ -4068,8 +4095,9 @@ subroutine lookup_des3_k_2d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (desat) @@ -4133,8 +4161,9 @@ subroutine lookup_es3_k_2d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) @@ -4198,8 +4227,9 @@ subroutine lookup_des3_k_1d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (desat) @@ -4259,8 +4289,9 @@ subroutine lookup_es3_k_1d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. !< For checking if variable types match + logical :: valid_types !< For checking if variable types match + valid_types = .false. select type (temp) type is (real(kind=r4_kind)) select type (esat) From 4526cc94a3e19fe8fa151f54b0db432e1fb2f7d0 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 16 Feb 2023 13:06:18 -0500 Subject: [PATCH 07/51] revert: log_diag_field_info argument changes (#1136) Co-authored-by: rem1776 --- diag_manager/diag_manager.F90 | 8 +------- diag_manager/diag_util.F90 | 13 +++++++++++-- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index c726b109f3..50ecb81eab 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -698,13 +698,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, ! only writes log if do_diag_field_log is true in the namelist (default false) ! if do_diag_field_log is true and do_not_log arg is present as well, it will only print if do_not_log = false IF ( do_diag_field_log.AND.allow_log ) THEN - axes_list='' - DO i = 1, SIZE(axes) - CALL get_diag_axis_name(axes(i),axis_name) - IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' - axes_list = TRIM(axes_list)//TRIM(axis_name) - END DO - CALL log_diag_field_info (module_name, field_name, axes, axes_list, & + CALL log_diag_field_info (module_name, field_name, axes, & & long_name, units, missing_value=missing_value, range=range, & & DYNAMIC=dynamic1) END IF diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index ad9e9ef0ab..4ee31b21e5 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -624,12 +624,11 @@ END FUNCTION get_index !! code uses a do_not_log parameter in the registration calls, !! and subsequently calls this subroutine to log field information !! under a generic name. - SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_name, units,& + SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& & missing_value, range, dynamic ) CHARACTER(len=*), INTENT(in) :: module_name !< Module name CHARACTER(len=*), INTENT(in) :: field_name !< Field name INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axis IDs - CHARACTER(len=*), INTENT(in) :: axes_list !< Comma seperated list of axes names CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long name for field. CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Unit of field. CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value value. @@ -643,6 +642,9 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_na INTEGER :: i REAL :: missing_value_use !< Local copy of missing_value REAL, DIMENSION(2) :: range_use !< Local copy of range + CHARACTER(len=256) :: axis_name, axes_list + + IF ( .NOT.do_diag_field_log ) RETURN IF ( mpp_pe().NE.mpp_root_pe() ) RETURN ! Fatal error if range is present and its extent is not 2. @@ -715,6 +717,13 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_na timeaxis = '' END IF + axes_list='' + DO i = 1, SIZE(axes) + CALL get_diag_axis_name(axes(i),axis_name) + IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' + axes_list = TRIM(axes_list)//TRIM(axis_name) + END DO + WRITE (diag_log_unit,'(777a)') & & TRIM(lmodule), field_log_separator, TRIM(lfield), field_log_separator, TRIM(lname), field_log_separator,& & TRIM(lunits), field_log_separator, TRIM(numaxis), field_log_separator, TRIM(timeaxis), field_log_separator,& From 6255971af28381fad22547bdc2c538fc3ea2e8bf Mon Sep 17 00:00:00 2001 From: Miguel R Zuniga <42479054+ngs333@users.noreply.github.com> Date: Thu, 23 Feb 2023 15:09:53 -0500 Subject: [PATCH 08/51] feat: refactored send_data math (field buffer update) functions. (#1131) --- CMakeLists.txt | 9 +- diag_manager/Makefile.am | 38 +- diag_manager/diag_data.F90 | 9 +- diag_manager/diag_manager.F90 | 109 +- diag_manager/diag_util.F90 | 466 ++++-- diag_manager/fms_diag_bbox.F90 | 167 ++ diag_manager/fms_diag_elem_weight_procs.F90 | 136 ++ diag_manager/fms_diag_fieldbuff_update.F90 | 110 ++ diag_manager/fms_diag_outfield.F90 | 450 ++++++ diag_manager/fms_diag_time_reduction.F90 | 227 +++ .../include/fms_diag_fieldbuff_update.fh | 1374 +++++++++++++++++ .../include/fms_diag_fieldbuff_update.inc | 50 + test_fms/diag_manager/Makefile.am | 5 +- test_fms/diag_manager/test_diag_manager2.sh | 8 +- .../diag_manager/test_diag_update_buffer.F90 | 491 ++++++ 15 files changed, 3473 insertions(+), 176 deletions(-) create mode 100644 diag_manager/fms_diag_bbox.F90 create mode 100644 diag_manager/fms_diag_elem_weight_procs.F90 create mode 100644 diag_manager/fms_diag_fieldbuff_update.F90 create mode 100644 diag_manager/fms_diag_outfield.F90 create mode 100644 diag_manager/fms_diag_time_reduction.F90 create mode 100644 diag_manager/include/fms_diag_fieldbuff_update.fh create mode 100644 diag_manager/include/fms_diag_fieldbuff_update.inc create mode 100644 test_fms/diag_manager/test_diag_update_buffer.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index b1f06a2707..930f37c426 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -124,6 +124,11 @@ list(APPEND fms_fortran_src_files diag_manager/diag_output.F90 diag_manager/diag_table.F90 diag_manager/diag_util.F90 + diag_manager/fms_diag_time_reduction.F90 + diag_manager/fms_diag_outfield.F90 + diag_manager/fms_diag_elem_weight_procs.F90 + diag_manager/fms_diag_fieldbuff_update.F90 + diag_manager/fms_diag_bbox.F90 drifters/cloud_interpolator.F90 drifters/drifters.F90 drifters/drifters_comm.F90 @@ -292,6 +297,7 @@ foreach(kind ${kinds}) fms fms2_io/include mpp/include + diag_manager/include constants4 constants) target_compile_definitions(${libTgt}_f PRIVATE "${fms_defs}") @@ -328,7 +334,8 @@ foreach(kind ${kinds}) $ $ $ - $) + $ + $) target_include_directories(${libTgt} INTERFACE $ diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 295b4e3bb5..37759e838f 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/diag_manager/include -I$(top_srcdir)/diag_manager AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build these uninstalled convenience libraries. @@ -37,15 +37,33 @@ libdiag_manager_la_SOURCES = \ diag_manager.F90 \ diag_output.F90 \ diag_table.F90 \ - diag_util.F90 + diag_util.F90 \ + fms_diag_time_reduction.F90 \ + fms_diag_outfield.F90 \ + fms_diag_elem_weight_procs.F90 \ + fms_diag_fieldbuff_update.F90 \ + fms_diag_bbox.F90 \ + include/fms_diag_fieldbuff_update.inc \ + include/fms_diag_fieldbuff_update.fh # Some mods are dependant on other mods in this dir. +diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) -diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) +diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) \ + diag_grid_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) +fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) +fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) +fms_diag_elem_weight_procs_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) +fms_diag_outfield_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) +fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_elem_weight_procs_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ - diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) + diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ + fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_fieldbuff_update_mod.$(FC_MODEXT) + # Mod files are built and then installed as headers. MODFILES = \ @@ -55,8 +73,16 @@ MODFILES = \ diag_output_mod.$(FC_MODEXT) \ diag_util_mod.$(FC_MODEXT) \ diag_table_mod.$(FC_MODEXT) \ - diag_manager_mod.$(FC_MODEXT) -nodist_include_HEADERS = $(MODFILES) + fms_diag_time_reduction_mod.$(FC_MODEXT) \ + fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_bbox_mod.$(FC_MODEXT) \ + fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ + fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \ + diag_manager_mod.$(FC_MODEXT) \ + include/fms_diag_fieldbuff_update.inc \ + include/fms_diag_fieldbuff_update.fh + + nodist_include_HEADERS = $(MODFILES) BUILT_SOURCES = $(MODFILES) include $(top_srcdir)/mkmods.mk diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index 486930940d..a1f5947098 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -51,6 +51,8 @@ MODULE diag_data_mod USE time_manager_mod, ONLY: time_type USE mpp_domains_mod, ONLY: domain1d, domain2d, domainUG USE fms_mod, ONLY: WARNING, write_version_number + USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type + #ifdef use_netCDF ! NF90_FILL_REAL has value of 9.9692099683868690e+36. USE netcdf, ONLY: NF_FILL_REAL => NF90_FILL_REAL @@ -115,6 +117,8 @@ MODULE diag_data_mod INTEGER, allocatable, DIMENSION(:) :: iatt !< INTEGER array to hold value of INTEGER attributes END TYPE diag_atttype + !!TODO: coord_type deserves a better name, like coord_interval_type or coord_bbox_type. + !! additionally, consider using a 2D array. !> @brief Define the region for field output !> @ingroup diag_data_mod TYPE coord_type @@ -240,7 +244,7 @@ MODULE diag_data_mod TYPE(diag_grid) :: output_grid LOGICAL :: local_output, need_compute, phys_window, written_once LOGICAL :: reduced_k_range - INTEGER :: imin, imax, jmin, jmax, kmin, kmax + TYPE(fmsDiagIbounds_type) :: buff_bounds TYPE(time_type) :: Time_of_prev_field_data TYPE(diag_atttype), allocatable, dimension(:) :: attributes INTEGER :: num_attributes @@ -327,6 +331,7 @@ MODULE diag_data_mod !! .TRUE. is only supported if the diag_manager_init !! routine is called with the optional time_init parameter. LOGICAL :: use_mpp_io = .false. !< false is fms2_io (default); true is mpp_io + LOGICAL :: use_refactored_send = .false. !< Namelist flag to use refactored send_data math funcitons. ! @@ -384,6 +389,8 @@ SUBROUTINE diag_data_init() call write_version_number("DIAG_DATA_MOD", version) END SUBROUTINE diag_data_init + + END MODULE diag_data_mod !> @} ! close documentation grouping diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 50ecb81eab..e78ee3e6f9 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -230,12 +230,15 @@ MODULE diag_manager_mod & use_cmor, issue_oor_warnings, oor_warnings_fatal, oor_warning, pack_size,& & max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes, output_field_type,& & max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time, diag_data_init,& - & use_mpp_io + & use_mpp_io, use_refactored_send USE diag_data_mod, ONLY: fileobj, fileobjU, fnum_for_domain, fileobjND USE diag_table_mod, ONLY: parse_diag_table USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end USE constants_mod, ONLY: SECONDS_PER_DAY + USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type + USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_missvals, & + & fieldbuff_copy_fieldvals #ifdef use_netCDF USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR @@ -1451,8 +1454,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CLASS(*), INTENT(in), OPTIONAL :: weight TYPE (time_type), INTENT(in), OPTIONAL :: time INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in - LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask - CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask + LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL, contiguous, target :: mask + CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg REAL :: weight1 @@ -1488,6 +1491,16 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field + REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 !< A pointer to r4 type of rmask + REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 ! null() + rmask_ptr_r8 => null() IF ( PRESENT(rmask) ) THEN SELECT TYPE (rmask) TYPE IS (real(kind=r4_kind)) WHERE ( rmask < 0.5_r4_kind ) oor_mask = .FALSE. + rmask_threshold = 0.5_r4_kind + rmask_ptr_r4 => rmask TYPE IS (real(kind=r8_kind)) WHERE ( rmask < 0.5_r8_kind ) oor_mask = .FALSE. + rmask_threshold = 0.5_r8_kind + rmask_ptr_r8 => rmask CLASS DEFAULT CALL error_mesg ('diag_manager_mod::send_data_3d',& & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -1876,6 +1895,85 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END IF END IF + IF (USE_REFACTORED_SEND) THEN + ALLOCATE( ofield_index_cfg ) + CALL ofield_index_cfg%initialize( is, js, ks, ie, je, ke, & + & hi, hj, f1, f2, f3, f4) + + ALLOCATE( ofield_cfg ) + CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num), PRESENT(mask), freq) + + IF ( average ) THEN + !!TODO (Future work): the copy that is filed_out should not be necessary + mf_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, & + & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,& + & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), & + & mask, weight1 ,missvalue, & + & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,& + & input_fields(diag_field_id)%issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local ) + IF (mf_result .eqv. .FALSE.) THEN + DEALLOCATE(ofield_index_cfg) + DEALLOCATE(ofield_cfg) + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + ELSE !!NOT AVERAGE + mf_result = fieldbuff_copy_fieldvals(ofield_cfg, ofield_index_cfg, field_out, sample, & + & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , & + & output_fields(out_num)%count_0d(sample), & + & mask, missvalue, l_start, l_end, err_msg, err_msg_local) + IF (mf_result .eqv. .FALSE.) THEN + DEALLOCATE(ofield_index_cfg) + DEALLOCATE(ofield_cfg) + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + + IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN + CALL check_bounds_are_exact_static(out_num, diag_field_id, err_msg=err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg)) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + END IF + + !!TODO: (Discusssion) One of the calls below will not compile depending + !! on the value of REAL. This is to the mixed use of REAL, R4, R8 and CLASS(*) + !! in send_data_3d. A copy of rmask can be made to avoid but it would be wasteful. + !! The option used for now is that the original code to copy missing values is + !! is used at the end of this procedure. + !IF ( PRESENT(rmask) .AND. missvalue_present ) THEN + ! SELECT TYPE (rmask) + ! TYPE IS (real(kind=r4_kind)) + ! call fieldbuff_copy_missvals(ofield_cfg, ofield_index_cfg, & + ! & output_fields(out_num)%buffer, sample, & + ! & l_start, l_end, rmask_ptr_r4, rmask_threshold, missvalue) + ! TYPE IS (real(kind=r8_kind)) + ! call fieldbuff_copy_missvals(ofield_cfg, ofield_index_cfg, & + ! & output_fields(out_num)%buffer, sample, & + ! & l_start, l_end, rmask_ptr_r8, rmask_threshold, missvalue) + ! CLASS DEFAULT + ! CALL error_mesg ('diag_manager_mod::send_data_3d',& + ! & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + ! END SELECT + !END IF + + IF(ALLOCATED(ofield_index_cfg)) THEN + DEALLOCATE(ofield_index_cfg) + ENDIF + IF(ALLOCATED(ofield_cfg)) THEN + DEALLOCATE(ofield_cfg) + ENDIF + + ELSE !! END USE_REFACTORED_SEND; Don''t use CYCLE option. + ! Take care of submitted field data IF ( average ) THEN IF ( input_fields(diag_field_id)%mask_variant ) THEN @@ -3022,6 +3120,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END IF END IF + END IF !! END OF IS_USE_REFACTORED SEND + ! If rmask and missing value present, then insert missing value IF ( PRESENT(rmask) .AND. missvalue_present ) THEN IF ( need_compute ) THEN @@ -3661,7 +3761,8 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,& & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,& & oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,& - & max_file_attributes, max_axis_attributes, prepend_date, use_mpp_io, field_log_separator + & max_file_attributes, max_axis_attributes, prepend_date, use_mpp_io, field_log_separator,& + & use_refactored_send ! If the module was already initialized do nothing IF ( module_is_initialized ) RETURN diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 4ee31b21e5..9956c2d9c4 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -71,17 +71,20 @@ MODULE diag_util_mod USE mpp_mod, ONLY: mpp_npes USE constants_mod, ONLY: SECONDS_PER_DAY, SECONDS_PER_HOUR, SECONDS_PER_MINUTE USE fms2_io_mod + USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type #ifdef use_netCDF USE netcdf, ONLY: NF90_CHAR #endif IMPLICIT NONE PRIVATE - PUBLIC get_subfield_size, log_diag_field_info, update_bounds, check_out_of_bounds,& - & check_bounds_are_exact_dynamic, check_bounds_are_exact_static, init_file, diag_time_inc,& + PUBLIC get_subfield_size, log_diag_field_info, init_file, diag_time_inc,& & find_input_field, init_input_field, init_output_field, diag_data_out, write_static,& & check_duplicate_output_fields, get_date_dif, get_subfield_vert_size, sync_file_times,& - & prepend_attribute, attribute_init, diag_util_init + & prepend_attribute, attribute_init, diag_util_init,& + & update_bounds, check_out_of_bounds, check_bounds_are_exact_dynamic, check_bounds_are_exact_static,& + & fms_diag_check_out_of_bounds, & + & fms_diag_check_bounds_are_exact_dynamic, fms_diag_check_bounds_are_exact_static !> @brief Prepend a value to a string attribute in the output field or output file. @@ -98,9 +101,14 @@ MODULE diag_util_mod MODULE PROCEDURE attribute_init_file END INTERFACE attribute_init + INTERFACE fms_diag_check_out_of_bounds + module procedure fms_diag_check_out_of_bounds_r4 + module procedure fms_diag_check_out_of_bounds_r8 + END INTERFACE fms_diag_check_out_of_bounds + + !> @addtogroup diag_util_mod !> @{ - ! Include variable "version" to be written to log file. #include @@ -731,7 +739,10 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& & TRIM(axes_list) END SUBROUTINE log_diag_field_info - !> @brief Update the output_fields x, y, and z min and max boundaries (array indices). + + + !> @brief Update the output_fields x, y, and z min and max boundaries (array indices) + !! with the six specified bounds values. SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) INTEGER, INTENT(in) :: out_num !< output field ID INTEGER, INTENT(in) :: lower_i !< Lower i bound. @@ -740,173 +751,312 @@ SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, u INTEGER, INTENT(in) :: upper_j !< Upper j bound. INTEGER, INTENT(in) :: lower_k !< Lower k bound. INTEGER, INTENT(in) :: upper_k !< Upper k bound. - - output_fields(out_num)%imin = MIN(output_fields(out_num)%imin, lower_i) - output_fields(out_num)%imax = MAX(output_fields(out_num)%imax, upper_i) - output_fields(out_num)%jmin = MIN(output_fields(out_num)%jmin, lower_j) - output_fields(out_num)%jmax = MAX(output_fields(out_num)%jmax, upper_j) - output_fields(out_num)%kmin = MIN(output_fields(out_num)%kmin, lower_k) - output_fields(out_num)%kmax = MAX(output_fields(out_num)%kmax, upper_k) + CALL output_fields(out_num)%buff_bounds%update_bounds & + & ( lower_i, upper_i, lower_j, upper_j, lower_k, upper_k ) END SUBROUTINE update_bounds - !> @brief Checks if the array indices for output_fields(out_num) are outside the - !! output_fields(out_num)%buffer upper - !! and lower bounds. - SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg) - INTEGER, INTENT(in) :: out_num !< Output field ID number. - INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty - !! error string indicates the x, y, and z indices are not outside the - !! buffer array boundaries. - - CHARACTER(len=128) :: error_string1, error_string2 - - IF ( output_fields(out_num)%imin < LBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%imax > UBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%jmin < LBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%jmax > UBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%kmin < LBOUND(output_fields(out_num)%buffer,3) .OR.& - & output_fields(out_num)%kmax > UBOUND(output_fields(out_num)%buffer,3) ) THEN - WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),& - & TRIM(output_fields(out_num)%output_name) - error_string2 ='Buffer bounds= : , : , : Actual bounds= : , : , : ' - WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin - WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax - WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin - WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax - WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin - WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax - err_msg = 'module/output_field='//TRIM(error_string1)//& - & ' Bounds of buffer exceeded. '//TRIM(error_string2) - ! imax, imin, etc need to be reset in case the program is not terminated. - output_fields(out_num)%imax = 0 - output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%jmax = 0 - output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%kmax = 0 - output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH - ELSE - err_msg = '' - END IF - - END SUBROUTINE check_out_of_bounds - !> @brief Check if the array indices for output_fields(out_num) are equal to the - !! output_fields(out_num)%buffer - !! upper and lower bounds. - SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg) - INTEGER, INTENT(in) :: out_num !< Output field ID number. - INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. - TYPE(time_type), INTENT(in) :: Time !< Time to use in check. The check is only performed if - !! output_fields(out_num)%Time_of_prev_field_data is not - !! equal to Time or Time_zero. - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. - !! An empty error string indicates the x, y, and z indices are - !! equal to the buffer array boundaries. - CHARACTER(len=128) :: error_string1, error_string2 - LOGICAL :: do_check + !> @brief Compares the bounding indices of an array specified in "current_bounds" +!! to the corresponding lower and upper bounds specified in "bounds" +!! Comparison is done by the two user specified input functions lowerb_comp and upperb_comp. +!! If any compariosn function returns true, then, after filling error_str, this routine also returns +!! true. The suplied comparison functions should return true for errors : for indices out of bounds, +!! or indices are not equal when expected to be equal. +LOGICAL FUNCTION compare_buffer_bounds_to_size(current_bounds, bounds, error_str, lowerb_comp, upperb_comp) + TYPE (fmsDiagIbounds_type), INTENT(in) :: current_bounds ! @brief Interface lowerb_comp should be used for comparison to lower bounds of buffer. + INTERFACE + LOGICAL FUNCTION lowerb_comp(a , b) + INTEGER, INTENT(IN) :: a !< One of the two args that are to be compared to each other. + INTEGER, INTENT(IN) :: b !< One of the two args that are to be compared to each other. + END FUNCTION lowerb_comp + END INTERFACE + + !> @brief Interface lowerb_comp should be used for comparison to upper bounds of buffer. + INTERFACE + LOGICAL FUNCTION upperb_comp(a, b) + INTEGER, INTENT(IN) :: a !< One of the two args that are to be compared to each other. + INTEGER, INTENT(IN) :: b !< One of the two args that are to be compared to each other. + END FUNCTION upperb_comp + END INTERFACE + + compare_buffer_bounds_to_size = .FALSE. + + IF (lowerb_comp( bounds%get_imin() , current_bounds%get_imin()) .OR. & + upperb_comp( bounds%get_imax() , current_bounds%get_imax()).OR.& + lowerb_comp( bounds%get_jmin() , current_bounds%get_jmin()) .OR.& + upperb_comp( bounds%get_jmax() , current_bounds%get_jmax()) .OR.& + lowerb_comp( bounds%get_kmin() , current_bounds%get_kmin()) .OR.& + upperb_comp( bounds%get_kmax() , current_bounds%get_kmax())) THEN + compare_buffer_bounds_to_size = .TRUE. + error_str ='Buffer bounds= : , : , : Actual bounds= : , : , : ' + WRITE(error_str(15:17),'(i3)') current_bounds%get_imin() + WRITE(error_str(19:21),'(i3)') current_bounds%get_imax() + WRITE(error_str(23:25),'(i3)') current_bounds%get_jmin() + WRITE(error_str(27:29),'(i3)') current_bounds%get_jmax() + WRITE(error_str(31:33),'(i3)') current_bounds%get_kmin() + WRITE(error_str(35:37),'(i3)') current_bounds%get_kmax() + WRITE(error_str(54:56),'(i3)') bounds%get_imin() + WRITE(error_str(58:60),'(i3)') bounds%get_imax() + WRITE(error_str(62:64),'(i3)') bounds%get_jmin() + WRITE(error_str(66:68),'(i3)') bounds%get_jmax() + WRITE(error_str(70:72),'(i3)') bounds%get_kmin() + WRITE(error_str(74:76),'(i3)') bounds%get_kmax() + ELSE + compare_buffer_bounds_to_size = .FALSE. + error_str = '' + END IF +END FUNCTION compare_buffer_bounds_to_size + +!> @brief return true iff a @brief return true iff a>b. +LOGICAL FUNCTION a_greaterthan_b(a, b) + INTEGER, INTENT(IN) :: a !< The first of the two integer args that are to be compared to each other. + INTEGER, INTENT(IN) :: b !< The first of the two integer args that are to be compared to each other. + a_greaterthan_b = A > B +END FUNCTION a_greaterthan_b + +!> @brief return true iff a /= b +LOGICAL FUNCTION a_noteq_b(a, b) +INTEGER, INTENT(IN) :: a !< The first of the two integer args that are to be compared to each other. +INTEGER, INTENT(IN) :: b !< The first of the two integer args that are to be compared to each other. +a_noteq_b = a /= b +END FUNCTION a_noteq_b - err_msg = '' - - ! Check bounds only when the value of Time changes. When windows are used, - ! a change in Time indicates that a new loop through the windows has begun, - ! so a check of the previous loop can be done. - IF ( Time == output_fields(out_num)%Time_of_prev_field_data ) THEN - do_check = .FALSE. + !> @brief Checks if the array indices for output_fields(out_num) are outside the + !! output_fields(out_num)%buffer upper and lower bounds. + !! If there is an error then error message will be filled. +SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg) + INTEGER, INTENT(in) :: out_num !< Output field ID number. + INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty + !! error string indicates the x, y, and z indices are not outside the + + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: out_of_bounds = .true. + TYPE (fmsDiagIbounds_type) :: array_bounds + associate (buff_bounds => output_fields(out_num)%buff_bounds) + + CALL array_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer) + + out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, & + & error_string2, a_lessthan_b, a_greaterthan_b) + + IF (out_of_bounds .EQV. .true.) THEN + WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name), & + & TRIM(output_fields(out_num)%output_name) + err_msg = 'module/output_field='//TRIM(error_string1)//& + & ' Bounds of buffer exceeded. '//TRIM(error_string2) + ! imax, imin, etc need to be reset in case the program is not terminated. + call buff_bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) ELSE - IF ( output_fields(out_num)%Time_of_prev_field_data == Time_zero ) THEN - ! It may or may not be OK to check, I don't know how to tell. - ! Check will be done on subsequent calls anyway. - do_check = .FALSE. - ELSE - do_check = .TRUE. - END IF - output_fields(out_num)%Time_of_prev_field_data = Time - END IF - - IF ( do_check ) THEN - IF ( output_fields(out_num)%imin /= LBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%imax /= UBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%jmin /= LBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%jmax /= UBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%kmin /= LBOUND(output_fields(out_num)%buffer,3) .OR.& - & output_fields(out_num)%kmax /= UBOUND(output_fields(out_num)%buffer,3) ) THEN - WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),& - & TRIM(output_fields(out_num)%output_name) - error_string2 ='Buffer bounds= : , : , : Actual bounds= : , : , : ' - WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin - WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax - WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin - WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax - WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin - WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax - err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2) - END IF - output_fields(out_num)%imax = 0 - output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%jmax = 0 - output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%kmax = 0 - output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH - END IF - END SUBROUTINE check_bounds_are_exact_dynamic + err_msg = '' + END IF + end associate +END SUBROUTINE check_out_of_bounds + + !> @brief Checks if the array indices for output_fields(out_num) are outside the + !! output_fields(out_num)%buffer upper and lower bounds. + !! If there is an error then error message will be filled. +SUBROUTINE fms_diag_check_out_of_bounds_r4(ofb, bounds, output_name, module_name, err_msg) + REAL(kind=r4_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check + TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The bounding box to check against + CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message + CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_out_of_bounds. An empty + !! error string indicates the x, y, and z indices are not outside the + + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: out_of_bounds = .true. + TYPE (fmsDiagIbounds_type) :: array_bounds + + CALL array_bounds%reset_bounds_from_array_5D(ofb) + + out_of_bounds = compare_buffer_bounds_to_size(array_bounds, bounds, & + & error_string2, a_lessthan_b, a_greaterthan_b) + + IF (out_of_bounds .EQV. .true.) THEN + WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + err_msg = 'module/output_field='//TRIM(error_string1)//& + & ' Bounds of buffer exceeded. '//TRIM(error_string2) + ! imax, imin, etc need to be reset in case the program is not terminated. + call bounds%reset(VERY_LARGE_AXIS_LENGTH,0) + ELSE + err_msg = '' + END IF +END SUBROUTINE fms_diag_check_out_of_bounds_r4 + + !> @brief Checks if the array indices for output_field buffer (ofb) are outside the + !! are outside the bounding box (bounds). + !! If there is an error then error message will be filled. + +SUBROUTINE fms_diag_check_out_of_bounds_r8(ofb, bounds, output_name, module_name, err_msg) + REAL(kind=r8_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check + TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The bounding box to check against + CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty + !! error string indicates the x, y, and z indices are not outside the + + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: out_of_bounds = .true. + TYPE (fmsDiagIbounds_type) :: array_bounds ! @brief Checks that array indices specified in the bounding box "current_bounds" +!! are identical to those in the bounding box "bounds" match exactly. The check +!! occurs only when the time changed. +!! If there is an error then error message will be filled. +SUBROUTINE fms_diag_check_bounds_are_exact_dynamic(current_bounds, bounds, output_name, module_name, & + & Time, field_prev_Time, err_msg) + TYPE (fmsDiagIbounds_type), INTENT(in) :: current_bounds !output_fields(out_num)%Time_of_prev_field_data is not + !! equal to Time or Time_zero. + TYPE(time_type), INTENT(inout) :: field_prev_Time !< output_fields(out_num)%Time_of_prev_field_data + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. + !! An empty error string indicates the x, y, and z indices are + !! equal to the buffer array boundaries. + + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: do_check + LOGICAL :: lims_not_exact + + err_msg = '' + + ! Check bounds only when the value of Time changes. When windows are used, + ! a change in Time indicates that a new loop through the windows has begun, + ! so a check of the previous loop can be done. + IF ( Time == field_prev_Time ) THEN + do_check = .FALSE. + ELSE + IF ( field_prev_Time == Time_zero ) THEN + ! It may or may not be OK to check, I don't know how to tell. + ! Check will be done on subsequent calls anyway. + do_check = .FALSE. + ELSE + do_check = .TRUE. + END IF + field_prev_Time = Time + END IF + + IF ( do_check ) THEN + lims_not_exact = compare_buffer_bounds_to_size(current_bounds, bounds, & + & error_string2, a_noteq_b, a_noteq_b) + IF( lims_not_exact .eqv. .TRUE.) THEN + WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2) + END IF + call bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) + END IF +END SUBROUTINE fms_diag_check_bounds_are_exact_dynamic + + +!> @brief This is an adaptor to the check_bounds_are_exact_dynamic_modern function to +!! maintain an interface servicing the legacy diag_manager. +SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg) + INTEGER, INTENT(in) :: out_num !< Output field ID number. + INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. + TYPE(time_type), INTENT(in) :: Time !< Time to use in check. The check is only performed if + !! output_fields(out_num)%Time_of_prev_field_data is not + !! equal to Time or Time_zero. + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. + !! An empty error string indicates the x, y, and z indices are + !! equal to the buffer array boundaries. + CHARACTER(:), ALLOCATABLE :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE :: module_name !< module name for placing in error message + TYPE (fmsDiagIbounds_type) :: current_bounds !< a bounding box to store the current bounds of the array. + + output_name = output_fields(out_num)%output_name + module_name = input_fields(diag_field_id)%module_name + + CALL current_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer) + + CALL fms_diag_check_bounds_are_exact_dynamic(current_bounds, output_fields(out_num)%buff_bounds, & + & output_name, module_name, & + & Time, output_fields(out_num)%Time_of_prev_field_data, err_msg) + +END SUBROUTINE check_bounds_are_exact_dynamic + !> @brief Check if the array indices for output_fields(out_num) are equal to the - !! output_fields(out_num)%buffer - !! upper and lower bounds. + !! output_fields(out_num)%buffer upper and lower bounds. SUBROUTINE check_bounds_are_exact_static(out_num, diag_field_id, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID INTEGER, INTENT(in) :: diag_field_id !< Input field ID. - CHARACTER(len=*), INTENT(out) :: err_msg + CHARACTER(len=*), INTENT(out) :: err_msg !< The return status, which is set to non-empty message + !! if the check fails. + CHARACTER(:), ALLOCATABLE :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE :: module_name !< output name for placing in error message + TYPE (fmsDiagIbounds_type) :: current_bounds !< a bounding box to store the current bounds of the array. + + output_name = output_fields(out_num)%output_name + module_name = input_fields(diag_field_id)%module_name + + CALL current_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer) + + CALL fms_diag_check_bounds_are_exact_static(current_bounds, output_fields(out_num)%buff_bounds, & + & output_name, module_name, err_msg) + END SUBROUTINE check_bounds_are_exact_static + + + !> @brief Check if the array indices specified in the bounding box "current_bounds" are equal to those + !! specified in the bounding box "bounds" output_fields are equal to the buffer upper and lower bounds. + !! If there is an error then error message will be filled. + SUBROUTINE fms_diag_check_bounds_are_exact_static(current_bounds, bounds, output_name, module_name, err_msg) + TYPE (fmsDiagIbounds_type), INTENT(in) :: current_bounds ! @brief Initialize the output file. SUBROUTINE init_file(name, output_freq, output_units, format, time_units, long_name, tile_count,& @@ -1391,12 +1541,8 @@ SUBROUTINE init_output_field(module_name, field_name, output_name, output_file,& output_fields(out_num)%num_axes = 0 output_fields(out_num)%total_elements = 0 output_fields(out_num)%region_elements = 0 - output_fields(out_num)%imax = 0 - output_fields(out_num)%jmax = 0 - output_fields(out_num)%kmax = 0 - output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH + + call output_fields(out_num)%buff_bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) ! initialize the size of the diurnal axis to 1 output_fields(out_num)%n_diurnal_samples = 1 diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 new file mode 100644 index 0000000000..7fa331258a --- /dev/null +++ b/diag_manager/fms_diag_bbox.F90 @@ -0,0 +1,167 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_bbox_mod fms_diag_bbox_mod +!> @ingroup diag_manager +!> @brief fms_diag_bbox_mod defines classes encapsulating bounding boxes +!! and interval bounds. +!! +!> @author Miguel Zuniga +!! +!> @file +!> @brief File for @ref fms_diag_bbox_mod +!> @addtogroup fms_diag_bbox_mod +!> @{ +MODULE fms_diag_bbox_mod + + USE fms_mod, ONLY: error_mesg, FATAL + + implicit none + +!> @brief Data structure holding a 3D bounding box. It is commonlyused to +!! represent the interval bounds or limits of a 3D sub-array such as the +!! array index bounds of the spatial component a diag_manager field output +!! buffer array. + TYPE, public :: fmsDiagIbounds_type + PRIVATE + INTEGER :: imin !< Lower i bound. + INTEGER :: imax !< Upper i bound. + INTEGER :: jmin !< Lower j bound. + INTEGER :: jmax !< Upper j bound. + INTEGER :: kmin !< Lower k bound. + INTEGER :: kmax !< Upper k bound. + contains + procedure :: reset => reset_bounds + procedure :: reset_bounds_from_array_4D + procedure :: reset_bounds_from_array_5D + procedure :: update_bounds + procedure :: get_imin + procedure :: get_imax + procedure :: get_jmin + procedure :: get_jmax + procedure :: get_kmin + procedure :: get_kmax + END TYPE fmsDiagIbounds_type + +CONTAINS + + !> @brief Gets imin of fmsDiagIbounds_type + !! @return copy of integer member imin + pure integer function get_imin (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%imin + end function get_imin + + !> @brief Gets imax of fmsDiagIbounds_type + !! @return copy of integer member imax + pure integer function get_imax (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%imax + end function get_imax + + !> @brief Gets jmin of fmsDiagIbounds_type + !! @return copy of integer member jmin + pure integer function get_jmin (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%jmin + end function get_jmin + + !> @brief Gets jmax of fmsDiagIbounds_type + !! @return copy of integer member jmax + pure integer function get_jmax (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%jmax + end function get_jmax + + + !> @brief Gets kmin of fmsDiagIbounds_type + !! @return copy of integer member kmin + pure integer function get_kmin (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%kmin + end function get_kmin + + !> @brief Gets kmax of fmsDiagIbounds_type + !! @return copy of integer member kmax + pure integer function get_kmax (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%kmax + end function get_kmax + + !> @brief Reset the instance bounding lower and upper bounds to lower_val and upper_val, respectively. + SUBROUTINE reset_bounds (this, lower_val, upper_val) + class (fmsDiagIbounds_type), target, intent(inout) :: this !< ibounds instance + integer, intent(in) :: lower_val !< value for the lower bounds in each dimension + integer, intent(in) :: upper_val !< value for the upper bounds in each dimension + this%imin = lower_val + this%jmin = lower_val + this%kmin = lower_val + this%imax = upper_val + this%jmax = upper_val + this%kmax = upper_val + END SUBROUTINE reset_bounds + + !> @brief Update the the first three (normally x, y, and z) min and + !! max boundaries (array indices) of the instance bounding box + !! the six specified bounds values. + SUBROUTINE update_bounds(this, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) + CLASS (fmsDiagIbounds_type), intent(inout) :: this ! @brief Reset the instance bounding box with the bounds determined from the + !! first three dimensions of the 5D "array" argument + SUBROUTINE reset_bounds_from_array_4D(this, array) + CLASS (fmsDiagIbounds_type), INTENT(inout) :: this !< The instance of the bounding box. + REAL, INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array. + this%imin = LBOUND(array,1) + this%imax = UBOUND(array,1) + this%jmin = LBOUND(array,2) + this%jmax = UBOUND(array,2) + this%kmin = LBOUND(array,3) + this%kmax = UBOUND(array,3) + END SUBROUTINE reset_bounds_from_array_4D + + !> @brief Reset the instance bounding box with the bounds determined from the + !! first three dimensions of the 5D "array" argument + SUBROUTINE reset_bounds_from_array_5D(this, array) + CLASS (fmsDiagIbounds_type), INTENT(inout) :: this !< The instance of the bounding box. + CLASS(*), INTENT( in), DIMENSION(:,:,:,:,:) :: array !< The 5D input array. + this%imin = LBOUND(array,1) + this%imax = UBOUND(array,1) + this%jmin = LBOUND(array,2) + this%jmax = UBOUND(array,2) + this%kmin = LBOUND(array,3) + this%kmax = UBOUND(array,3) + END SUBROUTINE reset_bounds_from_array_5D + + END MODULE fms_diag_bbox_mod + !> @} + ! close documentation grouping diff --git a/diag_manager/fms_diag_elem_weight_procs.F90 b/diag_manager/fms_diag_elem_weight_procs.F90 new file mode 100644 index 0000000000..0a07d47327 --- /dev/null +++ b/diag_manager/fms_diag_elem_weight_procs.F90 @@ -0,0 +1,136 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_elem_weight_procs_mod fms_diag_elem_weight_procs_mod +!> @ingroup diag_manager +!> @brief fms_diag_elem_weight_procs_mod Contains elemental functions for uddating +!! one element of a buffer array with field data. +!! +!> @author Miguel Zuniga +!! +!! fms_diag_elem_weight_procs_mod Contains elemental functions for uddating +!! one element of a buffer array with field data, +!! +!> @file +!> @brief File for @ref fms_diag_elem_weight_procs_mod +!> @addtogroup fms_diag_elem_weight_procs_mod +!> @{ +MODULE fms_diag_elem_weight_procs_mod + USE platform_mod + + implicit none + + !> @brief Interface for the elemental function addwf, which + !! Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !> @ingroup fms_diag_elem_weight_procs_mod + INTERFACE addwf + module procedure addwf_r4 + module procedure addwf_r8 + module procedure addwf_i4 + module procedure addwf_i8 + END INTERFACE + +CONTAINS + + !!TODO: Note that in the functions below, the case for pow_value == 2 was + !! not in the original send_data_3d code and the power function was used. + !! So this case may need to be deleted if reproducability is an issue. + + !!TODO: (MDM) Discuss whether or not the pow_value should be allowed to + !! also be real though legacy interface has it satic. + + !> @brief Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !! Special cases when pow_value is equal to 1 or 2 do not explicitly use the power function. + ELEMENTAL REAL(r4_kind) FUNCTION addwf_r4(buff, field, weight, pow_value ) + REAL(r4_kind), INTENT(in) :: buff !< The buffer cell (point) value + REAL(r4_kind), INTENT(IN) :: field !< The field value + REAL(r4_kind), INTENT(IN) :: weight !< The weight factor for the field + INTEGER, INTENT(IN) :: pow_value !< The power value for the power function + + SELECT CASE(pow_value) + CASE (1) + addwf_r4 = buff + weight * field + CASE (2) + addwf_r4 = buff + (weight * field) * (weight * field) + CASE default + addwf_r4 = buff + (weight * field) ** pow_value + END SELECT + END FUNCTION addwf_r4 + + !> @brief Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !! Special cases when pow_value is equal to 1 or 2 do not explicitly use the power function. + ELEMENTAL REAL(r8_kind) FUNCTION addwf_r8(buff, field, weight, pow_value ) + REAL(r8_kind), INTENT(in) :: buff !< The buffer cell (point) value + REAL(r8_kind) ,INTENT(IN) :: field !< The field value + REAL(r8_kind), INTENT(IN) :: weight !< The weight factor for the field + INTEGER, INTENT(IN) :: pow_value !< The power value for the power function + + SELECT CASE(pow_value) + CASE (1) + addwf_r8 = buff + weight * field + CASE (2) + addwf_r8 = buff + (weight * field) * (weight * field) + CASE default + addwf_r8 = buff + (weight * field) ** pow_value + END SELECT + END FUNCTION addwf_r8 + + !> @brief Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !! Special cases when pow_value is equal to 1 or 2 do not explicitly use the power function. + ELEMENTAL INTEGER(i4_kind) FUNCTION addwf_i4(buff, field, weight, pow_value ) + INTEGER(i4_kind), INTENT(in) :: buff !< The buffer cell (point) value + INTEGER(i4_kind), INTENT(IN) :: field !< The field value + INTEGER, INTENT(IN) :: weight !< The weight factor for the field + INTEGER, INTENT(IN) :: pow_value !< The power value for the power function + SELECT CASE(pow_value) + CASE (1) + addwf_i4 = buff + weight * field + CASE (2) + addwf_i4 = buff + (weight * field) * (weight * field) + CASE default + addwf_i4 = buff + (weight * field) ** pow_value + END SELECT + END FUNCTION addwf_i4 + + !> @brief Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !! Special cases when pow_value is equal to 1 or 2 do not explicitly use the power function. + ELEMENTAL INTEGER(i8_kind) FUNCTION addwf_i8(buff, field, weight, pow_value ) + INTEGER(i8_kind), INTENT(in) :: buff !< The buffer cell (point) value + INTEGER(i8_kind) ,INTENT(IN) :: field !< The field value + INTEGER, INTENT(IN) :: weight !< The weight factor for the field + INTEGER, INTENT(IN) :: pow_value !< The power value for the power function + + SELECT CASE(pow_value) + CASE (1) + addwf_i8 = buff + weight * field + CASE (2) + addwf_i8 = buff + (weight * field) * (weight * field) + CASE default + addwf_i8 = buff + (weight * field) ** pow_value + END SELECT + END FUNCTION addwf_i8 +END MODULE fms_diag_elem_weight_procs_mod +!> @} +! close documentation grouping + diff --git a/diag_manager/fms_diag_fieldbuff_update.F90 b/diag_manager/fms_diag_fieldbuff_update.F90 new file mode 100644 index 0000000000..0e3783dcef --- /dev/null +++ b/diag_manager/fms_diag_fieldbuff_update.F90 @@ -0,0 +1,110 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_fieldbuff_update_mod fms_diag_fieldbuff_update_mod +!> @ingroup diag_manager +!> @brief fms_diag_fieldbuff_update_mod Contains routines for updating the +!! buffer (array) of field data statistics (e.g. average, rms) with new field data. +!! +!> @author Miguel Zuniga +!! +!! fms_diag_fieldbuff_update_mod contains routines for updating the buffer +!!(array) of field data statistics (e.g. average, rms) with new field data. These +!! routines are called by the send_data routines in the diag_manager. +!! +!> @file +!> @brief File for @ref fms_diag_fieldbuff_update_mod +!> @addtogroup fms_diag_fieldbuff_update_mod +!> @{ +MODULE fms_diag_fieldbuff_update_mod + USE platform_mod + USE mpp_mod, ONLY: mpp_pe, mpp_root_pe + USE time_manager_mod, ONLY: time_type + USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdout, stdlog, write_version_number,fms_error_handler + USE diag_data_mod, ONLY: debug_diag_manager + USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type + USE diag_util_mod, ONLY: fms_diag_check_out_of_bounds + USE fms_diag_time_reduction_mod, ONLY: fmsDiagTimeReduction_type + USE fms_diag_elem_weight_procs_mod, ONLY: addwf + USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type + + implicit none + + !!TODO: (MDM) Remove commented integer versions. + + !> @brief Interface fieldbuff_update updates elements of field output buffer based on input field + !! data and mathematical operations on the field data. + !> @ingroup fms_diag_fieldbuff_update_mod + interface fieldbuff_update + !< r4 version of the interface + module procedure fieldbuff_update_r4 + !< r8 version of the interface + module procedure fieldbuff_update_r8 + !< r4 version of the interface, where the field is 3D + module procedure fieldbuff_update_3d_r4 + !< r8 version of the interface + module procedure fieldbuff_update_3d_r8 + !< i4 version of the interface, , where the field is 3D + !module procedure fieldbuff_update_i4 + !< i8 version of the interface + ! module procedure fieldbuff_update_i8 + end interface + + !> @brief Interface fieldbuff_copy_missvals updates elements of the field output buffer with + !! the missvalue input argument. + !> @ingroup fms_diag_fieldbuff_update_mod + interface fieldbuff_copy_missvals + !< r4 version of the interface + module procedure fieldbuff_copy_missvals_r4 + !< r8 version of the interface + module procedure fieldbuff_copy_missvals_r8 + !< r4 version of the interface, , where the field is 3D + module procedure fieldbuff_copy_missvals_3d_r4 + !< r8 version of the interface, , where the field is 3D + module procedure fieldbuff_copy_missvals_3d_r8 + !< i4 version of the interface + !module procedure fieldbuff_copy_missvals_i4 + !< i8 version of the interface + !module procedure fieldbuff_copy_missvals_i8 + end interface + + !> @brief Interface fieldbuff_copy_fieldvals updates elements of the field output buffer with + !! copies of corresponding element values in the input field data. + !> @ingroup fms_diag_fieldbuff_update_mod + interface fieldbuff_copy_fieldvals + !< r4 version of the interface + module procedure fieldbuff_copy_fieldvals_r4 + !< r8 version of the interface + module procedure fieldbuff_copy_fieldvals_r8 + !< r4 version of the interface, , where the field is 3D + module procedure fieldbuff_copy_fieldvals_3d_r4 + !< r8 version of the interface, , where the field is 3D + module procedure fieldbuff_copy_fieldvals_3d_r8 + !< i4 version of the interface + !module procedure fieldbuff_copy_fieldvals_i4 + !< i8 version of the interface + !module procedure fieldbuff_copy_fieldvals_i8 + end interface +contains + +#include "fms_diag_fieldbuff_update.inc" + +END MODULE fms_diag_fieldbuff_update_mod +!> @} +! close documentation grouping diff --git a/diag_manager/fms_diag_outfield.F90 b/diag_manager/fms_diag_outfield.F90 new file mode 100644 index 0000000000..88c07880cc --- /dev/null +++ b/diag_manager/fms_diag_outfield.F90 @@ -0,0 +1,450 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_outfield_mod fms_diag_outfield_mod +!> @ingroup diag_manager +!> @brief fms_diag_outfield_mod defines data types and utility or auxiliary routines +!! useful in updating the output buffer. +!! +!> @author Miguel Zuniga +!! +!! fms_diag_outfield_mod The output buffer updating routines are passed configuration +!! and control data with types defined in this module; and some utility functions called by the +!! updating routines are +!! defined here. +!! +!> @file +!> @brief File for @ref fms_diag_outfield_mod +!> @addtogroup fms_diag_outfield_mod +!> @{ +MODULE fms_diag_outfield_mod + USE platform_mod + USE mpp_mod, only :FATAL, WARNING + USE fms_mod, only :lowercase, uppercase, error_mesg, fms_error_handler + + + !! TODO: these might need removal or replacement + USE diag_data_mod, only:Time_zero + USE diag_data_mod, only: GLO_REG_VAL, GLO_REG_VAL_ALT, region_out_use_alt_value, VERY_LARGE_AXIS_LENGTH, coord_type + USE diag_data_mod, only: fmsDiagIbounds_type, input_field_type, output_field_type + USE fms_diag_time_reduction_mod, only: fmsDiagTimeReduction_type, time_none , time_average, time_rms + USE fms_diag_time_reduction_mod, only: time_max, time_min, time_sum, time_power + + implicit none + + !> @brief Class fmsDiagOutfield_type (along with class ms_diag_outfield_index_type ) + !! contain information used in updating the output buffers by the diag_manager + !! send_data routines. In some sense they can be seen as encapsulating related + !! information in a convenient way (e.g. to pass to functions and for do loop + !! controls.) + !! + !! Class fmsDiagOutfield_type also contains a significant subset of the fields + !! and routines of of the legacy class output_field_type + !! TODO: (MDM) This class will need further development for the modern_diag effort. + !! For its development, consider the legacy diag_util::init_output_field already + !! in place. Fields added so are used the the field buffer math/dmUpdate functions. + !! TODO (MDM) : Should the MDM have pow_value be type REAL? + !> @ingroup fms_diag_outfield_mod + TYPE, public :: fmsDiagOutfield_type + PRIVATE + CHARACTER(len=:), ALLOCATABLE :: module_name !< Module name. + CHARACTER(len=:), ALLOCATABLE :: field_name !< Output field name. + CHARACTER(len=:), ALLOCATABLE :: output_name !< Output name written to file. + CHARACTER(len=:), ALLOCATABLE :: output_file !< File where field should be written. + + !!Major outer loop controls in send_data functions. + INTEGER :: pow_value !< Power value for rms or pow(x) calculations + LOGICAL :: phys_window !< TODO: Rename? OMP subsetted data, See output_fields + LOGICAL :: need_compute !< True iff is local_output and current PE take part in send_data. + LOGICAL :: reduced_k_range !< If true, the local start and end indecies are used in k (i.e. 3rd) dim. + LOGICAL :: missvalue_present !< + LOGICAL :: mask_variant + LOGICAL :: mask_present !< True iff mask argument is present in user-facing send function call. + !< Note this field exists since the actual mask argument in the send + !< function call may be downstream replaced by a null pointer which + !< is considered present. + + TYPE(fmsDiagTimeReduction_type) :: time_reduction !< Instance of the fmsDiagTimeTeduction_type. + + !!TODO (Future effort? ) : a pointer for time_min and time_max comparison function + !! If possible, this can remove the innermost if/then/else construct in the buffer update loops. + !! min_max_f_ptr => (should point to < or > operators) + + !! gcc error: Interface ‘addwf’ at (1) must be explicit + ! procedure (addwf), pointer, nopass :: f_ptr => null () !!A pointer to the field weighing procedure + + CONTAINS + procedure :: get_module_name + procedure :: get_field_name + procedure :: get_output_name + procedure :: get_output_file + procedure :: get_pow_value + procedure :: get_phys_window + procedure :: get_need_compute + procedure :: get_reduced_k_range + procedure :: get_missvalue_present + procedure :: get_mask_variant + procedure :: get_mask_present + procedure :: get_time_reduction + procedure, public :: initialize => initialize_outfield_imp + procedure :: initialize_for_ut + + END TYPE fmsDiagOutfield_type + + !> @brief Class fms_diag_outfield_index_type which (along with class fmsDiagOutfield_type) + !! encapsulate related information used in updating the output buffers by the diag_manager + !! send_data routines. This class in particular focuses on do loop index controls or settings. + !! Note that the index names in this class should be indentical to the names used in the + !! diag_manager send_data functions and in the "math" buffer update functions. The purpose + !! of this class is also to allow for a smaller call function signature for the math/buffer + !! update functions. + !> @ingroup fms_diag_outfield_mod + TYPE, public :: fmsDiagOutfieldIndex_type + PRIVATE + INTEGER :: f1,f2 !< Indecies used specify 1st dim bounds of field, mask and rmask. + INTEGER :: f3,f4 !< Indecies used specify 2st dim bounds of field, mask and rmask. + INTEGER :: is, js, ks !< Start indecies in each spatial dim of the field_data; and + !! may be user provided in send_data + Integer :: ie, je, ke !< End indecies in each spatial dim of the field_data; and + !! may be user provided in send_data + INTEGER :: hi !< halo size in x direction. Same name as in send_data + INTEGER :: hj !< halo size in y direction. Same + CONTAINS + procedure :: initialize => initialize_outfield_index_type + procedure :: get_f1 + procedure :: get_f2 + procedure :: get_f3 + procedure :: get_f4 + procedure :: get_is + procedure :: get_js + procedure :: get_ks + procedure :: get_ie + procedure :: get_je + procedure :: get_ke + procedure :: get_hi + procedure :: get_hj + END TYPE fmsDiagOutfieldIndex_type + +CONTAINS + + !> @brief Gets module_name + !! @return copy of the module_name character array + pure function get_module_name (this) & + result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + rslt = this%module_name + end function get_module_name + + !> @brief Gets field_name + !! @return copy of the field_name character array + pure function get_field_name (this) & + result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + rslt = this%field_name + end function get_field_name + + !> @brief Gets output_name + !! @return copy of the output_name character array + pure function get_output_name (this) & + result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + rslt = this%output_name + end function get_output_name + + !> @brief Gets output_file + !! @return copy of the output_file character array + pure function get_output_file (this) & + result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + rslt = this%output_file + end function get_output_file + + !> @brief Gets pow_value + !! @return copy of integer member pow_value + pure integer function get_pow_value (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%pow_value + end function get_pow_value + + !> @brief Gets phys_window + !! @return copy of integer member phys_window + pure logical function get_phys_window (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%phys_window + end function get_phys_window + + !> @brief Gets need_compute + !! @return copy of integer member need_compute + pure logical function get_need_compute (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%need_compute + end function get_need_compute + + !> @brief Gets reduced_k_range + !! @return copy of integer member reduced_k_range + pure logical function get_reduced_k_range (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%reduced_k_range + end function get_reduced_k_range + + !> @brief Gets missvalue_present + !! @return copy of integer member missvalue_present + pure logical function get_missvalue_present (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%missvalue_present + end function get_missvalue_present + + !> @brief Gets mask_variant + !! @return copy of integer member mask_variant + pure logical function get_mask_variant (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%mask_variant + end function get_mask_variant + + !> @brief Gets mask_present + !! @return copy of integer member mask_present + pure logical function get_mask_present (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%mask_present + end function get_mask_present + + !> @brief Gets the time_reduction object + !! @return copy of the memeber object time_reduction + function get_time_reduction (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + TYPE(fmsDiagTimeReduction_type), allocatable :: rslt + allocate( rslt ) + call rslt%copy(this%time_reduction) + end function get_time_reduction + + !> @brief Gets f1 + !! @return copy of integer member f1 + pure integer function get_f1 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%f1 + end function get_f1 + + !> @brief Gets f2 + !! @return copy of integer member f2 + pure integer function get_f2 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%f2 + end function get_f2 + + !> @brief Gets f3 + !! @return copy of integer member f3 + pure integer function get_f3 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%f3 + end function get_f3 + + !> @brief Gets f4 + !! @return copy of integer member f4 + pure integer function get_f4 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%f4 + end function get_f4 + + !> @brief Gets is + !! @return copy of integer member is + pure integer function get_is (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%is + end function get_is + + !> @brief Gets js + !! @return copy of integer member js + pure integer function get_js (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%js + end function get_js + + !> @brief Gets ks + !! @return copy of integer member ks + pure integer function get_ks (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%ks + end function get_ks + + !> @brief Gets ie + !! @return copy of integer member ie + pure integer function get_ie (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%ie + end function get_ie + + !> @brief Gets je + !! @return copy of integer member je + pure integer function get_je (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%je + end function get_je + + !> @brief Gets ke + !! @return copy of integer member ke + pure integer function get_ke (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%ke + end function get_ke + + !> @brief Gets hi + !! @return copy of integer member hi + pure integer function get_hi (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%hi + end function get_hi + + !> @brief Gets hj + !! @return copy of integer member hj + pure integer function get_hj (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%hj + end function get_hj + + + !> #brief initialize all the members of the class. + SUBROUTINE initialize_outfield_index_type(this, is, js , ks, ie, je, ke, hi, hj, f1, f2, f3, f4) + CLASS(fmsDiagOutfieldIndex_type), INTENT(inout) :: this + INTEGER, INTENT(in) :: is, js, ks !< Variable used to update class member of same names. + INTEGER, INTENT(in) :: ie, je, ke !< Variable used to update class member of same names. + INTEGER, INTENT(in) :: hi, hj !< Variable used to update class member of same names. + INTEGER, INTENT(in) :: f1, f2, f3, f4 !< Variable used to update class member of same names. + + this%is = is + this%js = js + this%ks = ks + this%ie = ie + this%je = je + this%ke = ke + + this%hi = hi + this%hj = hj + + this%f1 = f1 + this%f2 = f2 + this%f3 = f3 + this%f4 = f4 + END SUBROUTINE initialize_outfield_index_type + + + !> @brief Update the fmsDiagOutfield_type instance with those fields used in the legacy diag manager. + !! Note that this is initializing from the legacy structures. + !! Note that output_frequency came from file_type; + SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_present, freq) + CLASS(fmsDiagOutfield_type), INTENT(inout) :: this !< An instance of the fmsDiagOutfield_type + TYPE(input_field_type), INTENT(in) :: input_field !< An instance of the input_field_type + TYPE(output_field_type), INTENT(in) :: output_field !< An instance of the output_field_type + LOGICAL, INTENT(in) :: mask_present !< Was the mask present in the call to send_data? + INTEGER, INTENT(in) :: freq !< The output frequency. + INTEGER :: time_redux !< The time reduction type integer. + + this%module_name = input_field%module_name + this%field_name = input_field%field_name + this%output_name = output_field%output_name + + this%pow_value = output_field%pow_value + this%phys_window = output_field%phys_window + this%need_compute = output_field%need_compute + this%reduced_k_range = output_field%reduced_k_range + this%mask_variant = input_field%mask_variant + !!Note: in legacy diag manager, presence of missing value vs presence of mask + !! is determined in different ways (diag table vs send function call) + this%missvalue_present = input_field%missing_value_present + this%mask_present = mask_present + + time_redux = get_output_field_time_reduction (output_field) + call this%time_reduction%initialize( time_redux , freq) + + !!TODO: the time_min and time_max buffer update code is almost the exact same src code, except + !! for the compariosn function. Simplify code and set comparison function: + !!TODO: If possible add to the power function. See issue with pointers and elemental functions + + END SUBROUTINE initialize_outfield_imp + + !> @brief Initialized an fmsDiagOutfield_type as needed for unit tests. + subroutine initialize_for_ut(this, module_name, field_name, output_name, & + & power_val, phys_window, need_compute, mask_variant, reduced_k_range, num_elems, & + & time_reduction_type,output_freq) + CLASS(fmsDiagOutfield_type), intent(inout) :: this + CHARACTER(len=*), INTENT(in) :: module_name !< Var with same name in fmsDiagOutfield_type + CHARACTER(len=*), INTENT(in) :: field_name !< Var with same name in fmsDiagOutfield_type + CHARACTER(len=*), INTENT(in) :: output_name !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: power_val !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: phys_window !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: need_compute !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: mask_variant !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: reduced_k_range !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: num_elems !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: time_reduction_type !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: output_freq !< The output_freq need in initaliztion of time_reduction_type + + this%module_name = module_name + this%field_name = field_name + this%output_name = output_name + this%pow_value = power_val + this%phys_window = phys_window + this%need_compute = need_compute + this%reduced_k_range = reduced_k_range + this%mask_variant = mask_variant + call this%time_reduction%initialize(time_reduction_type, output_freq) + end subroutine initialize_for_ut + + !> @brief Reset the time reduction member field. Intended for use in unit tests only. + SUBROUTINE reset_time_reduction_ut(this, source ) + CLASS(fmsDiagOutfield_type), INTENT(inout) :: this !< An instance of the fmsDiagOutfield_type + TYPE(fmsDiagTimeReduction_type) :: source !< The fmsDiagTimeReduction_type to copy from + call this%time_reduction%copy(source) + END SUBROUTINE reset_time_reduction_ut + + + + !> \brief Get the time reduction from a legacy output field. + !\note Note we do not place this in the time_reduction class to avoid circular dependencies. + function get_output_field_time_reduction(ofield) result (rslt) + TYPE(output_field_type), INTENT(in) :: ofield !< An instance of the output_field_type + INTEGER :: rslt !< The result integer which is the time reduction. + if(ofield%time_max) then + rslt = time_max + elseif(ofield%time_min)then + rslt = time_min + else if (ofield%time_sum) then + rslt = time_sum + else if (ofield%time_rms) then + rslt = time_rms + else if (ofield%time_average) then + rslt = time_average + else + rslt = time_none + !if(.NOT. ofield%static) then + !!TODO: Set error to FATAL. When legacy diag_manager is removed? + ! CALL error_mesg('fms_diag_outfield:get_output_field_time_reduction', & + ! & 'result is time_none but out_field%static is not true', WARNING) + !end if + endif + end function get_output_field_time_reduction + +END MODULE fms_diag_outfield_mod +!> @} +! close documentation grouping + + diff --git a/diag_manager/fms_diag_time_reduction.F90 b/diag_manager/fms_diag_time_reduction.F90 new file mode 100644 index 0000000000..78de19a25a --- /dev/null +++ b/diag_manager/fms_diag_time_reduction.F90 @@ -0,0 +1,227 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_time_reduction_mod fms_diag_time_reduction_mod +!> @ingroup diag_manager +!> @brief fms_diag_time_reduction_mod defines classes encapsulating the diag_manager +!! time redution types. +!! +!> @author Miguel Zuniga +!! +!> @file +!> @brief File for @ref fms_diag_time_reduction_mod +!> @addtogroup fms_diag_time_reduction_mod +!> @{ +MODULE fms_diag_time_reduction_mod + + USE diag_data_mod, only: EVERY_TIME + USE fms_mod, ONLY: error_mesg, FATAL + + implicit none + + !!TODO: (Future effort) Note that time_diurnal processing is a little different + !! and more complex than the other reduction methods, and therefore refactoring its + !! processing may simplify the overall related codebase. The refactoring, + !! if possible, may be done elsewhere in the diag_manager. + + !!These parametes are the possible kinds of time reduction operations. + INTEGER, PARAMETER :: time_none = 0 !< There is no reduction method + INTEGER, PARAMETER :: time_average = 1 !< The reduction method is average + INTEGER, PARAMETER :: time_rms = 2 !< The reduction method is rms + INTEGER, PARAMETER :: time_max = 3 !< The reduction method is max + INTEGER, PARAMETER :: time_min = 4 !< The reduction method is min + INTEGER, PARAMETER :: time_sum = 5 !< The reudction method is sum + INTEGER, PARAMETER :: time_diurnal = 6 !< The reduction method is diurnal + INTEGER, PARAMETER :: time_power = 7 !< The reduction method is power + + !> @brief Class fmsDiagTimeReduction_type has an encapsulation of the "Fortran enum" time + !! reduction integer parameters, plus an encapsulation of the groupings of + !! the time reduction types. It is intended to provide some of the functionality + !! that was coded in the legacy function diag_data.F90:init_output_fields. + !! The functionality in the end is used by send_data in (EFFICIENT) do loops calling + !! the weighting or math functions to update buffers. + !! The integer parameters above are the legal time reduction types, + !! but they are not necessarily mutually exclusive in some contexts. + !! + !> @addtogroup fms_diag_time_reduction_mod + TYPE fmsDiagTimeReduction_type + integer , private :: the_time_reduction !< The time reduction type, as an integer defined above. + logical , private :: time_averaging !< Set true iff time_average, time_rms, time_power or time_diurnal is true + logical , private :: time_ops !< Set true iff time_min, time_max, time_rms or time_average is true. + CONTAINS + procedure, public :: do_time_averaging => do_time_averaging_imp + procedure, public :: has_time_ops => has_time_ops_imp + procedure, public :: is_time_none => is_time_none_imp + procedure, public :: is_time_average => is_time_average_imp + procedure, public :: is_time_rms => is_time_rms_imp + procedure, public :: is_time_max => is_time_max_imp + procedure, public :: is_time_min => is_time_min_imp + procedure, public :: is_time_sum => is_time_sum_imp + procedure, public :: is_time_diurnal => is_time_diurnal_imp + procedure, public :: is_time_power => is_time_power_imp + procedure, public :: initialize + procedure, public :: copy + END TYPE fmsDiagTimeReduction_type + + !> @brief This interface is for the class constructor. + !> @addtogroup fms_diag_time_reduction_mod + interface fmsDiagTimeReduction_type + procedure :: fmsDiagTimeReduction_type_constructor + end interface fmsDiagTimeReduction_type + +CONTAINS + + !> @brief The class contructors. Just allocates the class and calls an initializer + !! @return An allocated instance of fmsDiagTimeReduction_type, which is nitialized using + !! provided values for arguments dt and out_freqeuncy. + function fmsDiagTimeReduction_type_constructor(dt, out_frequency) result(time_redux) + integer, intent(in) :: dt !< The redution type (time_rms, time_power, etc) + integer, intent(in) :: out_frequency !< The output frequency. + class (fmsDiagTimeReduction_type), allocatable :: time_redux !< The instance of the fmsDiagTimeReduction_type + !!class allocated and returned by this constructor. + allocate(time_redux) + call time_redux%initialize(dt, out_frequency) + end function fmsDiagTimeReduction_type_constructor + + !> @brief Initialize the object. As an alternative to the constructor, one can + !! allocate an fmsDiagTimeReduction_type instance, then call its initialize function. + subroutine initialize(this, dt, out_frequency) + class (fmsDiagTimeReduction_type), intent(inout) :: this !< The fmsDiagTimeReduction_type object + integer, intent(in) :: dt !< The redution type (time_rms, time_porer, etc) + integer, intent(in) :: out_frequency !< The output frequency. + + this%the_time_reduction = dt + + !! Set the time_averaging flag + !! See legacy init_ouput_fields function, lines 1470ff + IF(( dt .EQ. time_average) .OR. (dt .EQ. time_rms) .OR. (dt .EQ. time_power) .OR. & + & (dt .EQ. time_diurnal)) THEN + this%time_averaging = .true. + ELSE + this%time_averaging= .false. + IF((dt .NE. time_max) .AND. (dt .ne. time_min) .AND. (dt .NE. time_sum) & + & .AND. (dt .NE. time_none)) THEN + CALL error_mesg('fmsDiagTimeReduction_type: initialize', & + & 'time_averaging=.false. but reduction type not compatible', FATAL) + ENDIF + END IF + + !!TODO: (MDM) Add other checks? E.g. If time_averaging == .false., then + !! out_frequency == EVERY_TIME + + IF((dt .EQ. time_min) .OR. (dt .EQ. time_max) .OR. & + & ( dt .EQ. time_average) .OR. (dt .EQ. time_sum) ) THEN + this%time_ops = .true. + ELSE + this%time_ops = .false. + END IF + end subroutine initialize + + !> @brief Copy the source time reduction object into the this object. + subroutine copy(this, source) + class (fmsDiagTimeReduction_type),intent(inout):: this !< The fmsDiagTimeReduction_type object + class (fmsDiagTimeReduction_type),intent(in):: source !< The fmsDiagTimeReduction_type object + this%the_time_reduction = source%the_time_reduction + this%time_averaging = source%time_averaging + this%time_ops = source%time_ops + end subroutine copy + + !> \brief Returns true if any of time_min, time_max, time_rms or time_average is true. + !! @return true if any of time_min, time_max, time_rms or time_average is true. + pure function has_time_ops_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff time_averaging is true. + !! @return true iff time_averaging is true. + pure function do_time_averaging_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_average + !! @return true iff the_time_reduction is time_average + pure function is_time_average_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_none + !! @return true iff the_time_reduction is time_none + pure function is_time_none_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_rms + !! @return true iff the_time_reduction is time_rms + pure function is_time_rms_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_max + !! @return true iff the_time_reduction is time_max + pure function is_time_max_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_min + !! @return true iff the_time_reduction is time_min + pure function is_time_min_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_sum + !! @return true iff the_time_reduction is time_sum + pure function is_time_sum_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_diurnal + !! @return true iff the_time_reduction is time_diurnal + pure function is_time_diurnal_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_power + !! @return true iff the_time_reduction is time_power + pure function is_time_power_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! @} +! close documentation grouping diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh new file mode 100644 index 0000000000..52fa7259d6 --- /dev/null +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -0,0 +1,1374 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + + !> @brief This code will be used by the preprocessor to generate an implementation + !! of the module procedure for the fieldbuff_update interface. The + !! generated function is a wrapper calling 4D field/5D buffer version of the same. +FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & + & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, & + & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local ) result( succeded ) + TYPE(fmsDiagOutfield_type), INTENT(in):: ofield_cfg !< The fmsDiagOutfield_type object, + !! where "cfg" is short for configuration + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg ! A target for ofc_ptr, in case ofc is not allocated + LOGICAL, DIMENSION(1), target :: mask_dummy !> A target for mask_ptr, in case mask is not present + + !! For pointer bounds remapping + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr !< Pointer to the field + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr !< Pointer to the outfield buffer. + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofc_ptr !< Pointer to the outfield counter. + LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr !< Pointer to the mask. + + !!Set all the pointers! + field_ptr(1:size(field_d,1),1:size(field_d,2),1:size(field_d,3),1:1) => field_d + ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3),1:1, 1:size(ofb,4)) => ofb + + !!Note that diag manager does not allocate the ofc in all situations + if(allocated(ofc)) then + ofc_ptr(1:size(ofc,1),1:size(ofc,2),1:size(ofc,3), 1:1, 1:size(ofc,4)) => ofc + else + ofc_ptr(1:1,1:1,1:1,1:1,1:1) => ofc_dummy + endif + + IF (PRESENT (mask)) THEN + mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask + ELSE + mask_ptr(1:1,1:1,1:1,1:1) => mask_dummy + ENDIF + + succeded = FMS_DIAG_FBU_PNAME_ (ofield_cfg, ofield_index_cfg, field_ptr, sample, & + & ofb_ptr, ofc_ptr, bbounds, count_0d, num_elements, mask_ptr, weight1, missvalue, & + & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local) + END FUNCTION FMS_DIAG_FBU_3D_PNAME_ + + +!> @brief This code will be used by the preprocessor to generate an implementation +!! of the module procedure for the fieldbuff_update interface. +!! Updates elements of the running field output buffer (argument ofb) +!! and counter (argument ofc) based on the input field data array (argument field_d). +!! In general the formulas are : +!! A) ofb(l) = ofb(l) + (weight * field(l))**pow_value +!! B) ofc(l) = ofc(l) + weight +!! where l is a standing for some set of indices in multiple dimensions. +!! Note this function may set field object members active_omp_level and num_threads. +!! TODO: (MDM) revisit passing in and need of field_num_threads and field_active_omp_level +!> @addtogroup fms_diag_fieldbuff_update_mod +!> @{ + FUNCTION FMS_DIAG_FBU_PNAME_ (ofield_cfg, ofield_index_cfg, field_d, sample, & + & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, & + & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local ) result( succeded ) + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The fmsDiagOutfield_type object, + !!where "cfg" is short for configuration + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The fmsDiagOutfieldIndex_type object, + !! where "cfg" is short for configuration + FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in) :: field_d !< The input field data array. + FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< Output Field Buffer + FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofc !< Output Field Counter + TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds !< The array bounds of the ofb argument. + INTEGER, INTENT(in) :: sample !< The index along the diurnal time axis + FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. + INTEGER, INTENT(inout):: num_elements !< Used in counting updated buffer elements; Other functions (e.g. wrting + !!field) may nprmalize output buffer elements with the same. + LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL:: mask !< The mask of the corresponding field. + FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: weight1 !< Field data is multiplied by weight + FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. + + INTEGER, INTENT(inout) :: field_num_threads !< Number of OMP threads used processing the input field; + !! expected 1 if no OMP. + INTEGER, INTENT(inout)::field_active_omp_level !1 .AND. phys_window ) then + REDU_KR1_IF: IF ( reduced_k_range ) THEN + DO k= ksr, ker + k1= k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample), & + & field_d(i-is+1+hi, j-js+1+hj, k, :), weight1, pow_value) + ofc(i-hi,j-hj,k1,:,sample) = ofc(i-hi,j-hj,k1,:,sample) + weight1 + END where + END DO + END DO + END DO + ELSE REDU_KR1_IF + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + ofc(i-hi,j-hj,k,:,sample) = ofc(i-hi,j-hj,k,:,sample) + weight1 + END where + END DO + END DO + END DO + END IF REDU_KR1_IF + ELSE +!$OMP CRITICAL + REDU_KR2_IF: IF ( reduced_k_range ) THEN + DO k= ksr, ker + k1= k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi, j-js+1+hj, k, :) , weight1, pow_value) + ofc(i-hi,j-hj,k1,:,sample) = ofc(i-hi,j-hj,k1,:,sample) + weight1 + END where + END DO + END DO + END DO + ELSE REDU_KR2_IF + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + ofc(i-hi,j-hj,k,:,sample) = ofc(i-hi,j-hj,k,:,sample) + weight1 + END where + END DO + END DO + END DO + END IF REDU_KR2_IF +!$OMP END CRITICAL + END IF + ELSE MISSVAL_PR_1_IF + WRITE (error_string,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + IF(fms_error_handler('diag_manager_mod::send_data_3d', & + & 'module/output_field '//TRIM(error_string)//', variable mask but no missing value defined', & + & err_msg)) THEN + succeded = .FALSE. + RETURN + END IF + END IF MISSVAL_PR_1_IF + ELSE MASK_PR_1_IF ! no mask present + WRITE (error_string,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + IF(fms_error_handler('diag_manager_mod::send_data_3d','module/output_field '//TRIM(error_string)//& + & ', variable mask but no mask given', err_msg)) THEN + succeded = .FALSE. + RETURN + END IF + END IF MASK_PR_1_IF + ELSE MASK_VAR_IF + MASK_PR_2_IF: IF (mask_present ) THEN + MISSVAL_PR_2_IF: IF ( missvalue_present ) THEN !!section:(mask_var false +mask present +missval prsnt) + NDCMP_RKR_1_IF: IF ( need_compute ) THEN + IF (numthreads>1 .AND. phys_window) then + DO k = l_start(3), l_end(3) + k1 = k-l_start(3)+1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i1,j1,k1,:,sample) = addwf( ofb(i1,j1,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i1,j1,k1,:,sample) = missvalue + END where + END IF + END DO + END DO + END DO + ELSE +!$OMP CRITICAL + DO k = l_start(3), l_end(3) + k1 = k-l_start(3)+1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i1,j1,k1,:,sample) = addwf( ofb(i1,j1,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i1,j1,k1,:,sample) = missvalue + END where + END IF + END DO + END DO + END DO +!$OMP END CRITICAL + ENDIF +!$OMP CRITICAL + DO l = ls, le + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + num_elements = num_elements + l_end(3) - l_start(3) + 1 + END IF + END DO + END DO + END DO +!$OMP END CRITICAL + ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_1_IF + IF (numthreads>1 .AND. phys_window) then + DO k=ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k1,:,sample)= missvalue + END where + END DO + END DO + END DO + ELSE +!$OMP CRITICAL + DO k=ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k1,:,sample)= missvalue + END where + END DO + END DO + END DO +!$OMP END CRITICAL + END IF + ELSE NDCMP_RKR_1_IF + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + IF (numthreads>1 .AND. phys_window) then + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k,:,sample)= missvalue + END where + END DO + END DO + END DO + ELSE +!$OMP CRITICAL + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k,:,sample)= missvalue + END where + END DO + END DO + END DO +!$OMP END CRITICAL + END IF + END IF NDCMP_RKR_1_IF +!$OMP CRITICAL + IF ( need_compute .AND. .NOT.phys_window ) THEN + IF ( ANY(mask(l_start(1)+hi:l_end(1)+hi,l_start(2)+hj:l_end(2)+hj,l_start(3):l_end(3), :)) ) & + count_0d = count_0d + weight1 + ELSE + IF ( ANY(mask(f1:f2,f3:f4,ks:ke,:)) ) count_0d = count_0d + weight1 + END IF +!$OMP END CRITICAL + ELSE MISSVAL_PR_2_IF !! (section: mask_varian .eq. false + mask present + miss value not present) + IF ( (.NOT.ALL(mask(f1:f2,f3:f4,ks:ke,:)) .AND. mpp_pe() .EQ. mpp_root_pe()).AND.& + & .NOT. issued_mask_ignore_warning) THEN + ! + ! Mask will be ignored since missing values were not specified for field + ! in module + ! + CALL error_mesg('diag_manager_mod::send_data_3d',& + & 'Mask will be ignored since missing values were not specified for field '//& + & trim(field_name)//' in module '//& + & trim(module_name), WARNING) + issued_mask_ignore_warning = .TRUE. + END IF + NDCMP_RKR_2_IF: IF ( need_compute ) THEN + IF (numthreads>1 .AND. phys_window) then + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + ofb(i1,j1,:,:,sample)= addwf(ofb(i1,j1,:,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) , weight1, pow_value) + END IF + END DO + END DO + ELSE +!$OMP CRITICAL + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + ofb(i1,j1,:,:,sample) = addwf( ofb(i1,j1,:,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) , weight1, pow_value) + END IF + END DO + END DO +!$OMP END CRITICAL + END IF +!$OMP CRITICAL + DO l = ls, le + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + num_elements = num_elements + l_end(3)-l_start(3)+1 + END IF + END DO + END DO + END DO +!$OMP END CRITICAL + ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_2_IF + IF (numthreads>1 .AND. phys_window) then + ksr= l_start(3) + ker= l_end(3) + ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = addwf( ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) , & + & field_d(f1:f2,f3:f4,ksr:ker, :) , weight1, pow_value) + ELSE +!$OMP CRITICAL + ksr= l_start(3) + ker= l_end(3) + ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = addwf( ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) , & + & field_d(f1:f2,f3:f4,ksr:ker,:) , weight1, pow_value) +!$OMP END CRITICAL + END IF + ELSE NDCMP_RKR_2_IF + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '') THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + IF (numthreads>1 .AND. phys_window) then + ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) , & + & field_d(f1:f2,f3:f4,ks:ke,:) , weight1, pow_value) + ELSE +!$OMP CRITICAL + ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& + & addwf(ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) , & + & field_d(f1:f2,f3:f4,ks:ke,:) , weight1, pow_value) +!$OMP END CRITICAL + END IF + END IF NDCMP_RKR_2_IF +!$OMP CRITICAL + IF ( .NOT.phys_window ) count_0d = count_0d + weight1 +!$OMP END CRITICAL + END IF MISSVAL_PR_2_IF + ELSE MASK_PR_2_IF !!(section: mask_variant .eq. false + mask not present + missvalue) + MISSVAL_PR_3_IF: IF (missvalue_present ) THEN + NDCMP_RKR_3_IF: IF ( need_compute ) THEN + NTAPW_IF: If( numthreads>1 .AND. phys_window ) then + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i1,j1,k1,:,sample) = addwf( ofb(i1,j1,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i1,j1,k1,:,sample) = missvalue + END where + END IF + END DO + END DO + END DO + ELSE NTAPW_IF +!$OMP CRITICAL + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i1,j1,k1,:,sample) = addwf( ofb(i1,j1,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i1,j1,k1,:,sample) = missvalue + END where + END IF + END DO + END DO + END DO +!$OMP END CRITICAL + END IF NTAPW_IF +!$OMP CRITICAL + DO l = ls, le + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj) THEN + num_elements = num_elements + l_end(3) - l_start(3) + 1 + END IF + END DO + END DO + END DO + IF ( .NOT.phys_window ) THEN + DO l = ls, le + DO k = l_start(3), l_end(3) + DO j=l_start(2)+hj, l_end(2)+hj + DO i=l_start(1)+hi, l_end(1)+hi + IF (field_d(i,j, k, l) /= missvalue ) THEN + count_0d = count_0d + weight1 + EXIT + END IF + END DO + END DO + END DO + END DO + END IF +!$OMP END CRITICAL + ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_3_IF + if( numthreads>1 .AND. phys_window ) then + ksr= l_start(3) + ker= l_end(3) + DO k = ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i-hi,j-hj,k1,:,sample) = addwf(ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k1,:,sample) = missvalue + END where + END DO + END DO + END DO + else +!$OMP CRITICAL + ksr= l_start(3) + ker= l_end(3) + DO k = ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k1,:,sample) = missvalue + END where + END DO + END DO + END DO +!$OMP END CRITICAL + END IF +!$OMP CRITICAL + DO l = ls, le + DO k = ksr, ker + k1=k-ksr+1 + DO j=f3, f4 + DO i=f1, f2 + !!TODO: verify this and similar ones. Note the EXIT statement + IF ( field_d(i,j, k, l) /= missvalue ) THEN + count_0d = count_0d + weight1 + EXIT + END IF + END DO + END DO + END DO + END DO +!$OMP END CRITICAL + ELSE NDCMP_RKR_3_IF + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + IF( numthreads > 1 .AND. phys_window ) then + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k,:,sample) = missvalue + END where + END DO + END DO + END DO + ELSE +!$OMP CRITICAL + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) + elsewhere + ofb(i-hi,j-hj,k,:,sample) = missvalue + END where + END DO + END DO + END DO +!$OMP END CRITICAL + END IF +!$OMP CRITICAL + DO l = ls, le + DO k=ks, ke + DO j=f3, f4 + DO i=f1, f2 + IF ( field_d(i,j, k, l) /= missvalue ) THEN + count_0d = count_0d + weight1 + EXIT + END IF + END DO + END DO + END DO + END DO +!$OMP END CRITICAL + END IF NDCMP_RKR_3_IF + ELSE MISSVAL_PR_3_IF !!(section: mask_variant .eq. false + mask not present + missvalue not present) + NDCMP_RKR_4_IF: IF ( need_compute ) THEN + IF( numthreads > 1 .AND. phys_window ) then + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + ofb(i1,j1,:,:,sample) = addwf( ofb(i1,j1,:,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) , weight1, pow_value) + END IF + END DO + END DO + ELSE +!$OMP CRITICAL + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + ofb(i1,j1,:,:,sample) = addwf(ofb(i1,j1,:,:,sample), & + & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :), weight1, pow_value) + END IF + END DO + END DO +!$OMP END CRITICAL + END IF +!$OMP CRITICAL + DO l = ls, le + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + num_elements = num_elements + l_end(3)-l_start(3)+1 + END IF + END DO + END DO + END DO +!$OMP END CRITICAL + ! Accumulate time average + ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_4_IF + ksr= l_start(3) + ker= l_end(3) + IF( numthreads > 1 .AND. phys_window ) then + ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) =& + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) , & + & field_d(f1:f2,f3:f4,ksr:ker, :) , weight1, pow_value) + ELSE +!$OMP CRITICAL + ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) =& + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) , & + & field_d(f1:f2,f3:f4,ksr:ker, :) , weight1, pow_value) +!$OMP END CRITICAL + END IF + + ELSE NDCMP_RKR_4_IF + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF (fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + IF( numthreads > 1 .AND. phys_window ) then + ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) , & + & field_d(f1:f2,f3:f4,ks:ke, :) , weight1, pow_value) + ELSE +!$OMP CRITICAL + ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) , & + & field_d(f1:f2,f3:f4,ks:ke, :) , weight1, pow_value) + !! +!$OMP END CRITICAL + END IF + END IF NDCMP_RKR_4_IF +!$OMP CRITICAL + IF ( .NOT.phys_window ) count_0d = count_0d + weight1 +!$OMP END CRITICAL + END IF MISSVAL_PR_3_IF + END IF MASK_PR_2_IF ! if mask present + END IF MASK_VAR_IF + +!$OMP CRITICAL + IF ( .NOT.need_compute .AND. .NOT.reduced_k_range ) num_elements = num_elements + & + & (ie-is+1)*(je-js+1)*(ke-ks+1)*(le-ls+1) + IF ( reduced_k_range ) num_elements = num_elements + & + & (ie-is+1)*(je-js+1)*(ker-ksr+1)*(le-ls+1) +!$OMP END CRITICAL + + succeded = .TRUE. + RETURN + + END FUNCTION FMS_DIAG_FBU_PNAME_ + + + !> @brief This code will be used by the preprocessor to generate an implementation + !! of the module procedure for the fieldbuff_copy_fieldvals interface. The + !! generated function is a wrapper calling 4D field/5D buffer version of the same. + FUNCTION FMS_DIAG_FBCF_3D_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & + & bbounds, count_0d, mask, missvalue, & + & l_start, l_end, err_msg, err_msg_local) result( succeded ) + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The fmsDiagOutfield_type object, + !!where "cfg" is short for configuration + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The fmsDiagOutfieldIndex_type object, + !! where "cfg" is short for configuration + FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:),INTENT(in),target:: field !< The field value array. + INTEGER, INTENT(in) :: sample !< index along the diurnal time axis + FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:),INTENT(inout),target::ofb ! A target for mask_ptr, in case mask is not present + + !! For pointer bounds remapping: + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr!< Pointer to the field + FMS_DIAG_FBU_DATA_TYPE_ , pointer,DIMENSION(:,:,:,:,:):: ofb_ptr!< Pointer to the outfield buffer. + LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr !< Pointer to the mask. + + !Initialize all the pointers + field_ptr(1:size(field,1),1:size(field,2),1:size(field,3),1:1) => field(:,:,:) + ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:1, 1:size(ofb,4)) => ofb + IF (PRESENT (mask)) THEN + mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask + ELSE + mask_ptr(1:1,1:1,1:1,1:1) => mask_dummy + ENDIF + + succeded = FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field_ptr, sample, & + & ofb_ptr, bbounds, count_0d, mask_ptr, missvalue, & + & l_start, l_end, err_msg, err_msg_local) + END FUNCTION FMS_DIAG_FBCF_3D_PNAME_ + +!> @brief This code will be used by the preprocessor to generate an implementation +!! of the module procedure for the fieldbuff_copy_fieldvals interface. +!! The function may set or add to the output field buffer (argument ofb) with the input +!! field data array (argument field) +FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & + & bbounds, count_0d, mask, missvalue, & + & l_start, l_end, err_msg, err_msg_local) result( succeded ) + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The fmsDiagOutfield_type object, + !! where "cfg" is short for configuration + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The fmsDiagOutfieldIndex_type object, + !!where "cfg" is short for configuration + FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in) :: field !< The field value array. + INTEGER, INTENT(in) :: sample !< index along the diurnal time axis + FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< The Output Field Buffer + TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds !< The array bounds of the ofb argument. + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout) :: count_0d !< Normally the member of the buffer of same name, + LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask !< The mask of the corresponding field. + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !< buffer may be set to this value where mask is false. + INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on spatial axes for regional output + INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on spatial for regional output + CHARACTER(len=*), INTENT(out),OPTIONAL::err_msg !< Possibly passed in by the caller, and sent to handler + CHARACTER(len=256), INTENT(out) :: err_msg_local !< Possibly set by bounds checker, and sent to handler + LOGICAL :: succeded !< Return true iff errors are not encounterd. + !! + !! + !< The indices copied directly from the ofield_index_cfg + INTEGER :: is, js, ks, ie, je, ke, hi, hj, f1, f2, f3, f4 + + CHARACTER(:), ALLOCATABLE :: output_name !< A copy of same variable in ofield_cfg + CHARACTER(:), ALLOCATABLE :: module_name !< A copy of same variable in ofield_cfg + LOGICAL :: need_compute !< A copy of same variable in ofield_cfg + LOGICAL :: reduced_k_range !< A copy of same variable in ofield_cfg + LOGICAL :: mask_present !< A copy of same variable in ofield_cfg + LOGICAL :: missvalue_present !< A copy of same variable in ofield_cfg + class (fmsDiagTimeReduction_type), allocatable :: time_redux !< The instance of the fmsDiagTimeReduction_type + + INTEGER :: ksr, ker !< Loop indices used in reduced_k_range calculations + INTEGER :: i, j, k, i1, j1, k1 !< Looping indices, derived from ofield_index_cfg: + LOGICAL :: time_max, time_min, time_sum !< A copies of same variables in ofield_cfg%time_reduction + + ksr= l_start(3) + ker= l_end(3) + + is = ofield_index_cfg%get_is() + js = ofield_index_cfg%get_js() + ks = ofield_index_cfg%get_ks() + ie = ofield_index_cfg%get_ie() + je = ofield_index_cfg%get_je() + ke = ofield_index_cfg%get_ke() + hi = ofield_index_cfg%get_hi() + hj = ofield_index_cfg%get_hj() + f1 = ofield_index_cfg%get_f1() + f2 = ofield_index_cfg%get_f2() + f3 = ofield_index_cfg%get_f3() + f4 = ofield_index_cfg%get_f4() + + allocate(time_redux) + call time_redux%copy(ofield_cfg%get_time_reduction()) + time_max = time_redux%is_time_max() + time_min = time_redux%is_time_min() + time_sum = time_redux%is_time_sum() + + output_name = trim(ofield_cfg%get_output_name()) + module_name = trim(ofield_cfg%get_module_name()) + reduced_k_range = ofield_cfg%get_reduced_k_range() + need_compute = ofield_cfg%get_need_compute() + mask_present = ofield_cfg%get_mask_present() + missvalue_present = ofield_cfg%get_missvalue_present() + + ! Add processing for Max and Min + TIME_IF: IF ( time_max ) THEN + MASK_PRSNT_1_IF: IF (mask_present ) THEN + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + WHERE ( mask(i-is+1+hi,j-js+1+hj,k,:) .AND.& + & field(i-is+1+hi,j-js+1+hj,k,:)>OFB(i1,j1,k1,:,sample)) + OFB(i1,j1,k1,:,sample) = field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Maximum time value with masking + ELSE IF ( reduced_k_range ) THEN + ksr = l_start(3) + ker = l_end(3) + WHERE ( mask(f1:f2,f3:f4,ksr:ker,:) .AND. & + & field(f1:f2,f3:f4,ksr:ker,:) > OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE ( mask(f1:f2,f3:f4,ks:ke,:) .AND.& + & field(f1:f2,f3:f4,ks:ke,:)>OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + ELSE MASK_PRSNT_1_IF + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + IF(l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + WHERE ( field(i-is+1+hi,j-js+1+hj,k,:) > OFB(i1,j1,k1,:,sample) ) + OFB(i1,j1,k1,:,sample) = field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Maximum time value + ELSE IF ( reduced_k_range ) THEN + ksr = l_start(3) + ker = l_end(3) + WHERE ( field(f1:f2,f3:f4,ksr:ker,:) > OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) )& + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE (field(f1:f2,f3:f4,ks:ke,:) > OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + END IF MASK_PRSNT_1_IF + count_0d = 1 + !END TIME MAX + ELSE IF ( time_min ) THEN TiME_IF + MASK_PRSNT_2_IF: IF (mask_present ) THEN + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + WHERE ( mask(i-is+1+hi,j-js+1+hj,k,:) .AND.& + & field(i-is+1+hi,j-js+1+hj,k,:) < OFB(i1,j1,k1,:,sample) ) + OFB(i1,j1,k1,:,sample) = field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Minimum time value with masking + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + WHERE ( mask(f1:f2,f3:f4,ksr:ker,:) .AND.& + & field(f1:f2,f3:f4,ksr:ker,:) < OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample)) & + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE ( mask(f1:f2,f3:f4,ks:ke,:) .AND.& + & field(f1:f2,f3:f4,ks:ke,:) < OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + ELSE MASK_PRSNT_2_IF + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <=i.AND.i<=l_end(1)+hi.AND.l_start(2)+hj<=j.AND.j<=l_end(2)+hj) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + WHERE ( field(i-is+1+hi,j-js+1+hj,k,:) < OFB(i1,j1,k1,:,sample) ) + OFB(i1,j1,k1,:,sample) = field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Minimum time value + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + WHERE ( field(f1:f2,f3:f4,ksr:ker,:) < OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) )& + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE (field(f1:f2,f3:f4,ks:ke,:) < OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + END IF MASK_PRSNT_2_IF + count_0d = 1 + + !! END_TIME_MIN + ELSE IF ( time_sum ) THEN TIME_IF + MASK_PRSNT_3_IF: IF (mask_present ) THEN + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + WHERE ( mask(i-is+1+hi,j-js+1+hj,k,:) ) + OFB(i1,j1,k1,:,sample) = OFB(i1,j1,k1,:,sample) + field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Minimum time value with masking + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = & + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) + & + & field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE ( mask(f1:f2,f3:f4,ks:ke,:) ) & + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = & + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) + & + & field(f1:f2,f3:f4,ks:ke,:) + END IF + ELSE MASK_PRSNT_3_IF + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <=i.AND.i<=l_end(1)+hi.AND.l_start(2)+hj<=j.AND.j<=l_end(2)+hj) THEN + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + OFB(i1,j1,k1,:,sample) = OFB(i1,j1,k1,:,sample) + field(i-is+1+hi,j-js+1+hj,k,:) + END IF + END DO + END DO + END DO + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) + & + & field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) + & + & field(f1:f2,f3:f4,ks:ke, :) + END IF + END IF MASK_PRSNT_3_IF + count_0d = 1 + !END time_sum + ELSE TIME_IF !! ( not average, not min, not max, not sum ) + count_0d = 1 + IF ( need_compute ) THEN + DO j = js, je + DO i = is, ie + IF (l_start(1)+hi<= i .AND. i<= l_end(1)+hi .AND. l_start(2)+hj<= j .AND. j<= l_end(2)+hj) THEN + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + OFB(i1,j1,:,:,sample) = field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3),:) + END IF + END DO + END DO + ! instantaneous output + ELSE IF ( reduced_k_range ) THEN + ksr = l_start(3) + ker = l_end(3) + OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + + IF (mask_present .AND. missvalue_present ) THEN + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND. & + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + !!TODO: Make sure this where is appropritate with .NOT. + WHERE ( .NOT.mask(i-is+1+hi,j-js+1+hj,k,:) ) & + & OFB(i1,j1,k1,:,sample) = missvalue + END IF + END DO + END DO + END DO + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + DO k=ksr, ker + k1= k - ksr + 1 + DO j=js, je + DO i=is, ie + !!TODO: Make sure this where is appropritate with .NOT. + WHERE ( mask(i-is+1+hi,j-js+1+hj,k,:) .eqv. .false.) & + & OFB(i-hi,j-hj,k1,:,sample)= missvalue + END DO + END DO + END DO + ELSE + DO k=ks, ke + DO j=js, je + DO i=is, ie + !!TODO: Make sure this where is appropritate with .NOT. + WHERE ( .NOT. mask(i-is+1+hi,j-js+1+hj,k,:) )& + & OFB(i-hi,j-hj,k,:,sample)= missvalue + END DO + END DO + END DO + END IF + END IF + END IF TIME_IF + succeded = .TRUE. + RETURN + + END FUNCTION FMS_DIAG_FBCF_PNAME_ + + + + !> @brief This code will be used by the preprocessor to generate an implementation + !! of the module procedure for the fieldbuff_copy_misvals interface. The + !! generated function is a wrapper calling 4D field/5D buffer version of the same. + !! TODO (MDM) the meaning of an integer rmask has to be studied. + SUBROUTINE FMS_DIAG_FBCM_3D_PNAME_ (ofield_cfg, ofield_index_cfg, ofb, sample, & + & l_start, l_end, rmask, rmask_thresh, missvalue) + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The ofield_cfg object + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The ofield_index_cfg object + FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS,DIMENSION(:,:,:,:),INTENT(inout),target:: ofb ! ofb + rmask_ptr(1:size(rmask,1),1:size(rmask,2),1:size(rmask,3),1:1) => rmask + + call FMS_DIAG_FBCM_PNAME_ (ofield_cfg, ofield_index_cfg, ofb_ptr, sample, & + & l_start, l_end, rmask_ptr, rmask_thresh, missvalue) + END SUBROUTINE FMS_DIAG_FBCM_3D_PNAME_ + + + !> @brief This code will be used by the preprocessor to generate an implementation + !! of the module procedure for the fieldbuff_copy_misvals interface. + !! The function updates where appropriate and depending on the rmask argument, + !! elements of the running field output buffer (argument buffer) with value missvalue. + !! NOTE: It appears these OFB updates were introcuded by EMC MM into the tail end of the + !! legacy send_data_3d. + SUBROUTINE FMS_DIAG_FBCM_PNAME_ (ofield_cfg, ofield_index_cfg, buffer, sample, & + & l_start, l_end, rmask, rmask_thresh, missvalue) + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The fmsDiagOutfield_type object, + !! where "cfg" is short for configuration + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The fmsDiagOutfieldIndex_type object, + !!where "cfg" is short for configuration + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout), DIMENSION(:,:,:,:,:) :: buffer !< the buffer to update + INTEGER, INTENT(in) :: sample !< index along the diurnal time axis + INTEGER, INTENT(in), DIMENSION(3):: l_start !< local start indices on 3 axes for regional output + INTEGER, INTENT(in), DIMENSION(3):: l_end !< local end indices on 3 axes for regional output + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in), DIMENSION(:,:,:,:):: rmask !< Updates where rmask < rmask_thresh + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: rmask_thresh !< Updates where rmask < rmask_thresh + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !< Value used to update the buffer. + + !< Looping indices copied from corresponding one in ofield_index_cfg info: + INTEGER :: is, js, ks, ie, je, ke, hi, hj + !< Floags copied from corresponding one in ofield_cfg info: + LOGICAL :: need_compute !< A copy of same variable in ofield_cfg + LOGICAL :: reduced_k_range !< A copy of same variable in ofield_cfg + INTEGER :: ksr, ker !< Loop indices used in reduced_k_range calculations + !< Looping indices, derived from ofield_index_cfg info: + INTEGER :: i, j, k, i1, j1, k1 + + is = ofield_index_cfg%get_is() + js = ofield_index_cfg%get_js() + ks = ofield_index_cfg%get_ks() + ie = ofield_index_cfg%get_ie() + je = ofield_index_cfg%get_je() + ke = ofield_index_cfg%get_ke() + hi = ofield_index_cfg%get_hi() + hj = ofield_index_cfg%get_hj() + + reduced_k_range = ofield_cfg%get_reduced_k_range() + need_compute = ofield_cfg%get_need_compute() + + associate(ofb => buffer) + + ! If rmask and missing value present, then insert missing value + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + IF ( l_start(1)+hi <= i .AND. i <= l_end(1)+hi .AND. l_start(2)+hj <= j .AND.& + & j <= l_end(2)+hj ) THEN + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + where ( rmask(i-is+1+hi,j-js+1+hj,k,:) <= rmask_thresh ) + ofb(i1,j1,k1,:,sample) = missvalue + end where + END IF + END DO + END DO + END DO + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + DO k= ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( rmask(i-is+1+hi,j-js+1+hj,k,:) <= rmask_thresh ) + ofb(i-hi,j-hj,k1,:,sample)= missvalue + endwhere + END DO + END DO + END DO + ELSE + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( rmask(i-is+1+hi,j-js+1+hj,k,:) <= rmask_thresh ) + ofb(i-hi,j-hj,k,:,sample)= missvalue + endwhere + END DO + END DO + END DO + END IF + end associate + END SUBROUTINE FMS_DIAG_FBCM_PNAME_ + !> @} diff --git a/diag_manager/include/fms_diag_fieldbuff_update.inc b/diag_manager/include/fms_diag_fieldbuff_update.inc new file mode 100644 index 0000000000..be6f51d0f1 --- /dev/null +++ b/diag_manager/include/fms_diag_fieldbuff_update.inc @@ -0,0 +1,50 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +#undef FMS_DIAG_FBU_DATA_TYPE_ +#define FMS_DIAG_FBU_DATA_TYPE_ REAL(r4_kind) +#undef FMS_DIAG_FBU_PNAME_ +#define FMS_DIAG_FBU_PNAME_ fieldbuff_update_r4 +#undef FMS_DIAG_FBU_3D_PNAME_ +#define FMS_DIAG_FBU_3D_PNAME_ fieldbuff_update_3d_r4 +#undef FMS_DIAG_FBCF_PNAME_ +#define FMS_DIAG_FBCF_PNAME_ fieldbuff_copy_fieldvals_r4 +#undef FMS_DIAG_FBCF_3D_PNAME_ +#define FMS_DIAG_FBCF_3D_PNAME_ fieldbuff_copy_fieldvals_3d_r4 +#undef FMS_DIAG_FBCM_PNAME_ +#define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_missvals_r4 +#undef FMS_DIAG_FBCM_3D_PNAME_ +#define FMS_DIAG_FBCM_3D_PNAME_ fieldbuff_copy_missvals_3d_r4 +#include + +#undef FMS_DIAG_FBU_DATA_TYPE_ +#define FMS_DIAG_FBU_DATA_TYPE_ REAL(r8_kind) +#undef FMS_DIAG_FBU_PNAME_ +#define FMS_DIAG_FBU_PNAME_ fieldbuff_update_r8 +#undef FMS_DIAG_FBU_3D_PNAME_ +#define FMS_DIAG_FBU_3D_PNAME_ fieldbuff_update_3d_r8 +#undef FMS_DIAG_FBCF_PNAME_ +#define FMS_DIAG_FBCF_PNAME_ fieldbuff_copy_fieldvals_r8 +#undef FMS_DIAG_FBCF_3D_PNAME_ +#define FMS_DIAG_FBCF_3D_PNAME_ fieldbuff_copy_fieldvals_3d_r8 +#undef FMS_DIAG_FBCM_PNAME_ +#define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_missvals_r8 +#undef FMS_DIAG_FBCM_3D_PNAME_ +#define FMS_DIAG_FBCM_3D_PNAME_ fieldbuff_copy_missvals_3d_r8 +#include diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index ed45102f7f..f5e646cd27 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -22,17 +22,18 @@ # uramirez, Ed Hartnett # Find the needed mod and .inc files. -AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/diag_manager/include -I$(MODDIR) # Link to the FMS library. LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. -check_PROGRAMS = test_diag_manager test_diag_manager_time +check_PROGRAMS = test_diag_manager test_diag_manager_time test_diag_update_buffer # This is the source code for the test. test_diag_manager_SOURCES = test_diag_manager.F90 test_diag_manager_time_SOURCES = test_diag_manager_time.F90 +test_diag_update_buffer_SOURCES= test_diag_update_buffer.F90 TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index a4d36cf52b..747be8e691 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -500,5 +500,9 @@ _EOF test_expect_success "diurnal test (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager_time ' - -test_done +setup_test +my_test_count=`expr $my_test_count + 1` +test_expect_success "Test the diag update_buffer (test $my_test_count)" ' + mpirun -n 1 ../test_diag_update_buffer +' + test_done diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 new file mode 100644 index 0000000000..67de3ec665 --- /dev/null +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -0,0 +1,491 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @brief This programs tests the update of field data buffers with +!! the "math" functions in module fms_diag_fieldbuff_update_mod. It mimics +!! the daig_manager::send_4d operation of calling those functions. +program test_diag_update_buffer + use platform_mod + use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated + use fms_mod, ONLY: fms_init, fms_end, error_mesg, FATAL,NOTE + use diag_data_mod, ONLY: VERY_LARGE_AXIS_LENGTH + USE fms_diag_outfield_mod, ONLY: fmsDiagOutfield_type, fmsDiagOutfieldIndex_type + USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_missvals, & + & fieldbuff_copy_fieldvals + USE fms_diag_time_reduction_mod, ONLY: fmsDiagTimeReduction_type, time_average, time_rms + USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type + + implicit none + + !! Class diag_buffer_type is here only for temporary use for modern diag_manager + !! development until the real buffer class is sufficiently ready and merged. + TYPE diagTestBuffer_type + CLASS(*), ALLOCATABLE, DIMENSION(:,:,:,:,:) :: buffer + CLASS(*), ALLOCATABLE, DIMENSION(:,:,:,:,:) :: counter + CLASS(*), ALLOCATABLE, DIMENSION(:) :: count_0d + INTEGER, ALLOCATABLE, dimension(:) :: num_elements + END TYPE diagTestBuffer_type + + integer,parameter :: SZ=10 !< Field data this size in all spatiall dims. + integer,parameter :: SL=2 !< Field data this size in 4th dim + integer,parameter :: NDI=1 !< Number of diurnal elemes + CLASS(*), ALLOCATABLE :: r4_datapoint, i8_datapoint !< to be allocated of rype data (e.g. r4. i8) + !! to be used thought. + + TYPE(fmsDiagIbounds_type) :: buff_bounds + + !!Diag_manager::send_data uses CLASS(*) in function signature, SO + !! we mimic the resulting operations. The set of ClASS(*) data needs to be allocated of same + !! type in order to be able to call the math/buffer update funtions. + CLASS(*), ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: field_data + CLASS(*), ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: rmask + CLASS(*), ALLOCATABLE, TARGET :: missvalue + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: mask + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: oor_mask + TYPE(diagTestBuffer_type), ALLOCATABLE, TARGET :: buff_obj + + !! In principle, the field_data can be r4,r8,i4,i8,but we will only rest r4,i8 + !!These belwo will be pointers to the data + REAL (kind=r4_kind),dimension (:,:,:,:),pointer::field_r4_ptr => null() !< Ptr to r4 field data array + REAL (kind=r4_kind),dimension (:,:,:,:),pointer::rmask_r4_ptr => null() !< Ptr to r4 field data rmask array + REAL (kind=r4_kind),pointer::missval_r4_ptr => null() !< Ptr to r4 missing value data. + INTEGER (kind=i8_kind),dimension (:,:,:,:),pointer::field_i8_ptr => null() !< Ptr to i8 field data array + INTEGER (kind=i8_kind),dimension (:,:,:,:),pointer::rmask_i8_ptr => null() !< Ptr to i8 field data rmask array + INTEGER (kind=i8_kind),pointer::missval_i8_ptr => null() !< Ptr to i8 missing value data. + + !! Typed pointers to buffer class(*) data will be needed + REAL (kind=r4_kind),dimension (:,:,:,:,:),pointer::ofb_r4_ptr => null() ! null() ! null() !< Ptr to r4 count0d member of buffer obj. + !! Typed pointers to buffer class(*) data will be needed + INTEGER (kind=i8_kind),dimension (:,:,:,:,:),pointer::ofb_i8_ptr => null() ! null() ! null() ! field_data + rmask_r4_ptr => rmask + missval_r4_ptr => missvalue + END SELECT + END SELECT + TYPE IS (integer(kind=i8_kind)) + SELECT TYPE ( rmask ) + TYPE IS (INTEGER(kind=i8_kind)) + SELECT TYPE ( missvalue ) + TYPE IS (INTEGER(kind=i8_kind)) + field_i8_ptr => field_data + rmask_i8_ptr => rmask + missval_i8_ptr => missvalue + END SELECT + END SELECT + CLASS DEFAULT + CALL error_mesg ('test_update_buffers_with_field','ptr assignemnt unsupported type', FATAL) + END SELECT + + SELECT TYPE ( ofb => buff_obj%buffer ) + TYPE IS (real(kind=r4_kind)) + SELECT TYPE ( ofc => buff_obj%counter ) + TYPE IS (real(kind=r4_kind)) + SELECT TYPE ( ofb0d => buff_obj%count_0d ) + TYPE IS (real(kind=r4_kind)) + ofb_r4_ptr => ofb + ofc_r4_ptr => ofc + ofb0d_r4_ptr => ofb0d + END SELECT + END SELECT + TYPE IS (integer(kind=i8_kind)) + SELECT TYPE ( ofc => buff_obj%counter ) + TYPE IS (INTEGER(kind=i8_kind)) + SELECT TYPE ( ofb0d => buff_obj%count_0d ) + TYPE IS (INTEGER(kind=i8_kind)) + ofb_i8_ptr => ofb + ofc_i8_ptr => ofc + ofb0d_i8_ptr => ofb0d + END SELECT + END SELECT + CLASS DEFAULT + CALL error_mesg ('diag_manager_mod::send_data_4d', 'ptr assigenment error', FATAL) + END SELECT + + + diag_field_id = 1 + sample = 1 + weight = 1.0 + missvalue = 1.0e-5 + pow_value = 1 + phys_window = .false. + need_compute = .false. + mask_variant = .false. + reduced_k_range = .false. + num_elems = 0 + num_threads = 1 + active_omp_level = 0 + issued_mask_ignore_warning = .false. + mask = .true. + + + call init_buff_values_1 (buff_obj%buffer, buff_obj%counter, buff_obj%count_0d, buff_obj%num_elements) + + hi = 0 !!halo size i + hj = 0 !!halo size j + l_start(1) = 1 !!local (to PE) start inddex + l_start(2) = 1 + l_start(3) = 1 + l_end(1) = SZ + l_end(2) = SZ + l_end(3) = SZ + + + ALLOCATE( ofield_cfg ) + call ofield_cfg%initialize_for_ut(module_name1, field_name1, output_name1, pow_value, & + & phys_window, need_compute, mask_variant, reduced_k_range , & + & num_elems, time_reduction_type1, output_freq1 ) + ALLOCATE( ofield_index_cfg ) + CALL init_ofield_index_cfg(ofield_index_cfg, 1+hi, 1+hj, 1, SZ - hi, SZ - hj, SZ,& + & hi, hj, 1 + hi, SZ - hi, 1 + hj, SZ - hj) + + !!First make sure buffer vals are all zero + call check_results_2(ofb_r4_ptr, 1, 0) + + !! Update the buffer values with the fieldbuff_update function. + !! Case: mask_var=false & missval not present & mask not present & not_reduced_k_range + test_passed = .true. !! will be set to false if there are any issues. + + temp_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_r4_ptr, sample, & + & ofb_r4_ptr, ofc_r4_ptr, buff_bounds, & + & ofb0d_r4_ptr (sample), buff_obj%num_elements(sample), & + & mask, weight, missval_r4_ptr, & + & num_threads, active_omp_level, & + & issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local ) + + call check_results_1(ofb_r4_ptr, 1, "Buffer_update_test01") + call print_output_field_values( buff_obj%buffer, 1 ) + + !! ************ 2ND TEST: ********************** + !!First make sure buffer vals are all zero + ofb_r4_ptr = 0 + call check_results_2(ofb_r4_ptr, 1, 0) + + !! Update the buffer values with the copy_fieldvals function. + ! missvalue_present = .true. TBD + !!call print_output_field_values( buff_obj%buffer, 1 ) + temp_result = fieldbuff_copy_fieldvals(ofield_cfg, ofield_index_cfg, field_r4_ptr, sample, & + & ofb_r4_ptr, buff_bounds, & + & ofb0d_r4_ptr(sample), mask, missval_r4_ptr, & + & l_start, l_end, err_msg, err_msg_local ) + + !!call print_output_field_values( buff_obj%buffer, 1 ) + + call check_results_1(ofb_r4_ptr, 1, "Buffer_update_test02") + + call error_mesg('test_diag_update_buffer', 'Test has finished',NOTE) + + call fms_end + +CONTAINS + + !> @brief Initialized an fms_diag_outfield_index_type by calling member funtion of + !! fms_diag_outfield_index_type input object. + SUBROUTINE init_ofield_index_cfg(idx_cfg, is, js , ks, ie, je, ke, hi, hj, f1, f2, f3, f4) + type(fmsDiagOutfieldIndex_type), INTENT(inout) :: idx_cfg !< The object to initialize. + INTEGER, INTENT(in) :: is, js, ks !< Var with same name in fms_diag_outfield_index_type + INTEGER, INTENT(in) :: ie, je, ke !< Var with same name in fms_diag_outfield_index_type + INTEGER, INTENT(in) :: hi, hj !< Var with same name in fms_diag_outfield_index_type + INTEGER, INTENT(in) :: f1, f2, f3, f4 !< Var with same name in fms_diag_outfield_index_type + call idx_cfg%initialize ( is, js , ks, ie, je, ke, hi, hj, f1, f2, f3, f4) + end subroutine init_ofield_index_cfg + + SUBROUTINE init_field_values (field) + CLASS(*), DIMENSION(:,:,:,:), INTENT(INOUT) :: field + INTEGER :: NX,NY,NZ, NL + INTEGER :: i,j,k,l + INTEGER :: itemp + NX = size(field,1) + NY= size(field,2) + NZ= size(field,3) + NL= size(field,4) + DO l = 1, NL + DO k = 1, NZ + DO j = 1, NY + DO i = 1, NX + SELECT TYPE ( field) + TYPE IS (real(kind=r4_kind)) + itemp = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) + field(i,j,k,l) = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) +1 TYPE IS (integer(kind=i8_kind)) + field(i,j,k,l) = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) + END SELECT + END DO + END DO + END DO + END DO + END SUBROUTINE init_field_values + + !> @brief Init to zero the buffer, counter , an + SUBROUTINE init_buff_values_1 (buffer, counter, count_0d, num_elems) + CLASS(*), DIMENSION(:,:,:,:,:), INTENT(INOUT) :: buffer !< The actual buffer array of the buffer class. + CLASS(*), DIMENSION(:,:,:,:,:), INTENT(INOUT) :: counter !< The actual buffer array of the buffer class. + CLASS(*), DIMENSION(:), INTENT(INOUT) :: count_0d !< A counter used in time averaging. + INTEGER, DIMENSION(:), INTENT(INOUT) :: num_elems !< A counter used in time averaging. + INTEGER, PARAMETER :: sample = 1 !< The diurnal sample. + + SELECT TYPE ( buffer) + TYPE IS (real(kind=r4_kind)) + buffer = 0 + TYPE IS (integer(kind=i8_kind)) + buffer = 0 + END SELECT + + SELECT TYPE ( counter) + TYPE IS (real(kind=r4_kind)) + counter = 0 + TYPE IS (integer(kind=i8_kind)) + counter = 0 + END SELECT + + SELECT TYPE ( count_0d) + TYPE IS (real(kind=r4_kind)) + count_0d = 0 + TYPE IS (integer(kind=i8_kind)) + count_0d = 0 + end select + + num_elems = 0 + END SUBROUTINE init_buff_values_1 + + + SUBROUTINE print_output_field_values (buffer, onum) + CLASS(*), ALLOCATABLE, DIMENSION(:,:,:,:,: ) :: buffer + INTEGER, INTENT(IN) :: onum + INTEGER :: i,j,k + INTEGER :: ti + REAL :: tr + print *, "Start of print_output_field_values" + k = 1 + DO j =1 ,10 + DO i = 1,10 + SELECT TYPE ( buffer) + TYPE IS (real(kind=r4_kind)) + !print "(10f10.1)", buffer(:,j,k,1,1) + tr = buffer(i,j,k,1,1) + print "(f10.1)", tr + TYPE IS (integer(kind=i8_kind)) + !print "(10I10)", buffer(:,j,k,1,1) + !print "(I8))", buffer(i,j,k,1,1) + print "(I8)", ti + END SELECT + end do + print *, "************************" + end do + print *, "End of print_output_field_values" + END SUBROUTINE print_output_field_values + +!> @brief Verify that the buffer data is equal to the expected index value + SUBROUTINE check_results_1(buff, sample, test_name) + CLASS(*), DIMENSION(:,:,:,:,:), INTENT(IN) :: buff !< The 5D buffer + INTEGER, INTENT(in) :: sample !< The diurnal sample + CHARACTER(*), INTENT(in) :: test_name !< The test name + INTEGER :: NX,NY,NZ, NL + INTEGER :: i,j,k,l + LOGICAL :: pass + integer :: idx + real :: bv + pass = .true. + NX = size(buff,1) + NY= size(buff,2) + NZ= size(buff,3) + NL= size(buff,4) + + DO l = 1, NL + DO k = 1, NZ + DO j = 1, NY + DO i = 1, NX + SELECT TYPE ( buff) + TYPE IS (real(kind=r4_kind)) + idx = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) + bv = buff(i,j,k,l,sample) + if ( get_array_index_from_4D(i,j,k,l,NX,NY,NZ) /= buff(i,j,k,l,sample) ) then + pass = .false. + endif + TYPE IS (integer(kind=i8_kind)) + if ( get_array_index_from_4D(i,j,k,l,NX,NY,NZ) /= buff(i,j,k,l,sample) ) then + pass = .false. + endif + END SELECT + END DO + END DO + END DO + END DO + if ( pass .eqv. .false.) then + call error_mesg('check_results_1', test_name//" has failed.",FATAL) + end if + end subroutine check_results_1 + + SUBROUTINE check_results_2(buff, sample, val) + CLASS(*), DIMENSION(:,:,:,:,:), INTENT(IN) :: buff + INTEGER, INTENT(in) :: sample + INTEGER, INTENT(in) :: val + INTEGER :: NX,NY,NZ, NL + INTEGER :: i,j,k,l + LOGICAL :: pass + + pass = .true. + NX = size(buff,1) + NY= size(buff,2) + NZ= size(buff,3) + NL= size(buff,4) + DO l = 1, NL + DO k = 1, NZ + DO j = 1, NY + DO i = 1, NX + SELECT TYPE ( buff) + TYPE IS (real(kind=r4_kind)) + if ( buff(i,j,k,l,sample) /= val ) then + pass = .false. + endif + TYPE IS (integer(kind=i8_kind)) + if ( buff(i,j,k,l,sample) /= val ) then + pass = .false. + endif + END SELECT + END DO + END DO + END DO + END DO + if ( pass .eqv. .false.) then + call error_mesg('check_results_2', 'Test has failed',FATAL) + end if + end subroutine check_results_2 + + !> @brief Calculate the unique index into a 4D array given the first four indecies + !! i,j,k,l and the with in the fist three dimensions. + pure integer function get_array_index_from_4D(i,j,k, l, NX,NY,NZ) + INTEGER, INTENT(IN) :: i, j, k, l !< The three spatial dimentsions plus another + INTEGER, INTENT(IN) :: NX, NY, NZ !< The size of the spatial dimentions. + get_array_index_from_4D = (l-1)* (NX * NY * NZ) + (k-1) * NX * NY + (j-1) * NX + i + end function get_array_index_from_4D + + subroutine allocate_input_data_and_ptrs(datapoint, field_data, rmask, missvalue, mask, NX,NY,NZ, NL) + CLASS(*), INTENT(in) :: datapoint !!The type of data we want + CLASS(*), ALLOCATABLE, INTENT(inout), DIMENSION(:,:,:,:) :: field_data + CLASS(*), ALLOCATABLE, INTENT(inout), DIMENSION(:,:,:,:) :: rmask + CLASS(*), ALLOCATABLE, INTENT(inout) :: missvalue + LOGICAL, ALLOCATABLE, INTENT(inout), DIMENSION(:,:,:,:) :: mask + INTEGER , INTENT(in) :: NX,NY,NZ, NL + select type (datapoint) + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: field_data(NX,NY,NZ,NL)) + allocate(integer(kind=i8_kind) :: rmask(NX,NY,NZ,NL)) + allocate(integer(kind=i8_kind) :: missvalue) + type is (real(kind=r4_kind)) + allocate(real(kind=r4_kind) :: field_data(NX,NY,NZ,NL)) + allocate(real(kind=r4_kind) :: rmask(NX,NY,NZ,NL)) + allocate(real(kind=r4_kind) :: missvalue) + class default + call error_mesg("allocate input data", "The input data type is not a r4 or i8", FATAL) + end select + + allocate(mask(NX,NY,NZ,NL)) + END subroutine allocate_input_data_and_ptrs + + + subroutine allocate_buffer_obj( data_point, bo, NX,NY,NZ, NL, NDI) + TYPE(diagTestBuffer_type), INTENT(inout), allocatable :: bo + CLASS(*), INTENT(in) :: data_point !< Sample point allocated to the type being tested. + INTEGER, INTENT(IN) :: NX, NY, NZ !< The three spatial dimensions. + INTEGER, INTENT(IN) :: NL !< Size of the 4th dimentions + INTEGER, INTENT(IN) :: NDI !< Diurnal axis length, + allocate (bo) + select type (data_point) + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: bo%buffer(NX,NY,NZ,NL, NDI)) + allocate(integer(kind=i8_kind) :: bo%counter(NX,NY,NZ,NL, NDI)) + allocate(integer(kind=i8_kind) :: bo%count_0d(NDI)) + type is (real(kind=r4_kind)) + allocate(real(kind=r4_kind) :: bo%buffer(NX,NY,NZ,NL,NDI)) + allocate(real(kind=r4_kind) :: bo%counter(NX,NY,NZ,NL,NDI)) + allocate(real(kind=r4_kind) :: bo%count_0d(NDI)) + class default + call error_mesg("allocate buffer obj", "The input data type is not a r4 or i8", FATAL) + end select + + allocate( bo%num_elements(NDI)) + + END subroutine allocate_buffer_obj +end program test_diag_update_buffer + + From 74d8e734bd43b0ce043003da74896e5d747afc2f Mon Sep 17 00:00:00 2001 From: Miguel R Zuniga <42479054+ngs333@users.noreply.github.com> Date: Mon, 27 Feb 2023 12:01:30 -0500 Subject: [PATCH 09/51] fix: adds tags to nested do loops in fms_diag_fieldbuff.fh to fix history file issues (#1139) --- .../include/fms_diag_fieldbuff_update.fh | 22 ++++++++----------- 1 file changed, 9 insertions(+), 13 deletions(-) diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index 52fa7259d6..ae1bb0038c 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -591,18 +591,18 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END DO END DO IF ( .NOT.phys_window ) THEN - DO l = ls, le + outer0: DO l = ls, le DO k = l_start(3), l_end(3) DO j=l_start(2)+hj, l_end(2)+hj DO i=l_start(1)+hi, l_end(1)+hi IF (field_d(i,j, k, l) /= missvalue ) THEN count_0d = count_0d + weight1 - EXIT + EXIT outer0 END IF END DO END DO END DO - END DO + END DO outer0 END IF !$OMP END CRITICAL ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_3_IF @@ -642,20 +642,19 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & !$OMP END CRITICAL END IF !$OMP CRITICAL - DO l = ls, le + outer3: DO l = ls, le DO k = ksr, ker k1=k-ksr+1 DO j=f3, f4 DO i=f1, f2 - !!TODO: verify this and similar ones. Note the EXIT statement IF ( field_d(i,j, k, l) /= missvalue ) THEN count_0d = count_0d + weight1 - EXIT + EXIT outer3 END IF END DO END DO END DO - END DO + END DO outer3 !$OMP END CRITICAL ELSE NDCMP_RKR_3_IF IF ( debug_diag_manager ) THEN @@ -698,18 +697,18 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & !$OMP END CRITICAL END IF !$OMP CRITICAL - DO l = ls, le + outer1: DO l = ls, le DO k=ks, ke DO j=f3, f4 DO i=f1, f2 IF ( field_d(i,j, k, l) /= missvalue ) THEN count_0d = count_0d + weight1 - EXIT + EXIT outer1 END IF END DO END DO END DO - END DO + END DO outer1 !$OMP END CRITICAL END IF NDCMP_RKR_3_IF ELSE MISSVAL_PR_3_IF !!(section: mask_variant .eq. false + mask not present + missvalue not present) @@ -1213,7 +1212,6 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & j <= l_end(2)+hj ) THEN i1 = i-l_start(1)-hi+1 j1 = j-l_start(2)-hj+1 - !!TODO: Make sure this where is appropritate with .NOT. WHERE ( .NOT.mask(i-is+1+hi,j-js+1+hj,k,:) ) & & OFB(i1,j1,k1,:,sample) = missvalue END IF @@ -1227,7 +1225,6 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, k1= k - ksr + 1 DO j=js, je DO i=is, ie - !!TODO: Make sure this where is appropritate with .NOT. WHERE ( mask(i-is+1+hi,j-js+1+hj,k,:) .eqv. .false.) & & OFB(i-hi,j-hj,k1,:,sample)= missvalue END DO @@ -1237,7 +1234,6 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, DO k=ks, ke DO j=js, je DO i=is, ie - !!TODO: Make sure this where is appropritate with .NOT. WHERE ( .NOT. mask(i-is+1+hi,j-js+1+hj,k,:) )& & OFB(i-hi,j-hj,k,:,sample)= missvalue END DO From 9b83c8c4fd5deab29aac1741fc3ad4d7342612ea Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Thu, 9 Mar 2023 15:44:20 -0500 Subject: [PATCH 10/51] fix - gnu and pgi issue with class(*) in send_data3d (#1149) --- diag_manager/diag_manager.F90 | 46 ++++++++++++++++++++++++++--------- 1 file changed, 35 insertions(+), 11 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index e78ee3e6f9..828d267c56 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1315,7 +1315,7 @@ LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg) & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT - send_data_0d = send_data_3d(diag_field_id, field_out, time, err_msg=err_msg) + send_data_0d = diag_send_data(diag_field_id, field_out, time, err_msg=err_msg) END FUNCTION send_data_0d !> @return true if send is successful @@ -1370,18 +1370,18 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN - send_data_1d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& + send_data_1d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& & mask=mask_out, ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg) ELSE - send_data_1d = send_data_3d(diag_field_id, field_out, time, mask=mask_out,& + send_data_1d = diag_send_data(diag_field_id, field_out, time, mask=mask_out,& & weight=weight, err_msg=err_msg) END IF ELSE IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN - send_data_1d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& + send_data_1d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& & ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg) ELSE - send_data_1d = send_data_3d(diag_field_id, field_out, time, weight=weight, err_msg=err_msg) + send_data_1d = diag_send_data(diag_field_id, field_out, time, weight=weight, err_msg=err_msg) END IF END IF END FUNCTION send_data_1d @@ -1438,10 +1438,10 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & END IF IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN - send_data_2d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1, mask=mask_out,& - & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) + send_data_2d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,& + & mask=mask_out, ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) ELSE - send_data_2d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,& + send_data_2d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,& & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) END IF END FUNCTION send_data_2d @@ -1454,6 +1454,30 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CLASS(*), INTENT(in), OPTIONAL :: weight TYPE (time_type), INTENT(in), OPTIONAL :: time INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in + LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask + CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg + + if (present(mask) .and. present(rmask)) then + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + mask=mask, rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, & + err_msg=err_msg) + elseif (present(rmask)) then + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) + else + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) + endif + END FUNCTION send_data_3d + !> @return true if send is successful + LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, & + & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) + INTEGER, INTENT(in) :: diag_field_id + CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field + CLASS(*), INTENT(in), OPTIONAL :: weight + TYPE (time_type), INTENT(in), OPTIONAL :: time + INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL, contiguous, target :: mask CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg @@ -1503,10 +1527,10 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN - send_data_3d = .FALSE. + diag_send_data = .FALSE. RETURN ELSE - send_data_3d = .TRUE. + diag_send_data = .TRUE. END IF IF ( PRESENT(err_msg) ) err_msg = '' @@ -3219,7 +3243,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & DEALLOCATE(field_out) DEALLOCATE(oor_mask) - END FUNCTION send_data_3d + END FUNCTION diag_send_data !> @return true if send is successful LOGICAL FUNCTION send_tile_averaged_data1d ( id, field, area, time, mask ) From 9339b88d9fe1afe75913d6b820c8249019ab0efd Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Thu, 9 Mar 2023 15:45:52 -0500 Subject: [PATCH 11/51] feat: extend `string` interface in `fms_string_utils_mod` (#1142) --- CMakeLists.txt | 2 + string_utils/Makefile.am | 5 +- string_utils/fms_string_utils.F90 | 98 +++++++++++++++------ string_utils/include/fms_string_utils.inc | 87 ++++++++++++++++++ string_utils/include/fms_string_utils_r4.fh | 30 +++++++ string_utils/include/fms_string_utils_r8.fh | 30 +++++++ test_fms/string_utils/test_string_utils.F90 | 93 +++++++++++++++++++ 7 files changed, 315 insertions(+), 30 deletions(-) create mode 100644 string_utils/include/fms_string_utils.inc create mode 100644 string_utils/include/fms_string_utils_r4.fh create mode 100644 string_utils/include/fms_string_utils_r8.fh diff --git a/CMakeLists.txt b/CMakeLists.txt index 930f37c426..a4759aaa72 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -296,6 +296,7 @@ foreach(kind ${kinds}) target_include_directories(${libTgt}_f PRIVATE include fms fms2_io/include + string_utils/include mpp/include diag_manager/include constants4 @@ -334,6 +335,7 @@ foreach(kind ${kinds}) $ $ $ + $ $ $) diff --git a/string_utils/Makefile.am b/string_utils/Makefile.am index ca0c3ab5ef..408c5eea7a 100644 --- a/string_utils/Makefile.am +++ b/string_utils/Makefile.am @@ -21,7 +21,7 @@ # package. # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/string_utils/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build this uninstalled convenience library. @@ -30,6 +30,9 @@ noinst_LTLIBRARIES = libstring_utils.la # The convenience library depends on its source. libstring_utils_la_SOURCES = \ fms_string_utils.F90 \ + include/fms_string_utils.inc \ + include/fms_string_utils_r4.fh \ + include/fms_string_utils_r8.fh \ fms_string_utils_binding.c MODFILES = \ diff --git a/string_utils/fms_string_utils.F90 b/string_utils/fms_string_utils.F90 index cf2dcd0376..78d086f571 100644 --- a/string_utils/fms_string_utils.F90 +++ b/string_utils/fms_string_utils.F90 @@ -28,6 +28,7 @@ !> @{ module fms_string_utils_mod use, intrinsic :: iso_c_binding + use platform_mod, only: r4_kind, r8_kind, i4_kind, i8_kind use mpp_mod implicit none @@ -43,6 +44,7 @@ module fms_string_utils_mod public :: fms_cstring2cpointer public :: string public :: string_copy + public :: stringify !> @} interface @@ -112,11 +114,12 @@ subroutine c_free(ptr) bind(c,name="free") module procedure cpointer_fortran_conversion end interface -!> Converts a number to a string +!> Converts an array of real numbers to a string !> @ingroup fms_mod -interface string - module procedure string_from_integer - module procedure string_from_real +interface stringify + module procedure stringify_1d_r4, stringify_1d_r8 + module procedure stringify_2d_r4, stringify_2d_r8 + module procedure stringify_3d_r4, stringify_3d_r8 end interface !> @addtogroup fms_string_utils_mod @@ -237,31 +240,65 @@ subroutine fms_f2c_string (dest, str_in) enddo end subroutine fms_f2c_string - - !> @brief Converts an integer to a string - !> @return The integer as a string - function string_from_integer(i) result (res) - integer, intent(in) :: i !< Integer to be converted to a string - character(:),allocatable :: res !< String converted frominteger - character(range(i)+2) :: tmp !< Temp string that is set to correct size - write(tmp,'(i0)') i - res = trim(tmp) - return - - end function string_from_integer - - !####################################################################### - !> @brief Converts a real to a string - !> @return The real number as a string - function string_from_real(r) - real, intent(in) :: r !< Real number to be converted to a string - character(len=32) :: string_from_real - - write(string_from_real,*) r - - return - - end function string_from_real + !> @brief Converts a number or a Boolean value to a string + !> @return The argument as a string + function string(v, fmt) + class(*), intent(in) :: v !< Value to be converted to a string + character(*), intent(in), optional :: fmt !< Optional format string for a real or integral argument + character(:), allocatable :: string + + select type(v) + type is (logical) + if (present(fmt)) then + call mpp_error(WARNING, "string(): Ignoring `fmt` argument for type `logical`") + endif + if (v) then + string = "True" + else + string = "False" + endif + + type is (integer(i4_kind)) + allocate(character(32) :: string) + if (present(fmt)) then + write(string, "(" // fmt // ")") v + else + write(string, '(i0)') v + endif + string = trim(adjustl(string)) + + type is (integer(i8_kind)) + allocate(character(32) :: string) + if (present(fmt)) then + write(string, "(" // fmt // ")") v + else + write(string, '(i0)') v + endif + string = trim(adjustl(string)) + + type is (real(r4_kind)) + allocate(character(32) :: string) + if (present(fmt)) then + write(string, "(" // fmt // ")") v + else + write(string, *) v + endif + string = trim(adjustl(string)) + + type is (real(r8_kind)) + allocate(character(32) :: string) + if (present(fmt)) then + write(string, "(" // fmt // ")") v + else + write(string, *) v + endif + string = trim(adjustl(string)) + + class default + call mpp_error(FATAL, "string(): Called with incompatible argument type. Possible types & + &include integer(4), integer(8), real(4), real(8), or logical.") + end select + end function string !> @brief Safely copy a string from one buffer to another. subroutine string_copy(dest, source, check_for_null) @@ -290,6 +327,9 @@ subroutine string_copy(dest, source, check_for_null) dest = adjustl(trim(source(1:i))) end subroutine string_copy +#include "fms_string_utils_r4.fh" +#include "fms_string_utils_r8.fh" + end module fms_string_utils_mod !> @} ! close documentation grouping diff --git a/string_utils/include/fms_string_utils.inc b/string_utils/include/fms_string_utils.inc new file mode 100644 index 0000000000..db6e067c4f --- /dev/null +++ b/string_utils/include/fms_string_utils.inc @@ -0,0 +1,87 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @brief Converts a 1D array of real numbers to a string +!> @return The 1D array as a string +function STRINGIFY_1D_(arr, fmt) + real(STRING_UTILS_KIND_), dimension(:), intent(in) :: arr !< Real array to be converted to a string + character(*), intent(in), optional :: fmt !< Optional format string for the real array entries + character(:), allocatable :: STRINGIFY_1D_ + integer :: i, n + + n = size(arr) + + if (n .gt. 0) then + STRINGIFY_1D_ = "[" // string(arr(1), fmt) + else + STRINGIFY_1D_ = "[" + endif + + do i = 2,n + STRINGIFY_1D_ = STRINGIFY_1D_ // ", " // string(arr(i), fmt) + enddo + + STRINGIFY_1D_ = STRINGIFY_1D_ // "]" +end function + +!> @brief Converts a 2D array of real numbers to a string +!> @return The 2D array as a string +function STRINGIFY_2D_(arr, fmt) + real(STRING_UTILS_KIND_), dimension(:,:), intent(in) :: arr !< Real array to be converted to a string + character(*), intent(in), optional :: fmt !< Optional format string for the real array entries + character(:), allocatable :: STRINGIFY_2D_ + integer :: i, n + + n = size(arr, 2) + + if (n .gt. 0) then + STRINGIFY_2D_ = "[" // STRINGIFY_1D_(arr(:,1), fmt) + else + STRINGIFY_2D_ = "[" + endif + + do i = 2,n + STRINGIFY_2D_ = STRINGIFY_2D_ // ", " // STRINGIFY_1D_(arr(:,i), fmt) + enddo + + STRINGIFY_2D_ = STRINGIFY_2D_ // "]" +end function + +!> @brief Converts a 3D array of real numbers to a string +!> @return The 3D array as a string +function STRINGIFY_3D_(arr, fmt) + real(STRING_UTILS_KIND_), dimension(:,:,:), intent(in) :: arr !< Real array to be converted to a string + character(*), intent(in), optional :: fmt !< Optional format string for the real array entries + character(:), allocatable :: STRINGIFY_3D_ + integer :: i, n + + n = size(arr, 3) + + if (n .gt. 0) then + STRINGIFY_3D_ = "[" // STRINGIFY_2D_(arr(:,:,1), fmt) + else + STRINGIFY_3D_ = "[" + endif + + do i = 2,n + STRINGIFY_3D_ = STRINGIFY_3D_ // ", " // STRINGIFY_2D_(arr(:,:,i), fmt) + enddo + + STRINGIFY_3D_ = STRINGIFY_3D_ // "]" +end function diff --git a/string_utils/include/fms_string_utils_r4.fh b/string_utils/include/fms_string_utils_r4.fh new file mode 100644 index 0000000000..c12cb7e001 --- /dev/null +++ b/string_utils/include/fms_string_utils_r4.fh @@ -0,0 +1,30 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +#define STRING_UTILS_KIND_ r4_kind +#define STRINGIFY_1D_ stringify_1d_r4 +#define STRINGIFY_2D_ stringify_2d_r4 +#define STRINGIFY_3D_ stringify_3d_r4 + +#include "fms_string_utils.inc" + +#undef STRING_UTILS_KIND_ +#undef STRINGIFY_1D_ +#undef STRINGIFY_2D_ +#undef STRINGIFY_3D_ diff --git a/string_utils/include/fms_string_utils_r8.fh b/string_utils/include/fms_string_utils_r8.fh new file mode 100644 index 0000000000..4e40b1264a --- /dev/null +++ b/string_utils/include/fms_string_utils_r8.fh @@ -0,0 +1,30 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +#define STRING_UTILS_KIND_ r8_kind +#define STRINGIFY_1D_ stringify_1d_r8 +#define STRINGIFY_2D_ stringify_2d_r8 +#define STRINGIFY_3D_ stringify_3d_r8 + +#include "fms_string_utils.inc" + +#undef STRING_UTILS_KIND_ +#undef STRINGIFY_1D_ +#undef STRINGIFY_2D_ +#undef STRINGIFY_3D_ diff --git a/test_fms/string_utils/test_string_utils.F90 b/test_fms/string_utils/test_string_utils.F90 index ff9f51ec4e..41d4923c71 100644 --- a/test_fms/string_utils/test_string_utils.F90 +++ b/test_fms/string_utils/test_string_utils.F90 @@ -22,6 +22,7 @@ program test_fms_string_utils use fms_string_utils_mod use fms_mod, only: fms_init, fms_end + use platform_mod, only: r4_kind, r8_kind, i4_kind, i8_kind use mpp_mod use, intrinsic :: iso_c_binding @@ -110,6 +111,9 @@ program test_fms_string_utils print *, "Checking if fms_find_unique determines the correct number of unique strings" if (nunique .ne. 7) call mpp_error(FATAL, "The number of unique strings in your array is not correct") + call check_string + call check_stringify + call fms_end() deallocate(my_array) @@ -165,4 +169,93 @@ subroutine check_my_indices(indices, ans, string) end do end subroutine check_my_indices + subroutine check_string + if (string(.true.) .ne. "True") then + call mpp_error(FATAL, "string() unit test failed for Boolean true value") + endif + + if (string(.false.) .ne. "False") then + call mpp_error(FATAL, "string() unit test failed for Boolean false value") + endif + + if (string(12345_i4_kind) .ne. "12345") then + call mpp_error(FATAL, "string() unit test failed for positive integer(4)") + endif + + if (string(-12345_i4_kind) .ne. "-12345") then + call mpp_error(FATAL, "string() unit test failed for negative integer(4)") + endif + + if (string(12345_i8_kind) .ne. "12345") then + call mpp_error(FATAL, "string() unit test failed for positive integer(8)") + endif + + if (string(-12345_i8_kind) .ne. "-12345") then + call mpp_error(FATAL, "string() unit test failed for negative integer(8)") + endif + + if (string(1._r4_kind, "F15.7") .ne. "1.0000000") then + call mpp_error(FATAL, "string() unit test failed for positive real(4)") + endif + + if (string(-1._r4_kind, "F15.7") .ne. "-1.0000000") then + call mpp_error(FATAL, "string() unit test failed for negative real(4)") + endif + + if (string(1._r8_kind, "F25.16") .ne. "1.0000000000000000") then + call mpp_error(FATAL, "string() unit test failed for positive real(8)") + endif + + if (string(-1._r8_kind, "F25.16") .ne. "-1.0000000000000000") then + call mpp_error(FATAL, "string() unit test failed for negative real(8)") + endif + end subroutine + + subroutine check_stringify + real(r4_kind) :: arr_1d_r4(3), arr_2d_r4(2, 2), arr_3d_r4(2, 2, 2) + real(r8_kind) :: arr_1d_r8(3), arr_2d_r8(2, 2), arr_3d_r8(2, 2, 2) + + arr_1d_r4 = [0._r4_kind, 1._r4_kind, 2._r4_kind] + if (stringify(arr_1d_r4, "F15.7") .ne. "[0.0000000, 1.0000000, 2.0000000]") then + call mpp_error(FATAL, "stringify() unit test failed for 1D r4 array") + endif + + arr_1d_r8 = [0._r8_kind, 1._r8_kind, 2._r8_kind] + if (stringify(arr_1d_r8, "F25.16") .ne. "[0.0000000000000000, 1.0000000000000000, 2.0000000000000000]") then + call mpp_error(FATAL, "stringify() unit test failed for 1D r8 array") + endif + + arr_2d_r4 = reshape([[0._r4_kind, 1._r4_kind], [2._r4_kind, 3._r4_kind]], [2, 2]) + if (stringify(arr_2d_r4, "F15.7") .ne. & + & "[[0.0000000, 1.0000000], [2.0000000, 3.0000000]]") then + call mpp_error(FATAL, "stringify() unit test failed for 2D r4 array") + endif + + arr_2d_r8 = reshape([[0._r8_kind, 1._r8_kind], [2._r8_kind, 3._r8_kind]], [2, 2]) + if (stringify(arr_2d_r8, "F25.16") .ne. & + & "[[0.0000000000000000, 1.0000000000000000], [2.0000000000000000, 3.0000000000000000]]") then + call mpp_error(FATAL, "stringify() unit test failed for 2D r8 array") + endif + + arr_3d_r4 = reshape([ & + & [[0._r4_kind, 1._r4_kind], [2._r4_kind, 3._r4_kind]], & + & [[4._r4_kind, 5._r4_kind], [6._r4_kind, 7._r4_kind]] & + & ], [2, 2, 2]) + if (stringify(arr_3d_r4, "F15.7") .ne. & + & "[[[0.0000000, 1.0000000], [2.0000000, 3.0000000]],& + & [[4.0000000, 5.0000000], [6.0000000, 7.0000000]]]") then + call mpp_error(FATAL, "stringify() unit test failed for 3D r4 array") + endif + + arr_3d_r8 = reshape([ & + & [[0._r8_kind, 1._r8_kind], [2._r8_kind, 3._r8_kind]], & + & [[4._r8_kind, 5._r8_kind], [6._r8_kind, 7._r8_kind]] & + & ], [2, 2, 2]) + if (stringify(arr_3d_r8, "F25.16") .ne. & + & "[[[0.0000000000000000, 1.0000000000000000], [2.0000000000000000, 3.0000000000000000]],& + & [[4.0000000000000000, 5.0000000000000000], [6.0000000000000000, 7.0000000000000000]]]") then + call mpp_error(FATAL, "stringify() unit test failed for 3D r8 array") + endif + end subroutine + end program test_fms_string_utils From 0ff254e409b74d7d17ab234abe5ecd985967256c Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Thu, 9 Mar 2023 15:47:47 -0500 Subject: [PATCH 12/51] fix: add omp directives for race condition in tridiagonal (#1109) --- tridiagonal/tridiagonal.F90 | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/tridiagonal/tridiagonal.F90 b/tridiagonal/tridiagonal.F90 index 3aaddf070c..c22f99c4ee 100644 --- a/tridiagonal/tridiagonal.F90 +++ b/tridiagonal/tridiagonal.F90 @@ -89,8 +89,10 @@ subroutine tri_invert(x,d,a,b,c) integer :: k if(present(a)) then - init_tridiagonal = .true. + !< Check if module variables are allocated + !$OMP SINGLE + init_tridiagonal = .true. if(allocated(e)) deallocate(e) if(allocated(g)) deallocate(g) if(allocated(bb)) deallocate(bb) @@ -99,6 +101,7 @@ subroutine tri_invert(x,d,a,b,c) allocate(g (size(x,1),size(x,2),size(x,3))) allocate(bb(size(x,1),size(x,2))) allocate(cc(size(x,1),size(x,2),size(x,3))) + !$OMP END SINGLE !< There is an implicit barrier. e(:,:,1) = - a(:,:,1)/b(:,:,1) a(:,:,size(x,3)) = 0.0 @@ -132,12 +135,15 @@ end subroutine tri_invert !> @brief Releases memory used by the solver subroutine close_tridiagonal -implicit none + implicit none -deallocate(e) -deallocate(g) -deallocate(bb) -deallocate(cc) + !< Check if module variables are allocated + !$OMP SINGLE + if(allocated(e)) deallocate(e) + if(allocated(g)) deallocate(g) + if(allocated(bb)) deallocate(bb) + if(allocated(cc)) deallocate(cc) + !$OMP END SINGLE !< There is an implicit barrier. return end subroutine close_tridiagonal From 63626578cb8ed4bed1ce670b88acd6a1ec438e32 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Mon, 13 Mar 2023 10:22:06 -0400 Subject: [PATCH 13/51] fix: missing if statement in PR #1149 (#1155) --- diag_manager/diag_manager.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 828d267c56..92fdf0e122 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1465,6 +1465,9 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & elseif (present(rmask)) then send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) + elseif (present(mask)) then + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + mask=mask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) else send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) From 7188e3a2e634376da74c3e4247bc9b487ef52700 Mon Sep 17 00:00:00 2001 From: MiKyung Lee <58964324+mlee03@users.noreply.github.com> Date: Tue, 28 Mar 2023 08:54:27 -0400 Subject: [PATCH 14/51] fix: time_manager missing changes from year to yr, month to mo, day to dy (#1169) --- time_interp/time_interp.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/time_interp/time_interp.F90 b/time_interp/time_interp.F90 index 83cacec3f4..87e146714a 100644 --- a/time_interp/time_interp.F90 +++ b/time_interp/time_interp.F90 @@ -391,7 +391,7 @@ subroutine time_interp_month ( Time, weight, year1, year2, month1, month2 ) ! mid point of current month in seconds mid_month = days_in_month(Time) * halfday ! time into current month in seconds - cur_month = second + secmin*minute + sechour*hour + secday*(day-1) + cur_month = second + secmin*minute + sechour*hour + secday*(dy-1) if ( cur_month >= mid_month ) then ! current time is after mid point of current month @@ -466,8 +466,8 @@ subroutine time_interp_day ( Time, weight, year1, year2, month1, month2, day1, d endif else ! current time is before mid point of day - year2 = year; month2 = month; day2 = day - year1 = year; month1 = month; day1 = day - 1 + year2 = yr; month2 = mo ; day2 = dy + year1 = yr; month1 = mo; day1 = dy - 1 weight = real(sday + halfday) / real(secday) if (day1 < 1) then From 8a78face399bca9b121e3f94c0389d43d8cf39aa Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Mon, 3 Apr 2023 14:31:20 -0400 Subject: [PATCH 15/51] chore: update changelog and version numbers for release (#1167) --- CHANGELOG.md | 37 +++++++++++++++++++++++++++++++++++++ CMakeLists.txt | 2 +- configure.ac | 2 +- libFMS/Makefile.am | 2 +- 4 files changed, 40 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 67752821b4..55522567bb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,43 @@ and this project uses `yyyy.rr[.pp]`, where `yyyy` is the year a patch is releas `rr` is a sequential release number (starting from `01`), and an optional two-digit sequential patch number (starting from `01`). +## [2023.01] - 2023-04-03 +### Known Issues +- If using GCC 10 or higher as well as MPICH, compilation errors will occur unless `-fallow-argument-mismatch` is included in the Fortran compiler flags(the flag will now be added automatically if building with autotools or CMake). +- GCC 11.1.0 is unsupported due to compilation issues with select type. The issue is resolved in later GCC releases. +- When outputting sub-region diagnostics, the current diag_manager does not add "tileX" to the filename when using a cube sphere. This leads to trouble when trying to combine the files and regrid them (if the region is in two different tiles) + +### Added +- DIAG_MANAGER: Added code refactored as part of larger diag_manager rewrite for the send_data routines. The refactored code is disabled by default and enabled by setting `use_refactored_send` to true in the diag_manager_nml, and should mirror current behaviour. +- FMS2_IO: Added the ability to set deflate_level and shuffle netcdf options in `fms2_io_nml`. Also added functionality for registering dimensions as unlimited compressed. +- YAML_PARSER: Added support for emitting multiple tabbed section keys to allow diag manager yaml output + +### Changed +- STRING_UTILS: Extended the `string` interface in fms_string_utils_mod to accept reals of 4 or 8 kind, as well as 1, 2, and 3 dimensional real arrays +- DIAG_MANAGER: Changed the `log_diag_field_info` routine to allow for specifying seperator +- INTERPOLATOR(s): In horiz_interp, amip_interp and interpolator, changed pointers arrays into allocatables + +### Fixed +- TRIDIAGONAL: Added OMP directives to prevent race conditions +- DIAG_MANAGER: Added `diag_send_data` routine to fix class(\*) related compiler issues from the refactor update +- SAT_VAPOR_PRES_K: Removed implied saves causing issues with class(\*) type checking +- TIME_INTERP: Fixed naming conflicts between module level and local variables +- YAML_PARSER: Fixed typo in variable name, rename variables to avoid fortran keywords +- DOCS: Fixed incorrect serial build instructions +- COMPILER SUPPORT: Fixed compilation errors with Intel's llvm-based compiler and added support for the CMake build. Also fixed mpp_checksum unit test failures with openmpi and nvhpc compilation issues. +- TIME_MANAGER: Fixed an bug from PR #1169 that was causing answer changes in land models + +### Tag Commit Hashes +- 2023.01-beta4 (63626578cb8ed4bed1ce670b88acd6a1ec438e32) +- 2023.01-beta3 (0ff254e409b74d7d17ab234abe5ecd985967256c) +- 2023.01-beta2 (74d8e734bd43b0ce043003da74896e5d747afc2f) +- 2023.01-beta1 (6255971af28381fad22547bdc2c538fc3ea2e8bf) +- 2023.01-alpha4 (4526cc94a3e19fe8fa151f54b0db432e1fb2f7d0) +- 2023.01-alpha3 (f0e8cab3d8e58195f7c2663b84fd0bed12fa8b64) +- 2023.01-alpha2 (91e732473f7cffce070f9ce239f8ffa22c081261) +- 2023.01-alpha1 (203c8bf464ff26fe0fe39b1451caedd026bbce55) + + ## [2022.04] - 2022-10-13 ### Known Issues - If using GCC 10 or higher as well as MPICH, compilation errors will occur unless `-fallow-argument-mismatch` is included in the Fortran compiler flags(the flag will now be added automatically if building with autotools or CMake). diff --git a/CMakeLists.txt b/CMakeLists.txt index a4759aaa72..473d8b91f9 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -26,7 +26,7 @@ set(CMAKE_Fortran_FLAGS_DEBUG) # Define the CMake project project(FMS - VERSION 2022.04.0 + VERSION 2023.01.0 DESCRIPTION "GFDL FMS Library" HOMEPAGE_URL "https://www.gfdl.noaa.gov/fms" LANGUAGES C Fortran) diff --git a/configure.ac b/configure.ac index 7f3a1c0087..ea919ccbc8 100644 --- a/configure.ac +++ b/configure.ac @@ -25,7 +25,7 @@ AC_PREREQ([2.69]) # Initialize with name, version, and support email address. AC_INIT([GFDL FMS Library], - [2022.04.00-dev], + [2023.01.00], [gfdl.climate.model.info@noaa.gov], [FMS], [https://www.github.com/NOAA-GFDL/FMS]) diff --git a/libFMS/Makefile.am b/libFMS/Makefile.am index 868c792d4c..e56820e701 100644 --- a/libFMS/Makefile.am +++ b/libFMS/Makefile.am @@ -28,7 +28,7 @@ lib_LTLIBRARIES = libFMS.la # These linker flags specify libtool version info. # See http://www.gnu.org/software/libtool/manual/libtool.html#Libtool-versioning # for information regarding incrementing `-version-info`. -libFMS_la_LDFLAGS = -version-info 14:0:0 +libFMS_la_LDFLAGS = -version-info 15:0:0 # Add the convenience libraries to the FMS library. libFMS_la_LIBADD = $(top_builddir)/platform/libplatform.la From 003b8e1e39a7cd8e38120075b42ceec257881d25 Mon Sep 17 00:00:00 2001 From: "github-actions[bot]" <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 6 Apr 2023 08:26:07 -0400 Subject: [PATCH 16/51] chore: append dev to version number post-release (#1179) --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index ea919ccbc8..799fa4ba48 100644 --- a/configure.ac +++ b/configure.ac @@ -25,7 +25,7 @@ AC_PREREQ([2.69]) # Initialize with name, version, and support email address. AC_INIT([GFDL FMS Library], - [2023.01.00], + [2023.01.00-dev], [gfdl.climate.model.info@noaa.gov], [FMS], [https://www.github.com/NOAA-GFDL/FMS]) From 011b510f35a170f1a19f1e5c7f5bb2550e4da146 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Fri, 16 Jun 2023 15:56:01 -0400 Subject: [PATCH 17/51] feat: merge 2023.01.01 changes into main (#1259) * fix: fms2 io performance update for domain_reads (#1226) * fix: fms2 io performance update for compressed writes (#1227) * chore: build/log updates for patch (#1247) Co-authored-by: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Co-authored-by: rem1776 --- CHANGELOG.md | 15 + fms2_io/include/compressed_write.inc | 479 +++++++------- fms2_io/include/domain_read.inc | 663 +++++++++----------- fms2_io/netcdf_io.F90 | 1 + mpp/include/mpp_comm.inc | 22 + mpp/include/mpp_domains_util.inc | 8 + mpp/mpp.F90 | 6 + test_fms/fms2_io/Makefile.am | 4 +- test_fms/fms2_io/test_compressed_writes.F90 | 290 +++++++++ test_fms/fms2_io/test_domain_io.F90 | 312 +++++++++ test_fms/fms2_io/test_fms2_io.sh | 69 ++ 11 files changed, 1267 insertions(+), 602 deletions(-) create mode 100644 test_fms/fms2_io/test_compressed_writes.F90 create mode 100644 test_fms/fms2_io/test_domain_io.F90 diff --git a/CHANGELOG.md b/CHANGELOG.md index 55522567bb..0cc9802f8f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,21 @@ and this project uses `yyyy.rr[.pp]`, where `yyyy` is the year a patch is releas `rr` is a sequential release number (starting from `01`), and an optional two-digit sequential patch number (starting from `01`). +## [2023.01.01] - 2023-06-06 +### Changed +- FMS2_IO: Performance changes for domain_reads_2d and domain_reads_3d: + - Root pe reads the data + - Uses mpp_scatter to send the data to the other pes + - Added unit tests to test all of the domain_read/domain_write interfaces + +- FMS2_IO: Performance changes for compressed_writes_1d/2d/3d + - Uses mpp_gather to get data for write + - Added unit tests to test all of the compressed writes interfaces + - Compressed_writes_4d/5d were unchanged + +- FMS2_IO: Extended mpp_scatter and mpp_gather to work for int8; added a kludge for scatter since the data is assumed to be (x,y,z) + + ## [2023.01] - 2023-04-03 ### Known Issues - If using GCC 10 or higher as well as MPICH, compilation errors will occur unless `-fallow-argument-mismatch` is included in the Fortran compiler flags(the flag will now be added automatically if building with autotools or CMake). diff --git a/fms2_io/include/compressed_write.inc b/fms2_io/include/compressed_write.inc index dffff9ea94..cd2919c162 100644 --- a/fms2_io/include/compressed_write.inc +++ b/fms2_io/include/compressed_write.inc @@ -81,31 +81,32 @@ end subroutine compressed_write_0d_wrap subroutine compressed_write_1d(fileobj, variable_name, cdata, unlim_dim_level, & corner, edge_lengths) - class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. - character(len=*), intent(in) :: variable_name !< Variable name. - class(*), dimension(:), intent(in) :: cdata !< Compressed data that - !! will be gathered and - !! written to the - !! netcdf file. - integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited - !! dimension. - integer, dimension(1), intent(in), optional :: corner !< Array of starting - !! indices describing - !! where the data - !! will be written to. - integer, dimension(1), intent(in), optional :: edge_lengths !< The number of - !! elements that - !! will be written - !! in each dimension. - - integer, dimension(2) :: compressed_dim_index - integer, dimension(1) :: c - integer, dimension(1) :: e - integer :: i - integer(kind=i4_kind), dimension(:), allocatable :: buf_i4_kind - integer(kind=i8_kind), dimension(:), allocatable :: buf_i8_kind - real(kind=r4_kind), dimension(:), allocatable :: buf_r4_kind - real(kind=r8_kind), dimension(:), allocatable :: buf_r8_kind + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + class(*), dimension(:), intent(in) :: cdata !< Compressed data that + !! will be gathered and + !! written to the + !! netcdf file. + integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited + !! dimension. + integer, dimension(1), intent(in), optional :: corner !< Array of starting + !! indices describing + !! where the data + !! will be written to. + integer, dimension(1), intent(in), optional :: edge_lengths !< The number of + !! elements that + !! will be written + !! in each dimension. + + integer, dimension(2) :: compressed_dim_index !< index of the compressed dimension + !! compressed_dim_index(1) relative to cdata + !! compressed_dim_index(2) relative to the fileobj + integer, dimension(1) :: e !< "edges" number of points to read + + integer(kind=i4_kind), dimension(:), allocatable :: buf_i4_kind !< Global buffer of data + integer(kind=i8_kind), dimension(:), allocatable :: buf_i8_kind !< Global buffer of data + real (kind=r4_kind), dimension(:), allocatable :: buf_r4_kind !< Global buffer of data + real (kind=r8_kind), dimension(:), allocatable :: buf_r8_kind !< Global buffer of data character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message @@ -120,66 +121,54 @@ subroutine compressed_write_1d(fileobj, variable_name, cdata, unlim_dim_level, & return endif - !Gather the data onto the I/O root and write it out. + e(:) = shape(cdata) + !The root pe creates a buffer big enough to store the data: if (fileobj%is_root) then - c(:) = 1 - e(:) = shape(cdata) - do i = 1, size(fileobj%pelist) - c(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_corner(i) - e(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems(i) - if (i .eq. 1) then - call netcdf_write_data(fileobj, variable_name, cdata, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - else - select type(cdata) - type is (integer(kind=i4_kind)) - call allocate_array(buf_i4_kind, e) - call mpp_recv(buf_i4_kind, size(buf_i4_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_i4_kind) - type is (integer(kind=i8_kind)) - call allocate_array(buf_i8_kind, e) - call mpp_recv(buf_i8_kind, size(buf_i8_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_i8_kind) - type is (real(kind=r4_kind)) - call allocate_array(buf_r4_kind, e) - call mpp_recv(buf_r4_kind, size(buf_r4_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_r4_kind) - type is (real(kind=r8_kind)) - call allocate_array(buf_r8_kind, e) - call mpp_recv(buf_r8_kind, size(buf_r8_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_r8_kind) - class default - call error("unsupported variable type: "//trim(append_error_msg)) - end select - endif - enddo - else + e(compressed_dim_index(1)) = sum(fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems) select type(cdata) type is (integer(kind=i4_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_i4_kind, e) type is (integer(kind=i8_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_i8_kind, e) type is (real(kind=r4_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_r4_kind, e) type is (real(kind=r8_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_r8_kind, e) class default call error("unsupported variable type: "//trim(append_error_msg)) - end select - call mpp_sync_self(check=EVENT_SEND) + end select + endif + + !Gather the data onto the I/O root and write it out. + select type(cdata) + type is (integer(kind=i4_kind)) + call mpp_gather(cdata, size(cdata), buf_i4_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & + fileobj%pelist) + call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & + unlim_dim_level=unlim_dim_level) + type is (integer(kind=i8_kind)) + call mpp_gather(cdata, size(cdata), buf_i8_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & + fileobj%pelist) + call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & + unlim_dim_level=unlim_dim_level) + type is (real(kind=r4_kind)) + call mpp_gather(cdata, size(cdata), buf_r4_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & + fileobj%pelist) + call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & + unlim_dim_level=unlim_dim_level) + type is (real(kind=r8_kind)) + call mpp_gather(cdata, size(cdata), buf_r8_kind, fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems, & + fileobj%pelist) + call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & + unlim_dim_level=unlim_dim_level) + class default + call error("unsupported variable type: "//trim(append_error_msg)) + end select + if (fileobj%is_root) then + if (allocated(buf_i4_kind)) deallocate(buf_i4_kind) + if (allocated(buf_i8_kind)) deallocate(buf_i8_kind) + if (allocated(buf_r4_kind)) deallocate(buf_r4_kind) + if (allocated(buf_r8_kind)) deallocate(buf_r8_kind) endif end subroutine compressed_write_1d @@ -191,33 +180,43 @@ end subroutine compressed_write_1d subroutine compressed_write_2d(fileobj, variable_name, cdata, unlim_dim_level, & corner, edge_lengths) - class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. - character(len=*), intent(in) :: variable_name !< Variable name. - class(*), dimension(:,:), intent(in) :: cdata !< Compressed data that - !! will be gathered and - !! written to the - !! netcdf file. - integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited - !! dimension. - integer, dimension(2), intent(in), optional :: corner !< Array of starting - !! indices describing - !! where the data - !! will be written to. - integer, dimension(2), intent(in), optional :: edge_lengths !< The number of - !! elements that - !! will be written - !! in each dimension. + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + class(*), dimension(:,:), intent(in) :: cdata !< Compressed data that + !! will be gathered and + !! written to the + !! netcdf file. + integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited + !! dimension. + integer, dimension(2), intent(in), optional :: corner !< Array of starting + !! indices describing + !! where the data + !! will be written to. + integer, dimension(2), intent(in), optional :: edge_lengths !< The number of + !! elements that + !! will be written + !! in each dimension. + + integer, dimension(2) :: compressed_dim_index !< index of the compressed dimension + !! compressed_dim_index(1) relative to cdata + !! compressed_dim_index(2) relative to the fileobj + integer, dimension(2) :: c !! corners of the data to read + integer, dimension(2) :: e !< "edges" number of points to read + + integer(kind=i4_kind), dimension(:,:), allocatable :: buf_i4_kind !< Global buffer of data + integer(kind=i8_kind), dimension(:,:), allocatable :: buf_i8_kind !< Global buffer of data + real (kind=r4_kind), dimension(:,:), allocatable :: buf_r4_kind !< Global buffer of data + real (kind=r8_kind), dimension(:,:), allocatable :: buf_r8_kind !< Global buffer of data - integer, dimension(2) :: compressed_dim_index - integer, dimension(2) :: c - integer, dimension(2) :: e - integer :: i - integer(kind=i4_kind), dimension(:,:), allocatable :: buf_i4_kind - integer(kind=i8_kind), dimension(:,:), allocatable :: buf_i8_kind - real(kind=r4_kind), dimension(:,:), allocatable :: buf_r4_kind - real(kind=r8_kind), dimension(:,:), allocatable :: buf_r8_kind character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message + integer :: index(1) !< index of the PE in the pelist + + integer :: is !< Starting index of the first dimension + integer :: ie !< Ending index of the first dimension + integer :: js !< Starting index of the second dimension + integer :: je !< Ending index of the second dimension + append_error_msg = "compressed_write_2d: file:"//trim(fileobj%path)//" variable:"//trim(variable_name) compressed_dim_index = get_variable_compressed_dimension_index(fileobj, variable_name) @@ -228,66 +227,68 @@ subroutine compressed_write_2d(fileobj, variable_name, cdata, unlim_dim_level, & return endif - !Gather the data onto the I/O root and write it out. + e(:) = shape(cdata) + !The root pe creates a buffer big enough to store the data: if (fileobj%is_root) then - c(:) = 1 - e(:) = shape(cdata) - do i = 1, size(fileobj%pelist) - c(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_corner(i) - e(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems(i) - if (i .eq. 1) then - call netcdf_write_data(fileobj, variable_name, cdata, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - else - select type(cdata) - type is (integer(kind=i4_kind)) - call allocate_array(buf_i4_kind, e) - call mpp_recv(buf_i4_kind, size(buf_i4_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_i4_kind) - type is (integer(kind=i8_kind)) - call allocate_array(buf_i8_kind, e) - call mpp_recv(buf_i8_kind, size(buf_i8_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_i8_kind) - type is (real(kind=r4_kind)) - call allocate_array(buf_r4_kind, e) - call mpp_recv(buf_r4_kind, size(buf_r4_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_r4_kind) - type is (real(kind=r8_kind)) - call allocate_array(buf_r8_kind, e) - call mpp_recv(buf_r8_kind, size(buf_r8_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_r8_kind) - class default - call error("unsupported variable type: "//trim(append_error_msg)) - end select - endif - enddo - else + e(compressed_dim_index(1)) = sum(fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems) select type(cdata) type is (integer(kind=i4_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_i4_kind, e) type is (integer(kind=i8_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_i8_kind, e) type is (real(kind=r4_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_r4_kind, e) type is (real(kind=r8_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_r8_kind, e) class default call error("unsupported variable type: "//trim(append_error_msg)) - end select - call mpp_sync_self(check=EVENT_SEND) + end select + endif + + c(:) = 1 + index = FINDLOC(fileobj%pelist, mpp_pe()) + + c(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_corner(index(1)) + e(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems(index(1)) + + if (compressed_dim_index(1) .eq. 1) then + is = c(compressed_dim_index(1)) + ie = c(compressed_dim_index(1)) + e(compressed_dim_index(1)) - 1 + js = 1 + je = size(cdata,2) + else + js = c(compressed_dim_index(1)) + je = c(compressed_dim_index(1)) + e(compressed_dim_index(1)) - 1 + is = 1 + ie = size(cdata,2) + endif + + select type(cdata) + type is (integer(kind=i4_kind)) + call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_i4_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & + unlim_dim_level=unlim_dim_level) + type is (integer(kind=i8_kind)) + call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_i8_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & + unlim_dim_level=unlim_dim_level) + type is (real(kind=r4_kind)) + call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_r4_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & + unlim_dim_level=unlim_dim_level) + type is (real(kind=r8_kind)) + call mpp_gather(is, ie, js, je, fileobj%pelist, cdata, buf_r8_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & + unlim_dim_level=unlim_dim_level) + class default + call error("unsupported variable type: "//trim(append_error_msg)) + end select + + if (fileobj%is_root) then + if (allocated(buf_i4_kind)) deallocate(buf_i4_kind) + if (allocated(buf_i8_kind)) deallocate(buf_i8_kind) + if (allocated(buf_r4_kind)) deallocate(buf_r4_kind) + if (allocated(buf_r8_kind)) deallocate(buf_r8_kind) endif end subroutine compressed_write_2d @@ -299,32 +300,43 @@ end subroutine compressed_write_2d subroutine compressed_write_3d(fileobj, variable_name, cdata, unlim_dim_level, & corner, edge_lengths) - class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. - character(len=*), intent(in) :: variable_name !< Variable name. - class(*), dimension(:,:,:), intent(in) :: cdata !< Compressed data that - !! will be gathered and - !! written to the - !! netcdf file. - integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited - !! dimension. - integer, dimension(3), intent(in), optional :: corner !< Array of starting - !! indices describing - !! where the data - !! will be written to. - integer, dimension(3), intent(in), optional :: edge_lengths !< The number of - !! elements that - !! will be written - !! in each dimension. + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + class(*), contiguous, intent(in), target :: cdata(:,:,:) !< Compressed data that + !! will be gathered and + !! written to the + !! netcdf file. + integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited + !! dimension. + integer, dimension(3), intent(in), optional :: corner !< Array of starting + !! indices describing + !! where the data + !! will be written to. + integer, dimension(3), intent(in), optional :: edge_lengths !< The number of + !! elements that + !! will be written + !! in each dimension. + + integer, dimension(2) :: compressed_dim_index !< index of the compressed dimension + !! compressed_dim_index(1) relative to cdata + !! compressed_dim_index(2) relative to the fileobj + integer, dimension(3) :: c !! corners of the data to read + integer, dimension(3) :: e !< "edges" number of points to read + + integer(kind=i4_kind), dimension(:,:,:), allocatable :: buf_i4_kind !< Global buffer of data + integer(kind=i8_kind), dimension(:,:,:), allocatable :: buf_i8_kind !< Global buffer of data + real (kind=r4_kind), dimension(:,:,:), allocatable :: buf_r4_kind !< Global buffer of data + real (kind=r8_kind), dimension(:,:,:), allocatable :: buf_r8_kind !< Global buffer of data - integer, dimension(2) :: compressed_dim_index - integer, dimension(3) :: c - integer, dimension(3) :: e - integer :: i - integer(kind=i4_kind), dimension(:,:,:), allocatable :: buf_i4_kind - integer(kind=i8_kind), dimension(:,:,:), allocatable :: buf_i8_kind - real(kind=r4_kind), dimension(:,:,:), allocatable :: buf_r4_kind - real(kind=r8_kind), dimension(:,:,:), allocatable :: buf_r8_kind character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message + class(*), pointer :: cdata_dummy(:,:,:,:) + + integer :: index(1) !< index of the PE in the pelist + + integer :: is !< Starting index of the first dimension + integer :: ie !< Ending index of the first dimension + integer :: js !< Starting index of the second dimension + integer :: je !< Ending index of the second dimension append_error_msg = "compressed_write_3d: file:"//trim(fileobj%path)//" variable:"//trim(variable_name) @@ -334,68 +346,77 @@ subroutine compressed_write_3d(fileobj, variable_name, cdata, unlim_dim_level, & unlim_dim_level=unlim_dim_level, corner=corner, & edge_lengths=edge_lengths) return + else if (compressed_dim_index(1) .eq. 3) then + cdata_dummy(1:size(cdata,1), 1:size(cdata,2), 1:size(cdata,3), 1:1) => cdata(:,:,:) + call compressed_write_4d(fileobj, variable_name, cdata_dummy, unlim_dim_level) endif - !Gather the data onto the I/O root and write it out. + e(:) = shape(cdata) + !The root pe creates a buffer big enough to store the data: if (fileobj%is_root) then - c(:) = 1 - e(:) = shape(cdata) - do i = 1, size(fileobj%pelist) - c(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_corner(i) - e(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems(i) - if (i .eq. 1) then - call netcdf_write_data(fileobj, variable_name, cdata, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - else - select type(cdata) - type is (integer(kind=i4_kind)) - call allocate_array(buf_i4_kind, e) - call mpp_recv(buf_i4_kind, size(buf_i4_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_i4_kind) - type is (integer(kind=i8_kind)) - call allocate_array(buf_i8_kind, e) - call mpp_recv(buf_i8_kind, size(buf_i8_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_i8_kind) - type is (real(kind=r4_kind)) - call allocate_array(buf_r4_kind, e) - call mpp_recv(buf_r4_kind, size(buf_r4_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_r4_kind) - type is (real(kind=r8_kind)) - call allocate_array(buf_r8_kind, e) - call mpp_recv(buf_r8_kind, size(buf_r8_kind), fileobj%pelist(i), block=.true.) - call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & - unlim_dim_level=unlim_dim_level, corner=c, & - edge_lengths=e) - deallocate(buf_r8_kind) - class default - call error("unsupported variable type: "//trim(append_error_msg)) - end select - endif - enddo - else + e(compressed_dim_index(1)) = sum(fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems) select type(cdata) type is (integer(kind=i4_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_i4_kind, e) type is (integer(kind=i8_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_i8_kind, e) type is (real(kind=r4_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_r4_kind, e) type is (real(kind=r8_kind)) - call mpp_send(cdata, size(cdata), fileobj%io_root) + call allocate_array(buf_r8_kind, e) class default call error("unsupported variable type: "//trim(append_error_msg)) - end select - call mpp_sync_self(check=EVENT_SEND) + end select + endif + + c(:) = 1 + index = FINDLOC(fileobj%pelist, mpp_pe()) + + c(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_corner(index(1)) + e(compressed_dim_index(1)) = fileobj%compressed_dims(compressed_dim_index(2))%npes_nelems(index(1)) + + if (compressed_dim_index(1) .eq. 1) then + is = c(compressed_dim_index(1)) + ie = c(compressed_dim_index(1)) + e(compressed_dim_index(1)) - 1 + js = 1 + je = size(cdata,2) + else + js = c(compressed_dim_index(1)) + je = c(compressed_dim_index(1)) + e(compressed_dim_index(1)) - 1 + is = 1 + ie = size(cdata,2) + endif + + select type(cdata) + type is (integer(kind=i4_kind)) + call mpp_gather(is, ie, js, je, size(cdata,3), & + fileobj%pelist, cdata, buf_i4_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_i4_kind, & + unlim_dim_level=unlim_dim_level) + type is (integer(kind=i8_kind)) + call mpp_gather(is, ie, js, je, size(cdata,3), & + fileobj%pelist, cdata, buf_i8_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_i8_kind, & + unlim_dim_level=unlim_dim_level) + type is (real(kind=r4_kind)) + call mpp_gather(is, ie, js, je, size(cdata,3), & + fileobj%pelist, cdata, buf_r4_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_r4_kind, & + unlim_dim_level=unlim_dim_level) + type is (real(kind=r8_kind)) + call mpp_gather(is, ie, js, je, size(cdata,3), & + fileobj%pelist, cdata, buf_r8_kind, fileobj%is_root) + call netcdf_write_data(fileobj, variable_name, buf_r8_kind, & + unlim_dim_level=unlim_dim_level) + class default + call error("unsupported variable type: "//trim(append_error_msg)) + end select + + if (fileobj%is_root) then + if (allocated(buf_i4_kind)) deallocate(buf_i4_kind) + if (allocated(buf_i8_kind)) deallocate(buf_i8_kind) + if (allocated(buf_r4_kind)) deallocate(buf_r4_kind) + if (allocated(buf_r8_kind)) deallocate(buf_r8_kind) endif end subroutine compressed_write_3d diff --git a/fms2_io/include/domain_read.inc b/fms2_io/include/domain_read.inc index 3a70c067b2..13f142c19a 100644 --- a/fms2_io/include/domain_read.inc +++ b/fms2_io/include/domain_read.inc @@ -32,14 +32,14 @@ subroutine domain_read_0d(fileobj, variable_name, vdata, unlim_dim_level, corner type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. character(len=*), intent(in) :: variable_name !< Variable name. class(*), intent(inout) :: vdata !< Data that will - !! be written out + !! be read out !! to the netcdf file. integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited !! dimension. integer, intent(in), optional :: corner !< Array of starting !! indices describing !! where the data - !! will be written to. + !! will be read to. call netcdf_read_data(fileobj, variable_name, vdata, & unlim_dim_level=unlim_dim_level, corner=corner, & @@ -59,17 +59,17 @@ subroutine domain_read_1d(fileobj, variable_name, vdata, unlim_dim_level, & type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. character(len=*), intent(in) :: variable_name !< Variable name. class(*), dimension(:), intent(inout) :: vdata !< Data that will - !! be written out + !! be read out !! to the netcdf file. integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited !! dimension. integer, dimension(1), intent(in), optional :: corner !< Array of starting !! indices describing !! where the data - !! will be written to. + !! will be read to. integer, dimension(1), intent(in), optional :: edge_lengths !< The number of !! elements that - !! will be written + !! will be read !! in each dimension. call netcdf_read_data(fileobj, variable_name, vdata, & @@ -86,48 +86,52 @@ end subroutine domain_read_1d !! decomposed". subroutine domain_read_2d(fileobj, variable_name, vdata, unlim_dim_level, & corner, edge_lengths) - - type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. - character(len=*), intent(in) :: variable_name !< Variable name. - class(*), dimension(:,:), intent(inout) :: vdata !< Data that will - !! be written out - !! to the netcdf file. - integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited - !! dimension. - integer, dimension(2), intent(in), optional :: corner !< Array of starting - !! indices describing - !! where the data - !! will be written to. - integer, dimension(2), intent(in), optional :: edge_lengths !< The number of - !! elements that - !! will be written - !! in each dimension. - - integer :: xdim_index - integer :: ydim_index - type(domain2d), pointer :: io_domain - integer :: xpos - integer :: ypos - integer :: i - integer :: isd - integer :: isc - integer :: xc_size - integer :: jsd - integer :: jsc - integer :: yc_size - integer, dimension(:), allocatable :: pe_isc - integer, dimension(:), allocatable :: pe_icsize - integer, dimension(:), allocatable :: pe_jsc - integer, dimension(:), allocatable :: pe_jcsize - integer, dimension(2) :: c - integer, dimension(2) :: e - integer(kind=i4_kind), dimension(:,:), allocatable :: buf_i4_kind - integer(kind=i8_kind), dimension(:,:), allocatable :: buf_i8_kind - real(kind=r4_kind), dimension(:,:), allocatable :: buf_r4_kind - real(kind=r8_kind), dimension(:,:), allocatable :: buf_r8_kind - logical :: buffer_includes_halos - integer :: xgmin !< Starting x index of global io domain - integer :: ygmin !< Starting y index of global io domain + type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + class(*), contiguous, target, intent(inout) :: vdata(:,:) !< Data that will + !! be read out + !! to the netcdf file. + integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited + !! dimension. + integer, dimension(2), intent(in), optional :: corner !< Array of starting + !! indices describing + !! where the data + !! will be read to. + integer, dimension(2), intent(in), optional :: edge_lengths !< The number of + !! elements that + !! will be read + !! in each dimension. + + integer :: xdim_index !< The index of the variable that is the x dimension + integer :: ydim_index !< The index of the variable that is the y dimension + integer :: xpos !< The position of the x axis + integer :: ypos !< The position of the y axis + integer :: i !< For do loops + integer :: isd !< The starting x position of the data io_domain + integer :: isc !< The starting x position of the compute io_domain + integer :: xc_size !< The size of the x compute io_domain + integer :: yc_size !< The size of the y compute io_domain + integer :: jsd !< The ending x position of the data io_domain + integer :: jsc !< The ending y position of the compute io_domain + integer :: c(2) !< The corners of the data + integer :: e(2) !< The number of points (edges) + logical :: buffer_includes_halos !< .True. if vdata includes halo points + integer :: xgbegin !< Starting x index of global io domain + integer :: xgsize !< Size of global x io domain + integer :: ygbegin !< Starting y index of global io domain + integer :: ygsize !< Size of global y io domain + type(domain2d), pointer :: io_domain !< pointer to the io_domain + + !< The global data is only allocated by the io root PEs + integer(kind=i4_kind), dimension(:,:), allocatable :: buf_i4_kind_pe !< PES section of the data + integer(kind=i8_kind), dimension(:,:), allocatable :: buf_i8_kind_pe !< PES section of the data + real(kind=r4_kind), dimension(:,:), allocatable :: buf_r4_kind_pe !< PES section of the data + real(kind=r8_kind), dimension(:,:), allocatable :: buf_r8_kind_pe !< PES section of the data + integer(kind=i4_kind), dimension(:,:), allocatable :: buf_i4_kind !< Global section of the data + integer(kind=i8_kind), dimension(:,:), allocatable :: buf_i8_kind !< Global section of the data + real(kind=r4_kind), dimension(:,:), allocatable :: buf_r4_kind !< Global section of the data + real(kind=r8_kind), dimension(:,:), allocatable :: buf_r8_kind !< Global section of the data + class(*), dimension(:,:,:,:), pointer :: vdata_dummy !< Vdata remapped as 4D if (.not. is_variable_domain_decomposed(fileobj, variable_name, .true., & xdim_index, ydim_index, xpos, ypos)) then @@ -136,6 +140,15 @@ subroutine domain_read_2d(fileobj, variable_name, vdata, unlim_dim_level, & edge_lengths=edge_lengths, broadcast=.true.) return endif + + if (xdim_index .ne. 1 .or. ydim_index .ne. 2) then + ! This is a KLUDGE + ! mpp_scatter assumes that the variable is (x,y), if that is not the case it remaps the data + ! to a 4D array and calls domain_read_4d which does not use mpp_scatter yet + vdata_dummy(1:size(vdata,1),1:size(vdata,2), 1:1, 1:1) => vdata(:,:) + call domain_read_4d(fileobj, variable_name, vdata_dummy, unlim_dim_level) + return + endif io_domain => mpp_get_io_domain(fileobj%domain) call domain_offsets(size(vdata, xdim_index), size(vdata, ydim_index), fileobj%domain, & xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, buffer_includes_halos, & @@ -143,159 +156,105 @@ subroutine domain_read_2d(fileobj, variable_name, vdata, unlim_dim_level, & c(:) = 1 e(:) = shape(vdata) + call mpp_get_global_domain(io_domain, xbegin=xgbegin, xsize=xgsize, position=xpos) + call mpp_get_global_domain(io_domain, ybegin=ygbegin, ysize=ygsize, position=ypos) + !I/O root reads in the data and scatters it. if (fileobj%is_root) then - allocate(pe_isc(size(fileobj%pelist))) - allocate(pe_icsize(size(fileobj%pelist))) - allocate(pe_jsc(size(fileobj%pelist))) - allocate(pe_jcsize(size(fileobj%pelist))) - call mpp_get_compute_domains(io_domain, xbegin=pe_isc, xsize=pe_icsize, position=xpos) - call mpp_get_compute_domains(io_domain, ybegin=pe_jsc, ysize=pe_jcsize, position=ypos) - call mpp_get_global_domain(io_domain, xbegin=xgmin, position=xpos) - call mpp_get_global_domain(io_domain, ybegin=ygmin, position=ypos) - do i = 1, size(fileobj%pelist) - c(xdim_index) = pe_isc(i) - c(ydim_index) = pe_jsc(i) - if (fileobj%adjust_indices) then - c(xdim_index) = c(xdim_index) - xgmin + 1 - c(ydim_index) = c(ydim_index) - ygmin + 1 - endif - e(xdim_index) = pe_icsize(i) - e(ydim_index) = pe_jcsize(i) - select type(vdata) - type is (integer(kind=i4_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_i4_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_i4_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_i4_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_i4_kind, size(buf_i4_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_i4_kind) - type is (integer(kind=i8_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_i8_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_i8_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_i8_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_i8_kind, size(buf_i8_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_i8_kind) - type is (real(kind=r4_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_r4_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_r4_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_r4_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_r4_kind, size(buf_r4_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_r4_kind) - type is (real(kind=r8_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_r8_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_r8_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_r8_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_r8_kind, size(buf_r8_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_r8_kind) - class default - call error("unsupported variable type: domain_read_2d: file: "//trim(fileobj%path)//" variable:"// & - & trim(variable_name)) - end select - enddo - deallocate(pe_isc) - deallocate(pe_icsize) - deallocate(pe_jsc) - deallocate(pe_jcsize) - else - if (buffer_includes_halos) then - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 + + if (fileobj%adjust_indices) then + !< If the file is distributed, the file only contains the io global domain + c(xdim_index) = 1 + c(ydim_index) = 1 + else + !< If the file is not distributed read, the file contains the global domain, + !! so you only need to read the global io domain + c(xdim_index) = xgbegin + c(ydim_index) = ygbegin endif - e(xdim_index) = xc_size - e(ydim_index) = yc_size + + e(xdim_index) = xgsize + e(ydim_index) = ygsize + + !Read in the global io domain select type(vdata) type is (integer(kind=i4_kind)) call allocate_array(buf_i4_kind, e) - call mpp_recv(buf_i4_kind, size(buf_i4_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_i4_kind, vdata, c, e) - deallocate(buf_i4_kind) + call netcdf_read_data(fileobj, variable_name, buf_i4_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) type is (integer(kind=i8_kind)) call allocate_array(buf_i8_kind, e) - call mpp_recv(buf_i8_kind, size(buf_i8_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_i8_kind, vdata, c, e) - deallocate(buf_i8_kind) + call netcdf_read_data(fileobj, variable_name, buf_i8_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) type is (real(kind=r4_kind)) call allocate_array(buf_r4_kind, e) - call mpp_recv(buf_r4_kind, size(buf_r4_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_r4_kind, vdata, c, e) - deallocate(buf_r4_kind) + call netcdf_read_data(fileobj, variable_name, buf_r4_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) type is (real(kind=r8_kind)) call allocate_array(buf_r8_kind, e) - call mpp_recv(buf_r8_kind, size(buf_r8_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_r8_kind, vdata, c, e) - deallocate(buf_r8_kind) + call netcdf_read_data(fileobj, variable_name, buf_r8_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) class default call error("unsupported variable type: domain_read_2d: file: "//trim(fileobj%path)//" variable:"// & - & trim(variable_name)) + & trim(variable_name)) end select + + endif + + c = 1 + e = shape(vdata) + + if (buffer_includes_halos) then + !Adjust if the input buffer has room for halos. + c(xdim_index) = isc - isd + 1 + c(ydim_index) = jsc - jsd + 1 + else + c(xdim_index) = 1 + c(ydim_index) = 1 + endif + + e(xdim_index) = xc_size + e(ydim_index) = yc_size + + select type(vdata) + type is (integer(kind=i4_kind)) + call allocate_array(buf_i4_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, fileobj%pelist, & + buf_i4_kind_pe, buf_i4_kind, fileobj%is_root) + call put_array_section(buf_i4_kind_pe, vdata, c, e) + deallocate(buf_i4_kind_pe) + type is (integer(kind=i8_kind)) + call allocate_array(buf_i8_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, fileobj%pelist, & + buf_i8_kind_pe, buf_i8_kind, fileobj%is_root) + call put_array_section(buf_i8_kind_pe, vdata, c, e) + deallocate(buf_i8_kind_pe) + type is (real(kind=r4_kind)) + call allocate_array(buf_r4_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, fileobj%pelist, & + buf_r4_kind_pe, buf_r4_kind, fileobj%is_root) + call put_array_section(buf_r4_kind_pe, vdata, c, e) + deallocate(buf_r4_kind_pe) + type is (real(kind=r8_kind)) + call allocate_array(buf_r8_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, fileobj%pelist, & + buf_r8_kind_pe, buf_r8_kind, fileobj%is_root) + call put_array_section(buf_r8_kind_pe, vdata, c, e) + deallocate(buf_r8_kind_pe) + class default + call error("unsupported variable type: domain_read_2d: file: "//trim(fileobj%path)//" variable:"// & + & trim(variable_name)) + end select + + if (fileobj%is_root) then + if (allocated(buf_i4_kind)) deallocate(buf_i4_kind) + if (allocated(buf_i8_kind)) deallocate(buf_i8_kind) + if (allocated(buf_r4_kind)) deallocate(buf_r4_kind) + if (allocated(buf_r8_kind)) deallocate(buf_r8_kind) endif end subroutine domain_read_2d @@ -307,48 +266,52 @@ end subroutine domain_read_2d !! decomposed". subroutine domain_read_3d(fileobj, variable_name, vdata, unlim_dim_level, & corner, edge_lengths) - - type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. - character(len=*), intent(in) :: variable_name !< Variable name. - class(*), dimension(:,:,:), intent(inout) :: vdata !< Data that will - !! be written out - !! to the netcdf file. - integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited - !! dimension. - integer, dimension(3), intent(in), optional :: corner !< Array of starting - !! indices describing - !! where the data - !! will be written to. - integer, dimension(3), intent(in), optional :: edge_lengths !< The number of - !! elements that - !! will be written - !! in each dimension. - - integer :: xdim_index - integer :: ydim_index - type(domain2d), pointer :: io_domain - integer :: xpos - integer :: ypos - integer :: i - integer :: isd - integer :: isc - integer :: xc_size - integer :: jsd - integer :: jsc - integer :: yc_size - integer, dimension(:), allocatable :: pe_isc - integer, dimension(:), allocatable :: pe_icsize - integer, dimension(:), allocatable :: pe_jsc - integer, dimension(:), allocatable :: pe_jcsize - integer, dimension(3) :: c - integer, dimension(3) :: e - integer(kind=i4_kind), dimension(:,:,:), allocatable :: buf_i4_kind - integer(kind=i8_kind), dimension(:,:,:), allocatable :: buf_i8_kind - real(kind=r4_kind), dimension(:,:,:), allocatable :: buf_r4_kind - real(kind=r8_kind), dimension(:,:,:), allocatable :: buf_r8_kind - logical :: buffer_includes_halos - integer :: xgmin !< Starting x index of global io domain - integer :: ygmin !< Starting y index of global io domain + type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + class(*), contiguous, target, intent(inout) :: vdata(:,:,:) !< Data that will + !! be read out + !! to the netcdf file. + integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited + !! dimension. + integer, dimension(3), intent(in), optional :: corner !< Array of starting + !! indices describing + !! where the data + !! will be read to. + integer, dimension(3), intent(in), optional :: edge_lengths !< The number of + !! elements that + !! will be read + !! in each dimension. + + integer :: xdim_index !< The index of the variable that is the x dimension + integer :: ydim_index !< The index of the variable that is the y dimension + integer :: xpos !< The position of the x axis + integer :: ypos !< The position of the y axis + integer :: i !< For do loops + integer :: isd !< The starting x position of the data io_domain + integer :: isc !< The starting x position of the compute io_domain + integer :: xc_size !< The size of the x compute io_domain + integer :: yc_size !< The size of the y compute io_domain + integer :: jsd !< The ending x position of the data io_domain + integer :: jsc !< The ending y position of the compute io_domain + integer :: c(3) !< The corners of the data + integer :: e(3) !< The number of points (edges) + logical :: buffer_includes_halos !< .True. if vdata includes halo points + integer :: xgbegin !< Starting x index of global io domain + integer :: xgsize !< Size of global x io domain + integer :: ygbegin !< Starting y index of global io domain + integer :: ygsize !< Size of global y io domain + type(domain2d), pointer :: io_domain !< pointer to the io_domain + + !< The global data is only allocated by the io root PEs + integer(kind=i4_kind), dimension(:,:,:), allocatable :: buf_i4_kind_pe !< PES section of the data + integer(kind=i8_kind), dimension(:,:,:), allocatable :: buf_i8_kind_pe !< PES section of the data + real(kind=r4_kind), dimension(:,:,:), allocatable :: buf_r4_kind_pe !< PES section of the data + real(kind=r8_kind), dimension(:,:,:), allocatable :: buf_r8_kind_pe !< PES section of the data + integer(kind=i4_kind), dimension(:,:,:), allocatable :: buf_i4_kind !< Global section of the data + integer(kind=i8_kind), dimension(:,:,:), allocatable :: buf_i8_kind !< Global section of the data + real(kind=r4_kind), dimension(:,:,:), allocatable :: buf_r4_kind !< Global section of the data + real(kind=r8_kind), dimension(:,:,:), allocatable :: buf_r8_kind !< Global section of the data + class(*), dimension(:,:,:,:), pointer :: vdata_dummy !< Vdata remapped as 4D if (.not. is_variable_domain_decomposed(fileobj, variable_name, .true., & xdim_index, ydim_index, xpos, ypos)) then @@ -357,6 +320,15 @@ subroutine domain_read_3d(fileobj, variable_name, vdata, unlim_dim_level, & edge_lengths=edge_lengths, broadcast=.true.) return endif + + if (xdim_index .ne. 1 .or. ydim_index .ne. 2) then + ! This is a KLUDGE + ! mpp_scatter assumes that the variable is (x,y), if that is not the case it remaps the data + ! to a 4D array and calls domain_read_4d which does not use mpp_scatter yet + vdata_dummy(1:size(vdata,1),1:size(vdata,2), 1:size(vdata,3), 1:1) => vdata(:,:,:) + call domain_read_4d(fileobj, variable_name, vdata_dummy, unlim_dim_level) + return + endif io_domain => mpp_get_io_domain(fileobj%domain) call domain_offsets(size(vdata, xdim_index), size(vdata, ydim_index), fileobj%domain, & xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, buffer_includes_halos, & @@ -364,160 +336,107 @@ subroutine domain_read_3d(fileobj, variable_name, vdata, unlim_dim_level, & c(:) = 1 e(:) = shape(vdata) + call mpp_get_global_domain(io_domain, xbegin=xgbegin, xsize=xgsize, position=xpos) + call mpp_get_global_domain(io_domain, ybegin=ygbegin, ysize=ygsize, position=ypos) + !I/O root reads in the data and scatters it. if (fileobj%is_root) then - allocate(pe_isc(size(fileobj%pelist))) - allocate(pe_icsize(size(fileobj%pelist))) - allocate(pe_jsc(size(fileobj%pelist))) - allocate(pe_jcsize(size(fileobj%pelist))) - call mpp_get_compute_domains(io_domain, xbegin=pe_isc, xsize=pe_icsize, position=xpos) - call mpp_get_compute_domains(io_domain, ybegin=pe_jsc, ysize=pe_jcsize, position=ypos) - call mpp_get_global_domain(io_domain, xbegin=xgmin, position=xpos) - call mpp_get_global_domain(io_domain, ybegin=ygmin, position=ypos) - do i = 1, size(fileobj%pelist) - c(xdim_index) = pe_isc(i) - c(ydim_index) = pe_jsc(i) - if (fileobj%adjust_indices) then - c(xdim_index) = c(xdim_index) - xgmin + 1 - c(ydim_index) = c(ydim_index) - ygmin + 1 - endif - e(xdim_index) = pe_icsize(i) - e(ydim_index) = pe_jcsize(i) - select type(vdata) - type is (integer(kind=i4_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_i4_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_i4_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_i4_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_i4_kind, size(buf_i4_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_i4_kind) - type is (integer(kind=i8_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_i8_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_i8_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_i8_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_i8_kind, size(buf_i8_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_i8_kind) - type is (real(kind=r4_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_r4_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_r4_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_r4_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_r4_kind, size(buf_r4_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_r4_kind) - type is (real(kind=r8_kind)) - !Read in the data for fileobj%pelist(i)'s portion of the compute domain. - call allocate_array(buf_r8_kind, e) - call netcdf_read_data(fileobj, variable_name, buf_r8_kind, & - unlim_dim_level=unlim_dim_level, & - corner=c, edge_lengths=e, broadcast=.false.) - if (i .eq. 1) then - !Root rank stores data directly. - if (buffer_includes_halos) then - !Adjust if the input buffer has room for halos. - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 - else - c(xdim_index) = 1 - c(ydim_index) = 1 - endif - call put_array_section(buf_r8_kind, vdata, c, e) - else - !Send data to non-root ranks. - call mpp_send(buf_r8_kind, size(buf_r8_kind), fileobj%pelist(i)) - call mpp_sync_self(check=EVENT_SEND) - endif - deallocate(buf_r8_kind) - class default - call error("unsupported variable type: domain_read_3d: file: "//trim(fileobj%path)//" variable:"// & - & trim(variable_name)) - end select - enddo - deallocate(pe_isc) - deallocate(pe_icsize) - deallocate(pe_jsc) - deallocate(pe_jcsize) - else - if (buffer_includes_halos) then - c(xdim_index) = isc - isd + 1 - c(ydim_index) = jsc - jsd + 1 + + if (fileobj%adjust_indices) then + !< If the file is distributed, the file only contains the io global domain + c(xdim_index) = 1 + c(ydim_index) = 1 + else + !< If the file is not distributed read, the file contains the global domain, + !! so you only need to read the global io domain + c(xdim_index) = xgbegin + c(ydim_index) = ygbegin endif - e(xdim_index) = xc_size - e(ydim_index) = yc_size + + e(xdim_index) = xgsize + e(ydim_index) = ygsize + + !Read in the global io domain select type(vdata) type is (integer(kind=i4_kind)) call allocate_array(buf_i4_kind, e) - call mpp_recv(buf_i4_kind, size(buf_i4_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_i4_kind, vdata, c, e) - deallocate(buf_i4_kind) + call netcdf_read_data(fileobj, variable_name, buf_i4_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) type is (integer(kind=i8_kind)) call allocate_array(buf_i8_kind, e) - call mpp_recv(buf_i8_kind, size(buf_i8_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_i8_kind, vdata, c, e) - deallocate(buf_i8_kind) + call netcdf_read_data(fileobj, variable_name, buf_i8_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) type is (real(kind=r4_kind)) call allocate_array(buf_r4_kind, e) - call mpp_recv(buf_r4_kind, size(buf_r4_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_r4_kind, vdata, c, e) - deallocate(buf_r4_kind) + call netcdf_read_data(fileobj, variable_name, buf_r4_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) type is (real(kind=r8_kind)) call allocate_array(buf_r8_kind, e) - call mpp_recv(buf_r8_kind, size(buf_r8_kind), fileobj%io_root, block=.true.) - call put_array_section(buf_r8_kind, vdata, c, e) - deallocate(buf_r8_kind) + call netcdf_read_data(fileobj, variable_name, buf_r8_kind, & + unlim_dim_level=unlim_dim_level, & + corner=c, edge_lengths=e, broadcast=.false.) class default - call error("unsupported variable type: domain_read_3d: file: "//trim(fileobj%path)//" variable:"// & - & trim(variable_name)) + call error("unsupported variable type: domain_read_2d: file: "//trim(fileobj%path)//" variable:"// & + & trim(variable_name)) end select + + endif + + c = 1 + e = shape(vdata) + + if (buffer_includes_halos) then + !Adjust if the input buffer has room for halos. + c(xdim_index) = isc - isd + 1 + c(ydim_index) = jsc - jsd + 1 + else + c(xdim_index) = 1 + c(ydim_index) = 1 endif + + e(xdim_index) = xc_size + e(ydim_index) = yc_size + + select type(vdata) + type is (integer(kind=i4_kind)) + call allocate_array(buf_i4_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, e(3), fileobj%pelist, & + buf_i4_kind_pe, buf_i4_kind, fileobj%is_root) + call put_array_section(buf_i4_kind_pe, vdata, c, e) + deallocate(buf_i4_kind_pe) + type is (integer(kind=i8_kind)) + call allocate_array(buf_i8_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, e(3), fileobj%pelist, & + buf_i8_kind_pe, buf_i8_kind, fileobj%is_root) + call put_array_section(buf_i8_kind_pe, vdata, c, e) + deallocate(buf_i8_kind_pe) + type is (real(kind=r4_kind)) + call allocate_array(buf_r4_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, e(3), fileobj%pelist, & + buf_r4_kind_pe, buf_r4_kind, fileobj%is_root) + call put_array_section(buf_r4_kind_pe, vdata, c, e) + deallocate(buf_r4_kind_pe) + type is (real(kind=r8_kind)) + call allocate_array(buf_r8_kind_pe, e) + call mpp_scatter(isc-xgbegin+1, isc+xc_size-xgbegin, jsc-ygbegin+1, jsc+yc_size-ygbegin, e(3), fileobj%pelist, & + buf_r8_kind_pe, buf_r8_kind, fileobj%is_root) + call put_array_section(buf_r8_kind_pe, vdata, c, e) + deallocate(buf_r8_kind_pe) + class default + call error("unsupported variable type: domain_read_2d: file: "//trim(fileobj%path)//" variable:"// & + & trim(variable_name)) + end select + + if (fileobj%is_root) then + if (allocated(buf_i4_kind)) deallocate(buf_i4_kind) + if (allocated(buf_i8_kind)) deallocate(buf_i8_kind) + if (allocated(buf_r4_kind)) deallocate(buf_r4_kind) + if (allocated(buf_r8_kind)) deallocate(buf_r8_kind) + endif + end subroutine domain_read_3d @@ -532,17 +451,17 @@ subroutine domain_read_4d(fileobj, variable_name, vdata, unlim_dim_level, & type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. character(len=*), intent(in) :: variable_name !< Variable name. class(*), dimension(:,:,:,:), intent(inout) :: vdata !< Data that will - !! be written out + !! be read out !! to the netcdf file. integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited !! dimension. integer, dimension(4), intent(in), optional :: corner !< Array of starting !! indices describing !! where the data - !! will be written to. + !! will be read to. integer, dimension(4), intent(in), optional :: edge_lengths !< The number of !! elements that - !! will be written + !! will be read !! in each dimension. integer :: xdim_index @@ -753,17 +672,17 @@ subroutine domain_read_5d(fileobj, variable_name, vdata, unlim_dim_level, & type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< File object. character(len=*), intent(in) :: variable_name !< Variable name. class(*), dimension(:,:,:,:,:), intent(inout) :: vdata !< Data that will - !! be written out + !! be read out !! to the netcdf file. integer, intent(in), optional :: unlim_dim_level !< Level for the unlimited !! dimension. integer, dimension(5), intent(in), optional :: corner !< Array of starting !! indices describing !! where the data - !! will be written to. + !! will be read to. integer, dimension(5), intent(in), optional :: edge_lengths !< The number of !! elements that - !! will be written + !! will be read !! in each dimension. integer :: xdim_index diff --git a/fms2_io/netcdf_io.F90 b/fms2_io/netcdf_io.F90 index 03adef35a6..b76042900a 100644 --- a/fms2_io/netcdf_io.F90 +++ b/fms2_io/netcdf_io.F90 @@ -1015,6 +1015,7 @@ function get_variable_compressed_dimension_index(fileobj, variable_name, broadca endif endif call mpp_broadcast(compressed_dimension_index(1), fileobj%io_root, pelist=fileobj%pelist) + call mpp_broadcast(compressed_dimension_index(2), fileobj%io_root, pelist=fileobj%pelist) end function get_variable_compressed_dimension_index diff --git a/mpp/include/mpp_comm.inc b/mpp/include/mpp_comm.inc index 2355102ea9..024cb097fc 100644 --- a/mpp/include/mpp_comm.inc +++ b/mpp/include/mpp_comm.inc @@ -398,6 +398,20 @@ #define MPP_GATHER_PELIST_3D_ mpp_gather_pelist_int4_3d #include + +#undef MPP_GATHER_1D_ +#undef MPP_GATHER_1DV_ +#undef MPP_TYPE_ +#define MPP_TYPE_ integer(i8_kind) +#define MPP_GATHER_1D_ mpp_gather_int8_1d +#define MPP_GATHER_1DV_ mpp_gather_int8_1dv +#undef MPP_GATHER_PELIST_2D_ +#undef MPP_GATHER_PELIST_3D_ +#define MPP_GATHER_PELIST_2D_ mpp_gather_pelist_int8_2d +#define MPP_GATHER_PELIST_3D_ mpp_gather_pelist_int8_3d +#include + + #undef MPP_GATHER_1D_ #undef MPP_GATHER_1DV_ #undef MPP_TYPE_ @@ -431,6 +445,14 @@ #define MPP_SCATTER_PELIST_3D_ mpp_scatter_pelist_int4_3d #include +#undef MPP_SCATTER_PELIST_2D_ +#undef MPP_SCATTER_PELIST_3D_ +#undef MPP_TYPE_ +#define MPP_TYPE_ integer(i8_kind) +#define MPP_SCATTER_PELIST_2D_ mpp_scatter_pelist_int8_2d +#define MPP_SCATTER_PELIST_3D_ mpp_scatter_pelist_int8_3d +#include + #undef MPP_SCATTER_PELIST_2D_ #undef MPP_SCATTER_PELIST_3D_ #undef MPP_TYPE_ diff --git a/mpp/include/mpp_domains_util.inc b/mpp/include/mpp_domains_util.inc index 74b195b809..c27af7c093 100644 --- a/mpp/include/mpp_domains_util.inc +++ b/mpp/include/mpp_domains_util.inc @@ -324,6 +324,14 @@ !call mpp_set_super_grid_indices(domain%list(i-1)%y(1)%data) enddo + do i=1, size(domain%x(1)%list) + call mpp_set_super_grid_indices(domain%x(1)%list(i-1)%compute) + enddo + + do i=1, size(domain%y(1)%list) + call mpp_set_super_grid_indices(domain%y(1)%list(i-1)%compute) + enddo + end subroutine mpp_create_super_grid_domain !##################################################################### diff --git a/mpp/mpp.F90 b/mpp/mpp.F90 index d429abb3f9..7d07e1937c 100644 --- a/mpp/mpp.F90 +++ b/mpp/mpp.F90 @@ -698,16 +698,20 @@ module mpp_mod interface mpp_gather module procedure mpp_gather_logical_1d module procedure mpp_gather_int4_1d + module procedure mpp_gather_int8_1d module procedure mpp_gather_real4_1d module procedure mpp_gather_real8_1d module procedure mpp_gather_logical_1dv module procedure mpp_gather_int4_1dv + module procedure mpp_gather_int8_1dv module procedure mpp_gather_real4_1dv module procedure mpp_gather_real8_1dv module procedure mpp_gather_pelist_logical_2d module procedure mpp_gather_pelist_logical_3d module procedure mpp_gather_pelist_int4_2d module procedure mpp_gather_pelist_int4_3d + module procedure mpp_gather_pelist_int8_2d + module procedure mpp_gather_pelist_int8_3d module procedure mpp_gather_pelist_real4_2d module procedure mpp_gather_pelist_real4_3d module procedure mpp_gather_pelist_real8_2d @@ -734,6 +738,8 @@ module mpp_mod interface mpp_scatter module procedure mpp_scatter_pelist_int4_2d module procedure mpp_scatter_pelist_int4_3d + module procedure mpp_scatter_pelist_int8_2d + module procedure mpp_scatter_pelist_int8_3d module procedure mpp_scatter_pelist_real4_2d module procedure mpp_scatter_pelist_real4_3d module procedure mpp_scatter_pelist_real8_2d diff --git a/test_fms/fms2_io/Makefile.am b/test_fms/fms2_io/Makefile.am index d7fd03a867..ee4fddbc0e 100644 --- a/test_fms/fms2_io/Makefile.am +++ b/test_fms/fms2_io/Makefile.am @@ -30,7 +30,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. check_PROGRAMS = test_get_is_valid test_file_appendix test_fms2_io test_atmosphere_io test_io_simple test_io_with_mask test_global_att \ - test_bc_restart test_get_mosaic_tile_grid test_read_ascii_file test_unlimit_compressed test_chunksizes + test_bc_restart test_get_mosaic_tile_grid test_read_ascii_file test_unlimit_compressed test_chunksizes test_domain_io test_compressed_writes # This is the source code for the test. test_get_is_valid_SOURCES = test_get_is_valid.F90 @@ -49,6 +49,8 @@ test_read_ascii_file_SOURCES=test_read_ascii_file.F90 test_file_appendix_SOURCES=test_file_appendix.F90 test_unlimit_compressed_SOURCES=test_unlimit_compressed.F90 test_chunksizes_SOURCES = test_chunksizes.F90 +test_compressed_writes_SOURCES = test_compressed_writes.F90 +test_domain_io_SOURCES = test_domain_io.F90 EXTRA_DIST = test_bc_restart.sh test_fms2_io.sh test_atmosphere_io.sh test_io_simple.sh test_global_att.sh test_io_with_mask.sh test_read_ascii_file.sh diff --git a/test_fms/fms2_io/test_compressed_writes.F90 b/test_fms/fms2_io/test_compressed_writes.F90 new file mode 100644 index 0000000000..b905be70d7 --- /dev/null +++ b/test_fms/fms2_io/test_compressed_writes.F90 @@ -0,0 +1,290 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @brief This programs tests the compressed writes in fms2_io +program test_compressed_writes + use fms_mod, only: fms_init, fms_end + use fms2_io_mod, only: open_file, close_file, FmsNetcdfFile_t, register_axis, write_data, & + register_field, read_data + use mpp_mod, only: mpp_pe, mpp_root_pe, mpp_get_current_pelist, FATAL, mpp_npes, mpp_chksum, & + mpp_error + use platform_mod, only: r4_kind, r8_kind, i4_kind, i8_kind + + implicit none + + !> @brief Dummy type to hold variable data + type data_type + real(kind=r4_kind), allocatable :: var_r4(:,:,:,:,:) + real(kind=r8_kind), allocatable :: var_r8(:,:,:,:,:) + integer(kind=i4_kind), allocatable :: var_i4(:,:,:,:,:) + integer(kind=i8_kind), allocatable :: var_i8(:,:,:,:,:) + end type + + type(FmsNetcdfFile_t) :: fileobj !< fms2io fileobj for domain decomposed + character(len=6), dimension(5) :: names !< Dimensions names + type(data_type) :: var_data_in !< Variable data written in + type(data_type) :: var_data_out !< Variable data read + type(data_type) :: var_data_ref !< Variable data read + integer :: ndim2 = 2 !< The size of the second dimension + integer :: ndim3 = 3 !< The size of the third dimension + integer :: ndim4 = 4 !< The size of the fourth dimension + integer :: ndim5 = 1 !< The size of the fifth dimension + integer, allocatable :: pes(:) !< The pelist + + call fms_init + + allocate(pes(mpp_npes())) + call mpp_get_current_pelist(pes) + + if (open_file(fileobj, "test_compressed_writes.nc", "overwrite", nc_format="netcdf4", pelist=pes)) then + + names(1) = "c_xy" + names(2) = "dim2" + names(3) = "dim3" + names(4) = "dim4" + names(5) = "dim5" + + call register_axis(fileobj, "c_xy", mpp_pe()+1, is_compressed=.true.) + call register_axis(fileobj, "dim2", ndim2) + call register_axis(fileobj, "dim3", ndim3) + call register_axis(fileobj, "dim4", ndim4) + call register_axis(fileobj, "dim5", ndim5) + + call register_field_wrapper(fileobj, "var1", names, 1) + call register_field_wrapper(fileobj, "var2", names, 2) + call register_field_wrapper(fileobj, "var3", names, 3) + call register_field_wrapper(fileobj, "var4", names, 4) + call register_field_wrapper(fileobj, "var5", names, 5) + + call var_data_alloc(var_data_in, ndim2, ndim3, ndim4, ndim5, mpp_pe()+1) + call var_data_set(var_data_in, mpp_pe()) + + call write_data_wrapper(fileobj, "r4", var_data_in%var_r4) + call write_data_wrapper(fileobj, "r8", var_data_in%var_r8) + call write_data_wrapper(fileobj, "i4", var_data_in%var_i4) + call write_data_wrapper(fileobj, "i8", var_data_in%var_i8) + + call close_file(fileobj) + endif + + !< Now check answers + if (mpp_pe() .eq. mpp_root_pe()) then + !call mpp_set_current_pelist((/mpp_pe()/)) + if (open_file(fileobj, "test_compressed_writes.nc", "read", nc_format="netcdf4")) then + call var_data_alloc(var_data_out, ndim2, ndim3, ndim4, ndim5, sum(pes)+mpp_npes()) + call var_data_alloc(var_data_ref, ndim2, ndim3, ndim4, ndim5, sum(pes)+mpp_npes()) + call var_data_set_ref(var_data_ref) + + call read_data_wrapper(fileobj, "var2", 1, var_data_out, var_data_ref) + call read_data_wrapper(fileobj, "var2", 2, var_data_out, var_data_ref) + call read_data_wrapper(fileobj, "var3", 3, var_data_out, var_data_ref) + call read_data_wrapper(fileobj, "var4", 4, var_data_out, var_data_ref) + call read_data_wrapper(fileobj, "var5", 5, var_data_out, var_data_ref) + + call close_file(fileobj) + endif + endif + call fms_end + + contains + + !> @brief registers all of the possible variable types for a given + !! number of dimensions + subroutine register_field_wrapper(fileob, var_name, dimension_names, ndim) + type(FmsNetcdfFile_t), intent(inout) :: fileob !< fms2io fileobj for domain decomposed + character(len=*), intent(in) :: var_name !< Name of the variable + character(len=*), intent(in) :: dimension_names(:) !< dimension names + integer, intent(in) :: ndim !< Number of dimension + + call register_field(fileob, trim(var_name)//"_r8", "double", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_r4", "float", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i8", "int64", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i4", "int", names(1:ndim)) + end subroutine register_field_wrapper + +!> @brief Allocates the variable to be the size of data compute domain for x and y + !! and for a given size for the 3rd 4th and 5th dimension + subroutine var_data_alloc(var_data, dim2, dim3, dim4, dim5, compressed_dim) + type(data_type), intent(inout) :: var_data !< Variable data + integer, intent(in) :: dim2 !< Size of dim3 + integer, intent(in) :: dim3 !< Size of dim3 + integer, intent(in) :: dim4 !< Size of dim4 + integer, intent(in) :: dim5 !< Size of dim5 + integer, intent(in) :: compressed_dim !< Size of the compressed dimension + + allocate(var_data%var_r4(compressed_dim, dim2, dim3, dim4, dim5)) + allocate(var_data%var_r8(compressed_dim, dim2, dim3, dim4, dim5)) + allocate(var_data%var_i4(compressed_dim, dim2, dim3, dim4, dim5)) + allocate(var_data%var_i8(compressed_dim, dim2, dim3, dim4, dim5)) + end subroutine var_data_alloc + + + !> @brief Sets the data to some value + subroutine var_data_set(var_data, var_value) + type(data_type), intent(inout) :: var_data !< Variable data + integer, intent(in) :: var_value !< Value to set the data as + + var_data%var_r4 = real(var_value, kind=r4_kind) + var_data%var_r8 = real(var_value, kind=r8_kind) + var_data%var_i4 = int(var_value, kind=i4_kind) + var_data%var_i8 = int(var_value, kind=i8_kind) + end subroutine var_data_set + + !> @brief Writes the data for a give variable type + subroutine write_data_wrapper(fileob, var_kind, var_data) + type(FmsNetcdfFile_t), intent(inout) :: fileob !< fms2io fileobj for domain decomposed + character(len=*), intent(in) :: var_kind !< The kind of the variable + class(*), intent(in) :: var_data(:,:,:,:,:) !< Variable data + + call write_data(fileob, "var1_"//trim(var_kind), var_data(:,1,1,1,1)) + call write_data(fileob, "var2_"//trim(var_kind), var_data(:,:,1,1,1)) + call write_data(fileob, "var3_"//trim(var_kind), var_data(:,:,:,1,1)) + call write_data(fileob, "var4_"//trim(var_kind), var_data(:,:,:,:,1)) + call write_data(fileob, "var5_"//trim(var_kind), var_data(:,:,:,:,:)) + + end subroutine + + !> @brief Reads the data and compares it with reference data + subroutine read_data_wrapper(fileob, var_name, dim, var_data, ref_data) + type(FmsNetcdfFile_t), intent(inout) :: fileob !< fms2io fileobj for domain decomposed + character(len=*), intent(in) :: var_name !< The kind of the variable + integer, intent(in) :: dim !< The dimension of the variable + type(data_type), intent(inout) :: var_data !< Variable data to read to + type(data_type), intent(in) :: ref_data !< Variable data to compare to + + select case(dim) + case(1) + call var_data_set(var_data, -999) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,1,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,1,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r4(:,1,1,1,1), (/mpp_pe()/)), "var2_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,1,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,1,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r8(:,1,1,1,1), (/mpp_pe()/)), "var2_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,1,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,1,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i4(:,1,1,1,1), (/mpp_pe()/)), "var2_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,1,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,1,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i8(:,1,1,1,1), (/mpp_pe()/)), "var2_i8") + case(2) + call var_data_set(var_data, -999) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r4(:,:,1,1,1), (/mpp_pe()/)), "var2_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r8(:,:,1,1,1), (/mpp_pe()/)), "var2_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i4(:,:,1,1,1), (/mpp_pe()/)), "var2_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,1,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i8(:,:,1,1,1), (/mpp_pe()/)), "var2_i8") + case(3) + call var_data_set(var_data, -999) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,:,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r4(:,:,:,1,1), (/mpp_pe()/)), "var3_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,:,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r8(:,:,:,1,1), (/mpp_pe()/)), "var3_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,:,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i4(:,:,:,1,1), (/mpp_pe()/)), "var3_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,:,1,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i8(:,:,:,1,1), (/mpp_pe()/)), "var3_i8") + case(4) + call var_data_set(var_data, -999) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,:,:,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r4(:,:,:,:,1), (/mpp_pe()/)), "var4_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,:,:,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r8(:,:,:,:,1), (/mpp_pe()/)), "var4_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,:,:,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i4(:,:,:,:,1), (/mpp_pe()/)), "var4_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,:,:,1), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i8(:,:,:,:,1), (/mpp_pe()/)), "var4_i8") + case(5) + call var_data_set(var_data, -999) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,:,:,:), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r4(:,:,:,:,:), (/mpp_pe()/)), "var5_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,:,:,:), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_r8(:,:,:,:,:), (/mpp_pe()/)), "var5_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,:,:,:), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i4(:,:,:,:,:), (/mpp_pe()/)), "var5_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,:,:,:), (/mpp_pe()/)), & + mpp_chksum(ref_data%var_i8(:,:,:,:,:), (/mpp_pe()/)), "var5_i8") + end select + end subroutine + + !> @brief Sets the data to the expected answer + subroutine var_data_set_ref(var_data) + type(data_type), intent(inout) :: var_data !< Variable data to set + integer :: starting_index !< Starting index of the current pes data + integer :: ending_index !< Ending index of the current pes data + integer :: i !< for do loops + + ending_index = 0 + do i = 1, size(pes) + starting_index = ending_index + 1 + ending_index = starting_index + pes(i) + + var_data%var_r4(starting_index:ending_index,:,:,:,:) = real(pes(i), kind=r4_kind) + var_data%var_r8(starting_index:ending_index,:,:,:,:) = real(pes(i), kind=r8_kind) + var_data%var_i4(starting_index:ending_index,:,:,:,:) = int(pes(i), kind=i4_kind) + var_data%var_i8(starting_index:ending_index,:,:,:,:) = int(pes(i), kind=i8_kind) + + enddo + end subroutine + + !> @brief Compares two checksums and crashes if they are not the same + subroutine compare_var_data(check_sum_in, check_sum_ref, varname) + integer(kind=i8_kind), intent(in) :: check_sum_in !< The checksum calculated from the data read + integer(kind=i8_kind), intent(in) :: check_sum_ref !< The checksum to compare to + character(len=*), intent(in) :: varname !< Variable name for reference + + if (check_sum_ref .ne. check_sum_in) call mpp_error(FATAL, & + "Checksums do not match for variable: "//trim(varname)) + end subroutine compare_var_data + +end program test_compressed_writes diff --git a/test_fms/fms2_io/test_domain_io.F90 b/test_fms/fms2_io/test_domain_io.F90 new file mode 100644 index 0000000000..07a3e2845a --- /dev/null +++ b/test_fms/fms2_io/test_domain_io.F90 @@ -0,0 +1,312 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +program test_domain_read + use mpp_domains_mod, only: mpp_domains_set_stack_size, mpp_define_domains, mpp_define_io_domain, & + mpp_get_compute_domain, mpp_get_data_domain, domain2d, EAST, NORTH, CENTER + use mpp_mod, only: mpp_chksum, mpp_pe, mpp_root_pe, mpp_error, FATAL, input_nml_file + use fms2_io_mod, only: open_file, register_axis, register_variable_attribute, close_file, & + FmsNetcdfDomainFile_t, write_data, register_field, read_data, & + parse_mask_table + use fms_mod, only: fms_init, fms_end, check_nml_error + use platform_mod, only: r4_kind, r8_kind, i4_kind, i8_kind + + implicit none + + !> @brief Dummy type to hold variable data + type data_t + real(kind=r4_kind), allocatable :: var_r4(:,:,:,:,:) + real(kind=r8_kind), allocatable :: var_r8(:,:,:,:,:) + integer(kind=i4_kind), allocatable :: var_i4(:,:,:,:,:) + integer(kind=i8_kind), allocatable :: var_i8(:,:,:,:,:) + end type + + ! Namelist variables + integer, dimension(2) :: layout = (/2,3/) !< Domain layout + integer, dimension(2) :: io_layout = (/1,1/) !< Domain layout + integer :: nx = 96 !< Number of points in dim1 + integer :: ny = 96 !< Number of points in dim2 + character(len=20) :: mask_table = "" !< Name of a masktable to use + integer :: xhalo = 3 !< Number of halo points in X + integer :: yhalo = 2 !< Number of halo points in Y + integer :: nz = 2 !< Number of points in the z dimension + character(len=20) :: filename="test.nc" !< Name of the file + logical :: use_edges=.false. !< Use North and East domain positions + + integer :: ndim4 !< Number of points in dim4 + integer :: ndim5 !< Number of points in dim5 + type(domain2d) :: Domain !< Domain with mask table + type(FmsNetcdfDomainFile_t) :: fileobj !< fms2io fileobj for domain decomposed + character(len=6), dimension(5) :: names !< Dimensions names + type(data_t) :: var_data_in !< Variable data written in + type(data_t) :: var_data_out !< Variable data read in + logical, allocatable, dimension(:,:) :: parsed_mask !< Parsed masked + integer :: io !< Error code when reading namelist + integer :: ierr !< Error code when reading namelist + integer :: xposition !< position in the x dimension ("EAST" or "CENTER") + integer :: yposition !< position in the y dimension ("NORTH" or "CENTER") + + namelist /test_domain_io_nml/ layout, io_layout, nx, ny, nz, mask_table, xhalo, yhalo, nz, filename, use_edges + + call fms_init + + read(input_nml_file, nml=test_domain_io_nml, iostat=io) + ierr = check_nml_error(io, 'test_domain_io_nml') + + ndim4 = 2 + ndim5 = 2 + + if (use_edges) then + xposition = EAST + yposition = NORTH + else + xposition = CENTER + yposition = CENTER + endif + + !< Parse the mask table + allocate(parsed_mask(layout(1), layout(2))) + parsed_mask = .True. + if (trim(mask_table) .ne. "") then + call parse_mask_table(trim(mask_table), parsed_mask, 'test_io_with_mask') + endif + + call mpp_domains_set_stack_size(17280000) + call mpp_define_domains( (/1,nx,1,ny/), layout, Domain, xhalo=xhalo, yhalo=yhalo, & + maskmap=parsed_mask) + call mpp_define_io_domain(Domain, io_layout) + + if (open_file(fileobj, trim(filename), "overwrite", domain, nc_format="netcdf4")) then + names(1) = "dim1" + names(2) = "dim2" + names(3) = "dim3" + names(4) = "dim4" + names(5) = "dim5" + + call register_axis(fileobj, "dim1", "x", domain_position=xposition ) + call register_axis(fileobj, "dim2", "y", domain_position=yposition ) + call register_axis(fileobj, "dim3", nz) + call register_axis(fileobj, "dim4", ndim4) + call register_axis(fileobj, "dim5", ndim5) + + call register_field_wrapper(fileobj, "var2", names, 2) + call register_field_wrapper(fileobj, "var3", names, 3) + call register_field_wrapper(fileobj, "var4", names, 4) + call register_field_wrapper(fileobj, "var5", names, 5) + + call var_data_alloc(var_data_in, Domain, nz, ndim4, ndim5) + call var_data_init(var_data_in) + call var_data_set(var_data_in, Domain, nz, ndim4, ndim5) + + call write_data_wrapper(fileobj, "r4", var_data_in%var_r4) + call write_data_wrapper(fileobj, "r8", var_data_in%var_r8) + call write_data_wrapper(fileobj, "i4", var_data_in%var_i4) + call write_data_wrapper(fileobj, "i8", var_data_in%var_i8) + + call close_file(fileobj) + endif + + if (open_file(fileobj, trim(filename), "read", domain, nc_format="netcdf4")) then + call register_axis(fileobj, "dim1", "x") + call register_axis(fileobj, "dim2", "y") + + call var_data_alloc(var_data_out, Domain, nz, ndim4, ndim5) + call read_data_wrapper(fileobj, "var2", 2, var_data_out, var_data_in) + call read_data_wrapper(fileobj, "var3", 3, var_data_out, var_data_in) + call read_data_wrapper(fileobj, "var4", 4, var_data_out, var_data_in) + call read_data_wrapper(fileobj, "var5", 5, var_data_out, var_data_in) + + call close_file(fileobj) + endif + call fms_end + + contains + + !> @brief registers all of the possible variable types for a given + !! number of dimensions + subroutine register_field_wrapper(fileob, var_name, dimension_names, ndim) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileob !< fms2io fileobj for domain decomposed + character(len=*), intent(in) :: var_name !< Name of the variable + character(len=*), intent(in) :: dimension_names(:) !< dimension names + integer, intent(in) :: ndim !< Number of dimension + + call register_field(fileob, trim(var_name)//"_r8", "double", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_r4", "float", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i8", "int", names(1:ndim)) + call register_field(fileob, trim(var_name)//"_i4", "int64", names(1:ndim)) + end subroutine register_field_wrapper + + !> @brief Allocates the variable to be the size of data compute domain for x and y + !! and for a given size for the 3rd 4th and 5th dimension + subroutine var_data_alloc(var_data, var_domain, dim3, dim4, dim5) + type(data_t), intent(inout) :: var_data !< Variable data + type(domain2d), intent(in) :: var_domain !< Domain with mask table + integer, intent(in) :: dim3 !< Size of dim3 + integer, intent(in) :: dim4 !< Size of dim4 + integer, intent(in) :: dim5 !< Size of dim5 + + integer :: is !< Starting x index + integer :: ie !< Ending x index + integer :: js !< Starting y index + integer :: je !< Ending y index + + call mpp_get_data_domain(var_domain, is, ie, js, je) !< This includes halos (but halos will not be written!) + + allocate(var_data%var_r4(is:ie, js:je, dim3, dim4, dim5)) + allocate(var_data%var_r8(is:ie, js:je, dim3, dim4, dim5)) + allocate(var_data%var_i4(is:ie, js:je, dim3, dim4, dim5)) + allocate(var_data%var_i8(is:ie, js:je, dim3, dim4, dim5)) + end subroutine var_data_alloc + + !> @brief Initializes the data to -999.99 for reals and -999 for integers + subroutine var_data_init(var_data) + type(data_t), intent(inout) :: var_data !< Variable data + + var_data%var_r4 = real(-999.99, kind=r4_kind) + var_data%var_r8 = real(-999.99, kind=r8_kind) + var_data%var_i4 = int(-999, kind=i4_kind) + var_data%var_i8 = int(-999, kind=i8_kind) + end subroutine var_data_init + + !> @brief Sets the dcompute domain part of the variable to the expected number + subroutine var_data_set(var_data, var_domain, dim3, dim4, dim5) + type(data_t), intent(inout) :: var_data !< Variable data + type(domain2d), intent(in) :: var_domain !< Domain with mask table + integer, intent(in) :: dim3 !< Size of dim3 + integer, intent(in) :: dim4 !< Size of dim4 + integer, intent(in) :: dim5 !< Size of dim5 + + integer :: i, j, k, l, m !< For do loops + + integer :: is !< Starting x index + integer :: ie !< Ending x index + integer :: js !< Starting y index + integer :: je !< Ending y index + integer :: var_count !< For keeping track of the varible's data + + call mpp_get_compute_domain(var_domain, is, ie, js, je) !< This does not include halos! + + var_count = 0 + do i = is, ie + do j = js, je + do k = 1, dim3 + do l = 1, dim4 + do m = 1, dim5 + var_count = var_count + 1 + var_data%var_r4(i,j,k,l,m) = real(var_count, kind=r4_kind) + var_data%var_r8(i,j,k,l,m) = real(var_count, kind=r8_kind) + var_data%var_i4(i,j,k,l,m) = int(var_count, kind=i4_kind) + var_data%var_i8(i,j,k,l,m) = int(var_count, kind=i8_kind) + enddo + enddo + enddo + enddo + enddo + + end subroutine + + !> @brief Writes the data for a give variable type + subroutine write_data_wrapper(fileob, var_kind, var_data) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileob !< fms2io fileobj for domain decomposed + character(len=*), intent(in) :: var_kind !< The kind of the variable + class(*), intent(in) :: var_data(:,:,:,:,:) !< Variable data + + call write_data(fileob, "var2_"//trim(var_kind), var_data(:,:,1,1,1)) + call write_data(fileob, "var3_"//trim(var_kind), var_data(:,:,:,1,1)) + call write_data(fileob, "var4_"//trim(var_kind), var_data(:,:,:,:,1)) + call write_data(fileob, "var5_"//trim(var_kind), var_data(:,:,:,:,:)) + + end subroutine + + !> @brief Reads the data and compares the checksum from the expected result + subroutine read_data_wrapper(fileob, var_name, dim, var_data, ref_data) + type(FmsNetcdfDomainFile_t), intent(inout) :: fileob !< fms2io fileobj for domain decomposed + character(len=*), intent(in) :: var_name !< The kind of the variable + integer, intent(in) :: dim !< The variable's dimension + type(data_t), intent(inout) :: var_data !< The variable's data + type(data_t), intent(inout) :: ref_data !< The variable's reference data + + select case(dim) + case(2) + call var_data_init(var_data) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,1,1,1)), mpp_chksum(ref_data%var_r4(:,:,1,1,1)), "var2_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,1,1,1)), mpp_chksum(ref_data%var_r8(:,:,1,1,1)), "var2_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,1,1,1)), mpp_chksum(ref_data%var_i4(:,:,1,1,1)), "var2_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,1,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,1,1,1)), mpp_chksum(ref_data%var_i8(:,:,1,1,1)), "var2_i8") + case(3) + call var_data_init(var_data) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,:,1,1)), mpp_chksum(ref_data%var_r4(:,:,:,1,1)), "var3_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,:,1,1)), mpp_chksum(ref_data%var_r8(:,:,:,1,1)), "var3_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,:,1,1)), mpp_chksum(ref_data%var_i4(:,:,:,1,1)), "var3_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,:,1,1)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,:,1,1)), mpp_chksum(ref_data%var_i8(:,:,:,1,1)), "var3_i8") + case(4) + call var_data_init(var_data) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,:,:,1)), mpp_chksum(ref_data%var_r4(:,:,:,:,1)), "var4_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,:,:,1)), mpp_chksum(ref_data%var_r8(:,:,:,:,1)), "var4_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,:,:,1)), mpp_chksum(ref_data%var_i4(:,:,:,:,1)), "var4_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,:,:,1)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,:,:,1)), mpp_chksum(ref_data%var_i8(:,:,:,:,1)), "var4_i8") + case(5) + call var_data_init(var_data) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,:,:,:)), mpp_chksum(ref_data%var_r4(:,:,:,:,:)), "var5_r4") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,:,:,:)), mpp_chksum(ref_data%var_r8(:,:,:,:,:)), "var5_r8") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,:,:,:)), mpp_chksum(ref_data%var_i4(:,:,:,:,:)), "var5_i4") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,:,:,:)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,:,:,:)), mpp_chksum(ref_data%var_i8(:,:,:,:,:)), "var5_i8") + end select + + end subroutine read_data_wrapper + + !> @brief Compares two checksums and crashes if they are not the same + subroutine compare_var_data(check_sum_in, check_sum_ref, varname) + integer(kind=i8_kind), intent(in) :: check_sum_in !< Checksum + integer(kind=i8_kind), intent(in) :: check_sum_ref !< The reference checksum + character(len=*), intent(in) :: varname !< The variable's name (for error messages) + + if (check_sum_ref .ne. check_sum_in) call mpp_error(FATAL, & + "Checksums do not match for variable: "//trim(varname)) + end subroutine compare_var_data + +end program test_domain_read diff --git a/test_fms/fms2_io/test_fms2_io.sh b/test_fms/fms2_io/test_fms2_io.sh index a8cd54eaa2..8a604e6655 100755 --- a/test_fms/fms2_io/test_fms2_io.sh +++ b/test_fms/fms2_io/test_fms2_io.sh @@ -48,4 +48,73 @@ test_expect_success "FMS2 IO Test" ' mpirun -n 6 ../test_fms2_io ' +test_expect_success "Compressed writes tests" ' + mpirun -n 5 ../test_compressed_writes +' + +cat <<_EOF > input.nml +&test_domain_io_nml + layout = 1, 6 + io_layout = 1, 1 + filename = "test_simple_layout.nc" +/ +_EOF +test_expect_success "Domain Read Write Tests with simple layout" ' + mpirun -n 6 ../test_domain_io +' + +cat <<_EOF > input.nml +&test_domain_io_nml + layout = 2, 8 + io_layout = 1, 2 + filename = "test_dist_layout.nc" +/ +_EOF +test_expect_success "Domain Read Write Tests with 2 distributed files" ' + mpirun -n 16 ../test_domain_io +' + +cat <<_EOF > input.nml +&test_domain_io_nml + layout = 2, 8 + io_layout = 1, 2 + filename = "test_dist_layout.nc" + use_edges = .true. +/ +_EOF +test_expect_success "Domain Read Write Tests with 2 distributed files and EAST and NORTH axis" ' + mpirun -n 16 ../test_domain_io +' + +cat <<_EOF > input.nml +&test_domain_io_nml + nx = 33 + ny = 43 + layout = 4, 6 + io_layout = 2, 3 + filename = "test_non_uniform.nc" +/ +_EOF +test_expect_success "Domain Read Write Tests with non uniform layouts" ' + mpirun -n 24 ../test_domain_io +' + +cat <<_EOF > input.nml +&test_domain_io_nml + layout = 3, 6 + io_layout = 1, 2 + mask_table = "mask_table" + filename = "test_io_mask.nc" +/ +_EOF + +cat <<_EOF > mask_table +1 +3,6 +1,1 +_EOF +test_expect_success "Domain Read Write Tests with a ocean mask" ' + mpirun -n 17 ../test_domain_io +' + test_done From 23b86dbd78a376b004fd385fecda439cbe5cd080 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Fri, 16 Jun 2023 15:56:42 -0400 Subject: [PATCH 18/51] feat: mixed precision for axis_utils2, horiz_interp, sat_vapor_pressure, and fms_mod (#1239) (#1258) * feat: mixed precision axis_utils2 (#1104) * feat: mixed precision fms_mod (#1147) * feat: horiz interp mixed precision (#1067) * mixed precision sat_vapor_pressure (#1095) * feat: add mixed precision axis_utils unit tests (#1172) * fix: move type definitions to before first usage to fix nvhpc bug (#1187) * fix: change allocatable type for intel errors (#1221) Co-authored-by: Caitlyn McAllister <65364559+mcallic2@users.noreply.github.com> Co-authored-by: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Co-authored-by: MiKyung Lee <58964324+mlee03@users.noreply.github.com> --- CMakeLists.txt | 9 +- axis_utils/Makefile.am | 12 +- axis_utils/axis_utils2.F90 | 684 +-- axis_utils/include/axis_utils2.inc | 625 +++ axis_utils/include/axis_utils2_r4.fh | 67 + axis_utils/include/axis_utils2_r8.fh | 67 + configure.ac | 1 + fms/Makefile.am | 12 +- fms/fms.F90 | 55 +- fms/include/fms.inc | 64 + fms/include/fms_r4.fh | 8 + fms/include/fms_r8.fh | 8 + horiz_interp/Makefile.am | 22 +- horiz_interp/horiz_interp.F90 | 865 +--- horiz_interp/horiz_interp_bicubic.F90 | 701 +-- horiz_interp/horiz_interp_bilinear.F90 | 1247 +---- horiz_interp/horiz_interp_conserve.F90 | 992 +--- horiz_interp/horiz_interp_spherical.F90 | 841 +--- horiz_interp/horiz_interp_type.F90 | 247 +- horiz_interp/include/horiz_interp.inc | 843 ++++ horiz_interp/include/horiz_interp_bicubic.inc | 663 +++ .../include/horiz_interp_bicubic_r4.fh | 52 + .../include/horiz_interp_bicubic_r8.fh | 52 + .../include/horiz_interp_bilinear.inc | 1230 +++++ .../include/horiz_interp_bilinear_r4.fh | 52 + .../include/horiz_interp_bilinear_r8.fh | 52 + .../include/horiz_interp_conserve.inc | 926 ++++ .../include/horiz_interp_conserve_r4.fh | 55 + .../include/horiz_interp_conserve_r8.fh | 55 + horiz_interp/include/horiz_interp_r4.fh | 64 + horiz_interp/include/horiz_interp_r8.fh | 64 + .../include/horiz_interp_spherical.inc | 821 +++ .../include/horiz_interp_spherical_r4.fh | 49 + .../include/horiz_interp_spherical_r8.fh | 49 + horiz_interp/include/horiz_interp_type.inc | 90 + horiz_interp/include/horiz_interp_type_r4.fh | 28 + horiz_interp/include/horiz_interp_type_r8.fh | 28 + sat_vapor_pres/Makefile.am | 26 +- sat_vapor_pres/include/sat_vapor_pres.inc | 1984 ++++++++ sat_vapor_pres/include/sat_vapor_pres_k.inc | 2647 ++++++++++ sat_vapor_pres/include/sat_vapor_pres_k_r4.fh | 174 + sat_vapor_pres/include/sat_vapor_pres_k_r8.fh | 174 + sat_vapor_pres/include/sat_vapor_pres_r4.fh | 186 + sat_vapor_pres/include/sat_vapor_pres_r8.fh | 186 + sat_vapor_pres/sat_vapor_pres.F90 | 2116 +------- sat_vapor_pres/sat_vapor_pres_k.F90 | 4417 +---------------- test_fms/Makefile.am | 2 +- test_fms/axis_utils/Makefile.am | 10 +- test_fms/axis_utils/test_axis_utils.F90 | 842 +++- test_fms/axis_utils/test_axis_utils2.sh | 29 +- test_fms/fms/Makefile.am | 9 +- test_fms/fms/include/test_fms.inc | 111 + test_fms/fms/include/test_fms_r4.fh | 13 + test_fms/fms/include/test_fms_r8.fh | 13 + test_fms/fms/test_fms.F90 | 14 +- test_fms/horiz_interp/Makefile.am | 8 +- test_fms/horiz_interp/test_horiz_interp.F90 | 1479 +++++- test_fms/horiz_interp/test_horiz_interp2.sh | 177 +- test_fms/sat_vapor_pres/Makefile.am | 50 + .../sat_vapor_pres/test_sat_vapor_pres.F90 | 1010 ++++ .../sat_vapor_pres/test_sat_vapor_pres.sh | 116 + 61 files changed, 15697 insertions(+), 11796 deletions(-) create mode 100644 axis_utils/include/axis_utils2.inc create mode 100644 axis_utils/include/axis_utils2_r4.fh create mode 100644 axis_utils/include/axis_utils2_r8.fh create mode 100644 fms/include/fms.inc create mode 100644 fms/include/fms_r4.fh create mode 100644 fms/include/fms_r8.fh create mode 100644 horiz_interp/include/horiz_interp.inc create mode 100644 horiz_interp/include/horiz_interp_bicubic.inc create mode 100644 horiz_interp/include/horiz_interp_bicubic_r4.fh create mode 100644 horiz_interp/include/horiz_interp_bicubic_r8.fh create mode 100644 horiz_interp/include/horiz_interp_bilinear.inc create mode 100644 horiz_interp/include/horiz_interp_bilinear_r4.fh create mode 100644 horiz_interp/include/horiz_interp_bilinear_r8.fh create mode 100644 horiz_interp/include/horiz_interp_conserve.inc create mode 100644 horiz_interp/include/horiz_interp_conserve_r4.fh create mode 100644 horiz_interp/include/horiz_interp_conserve_r8.fh create mode 100644 horiz_interp/include/horiz_interp_r4.fh create mode 100644 horiz_interp/include/horiz_interp_r8.fh create mode 100644 horiz_interp/include/horiz_interp_spherical.inc create mode 100644 horiz_interp/include/horiz_interp_spherical_r4.fh create mode 100644 horiz_interp/include/horiz_interp_spherical_r8.fh create mode 100644 horiz_interp/include/horiz_interp_type.inc create mode 100644 horiz_interp/include/horiz_interp_type_r4.fh create mode 100644 horiz_interp/include/horiz_interp_type_r8.fh create mode 100644 sat_vapor_pres/include/sat_vapor_pres.inc create mode 100644 sat_vapor_pres/include/sat_vapor_pres_k.inc create mode 100644 sat_vapor_pres/include/sat_vapor_pres_k_r4.fh create mode 100644 sat_vapor_pres/include/sat_vapor_pres_k_r8.fh create mode 100644 sat_vapor_pres/include/sat_vapor_pres_r4.fh create mode 100644 sat_vapor_pres/include/sat_vapor_pres_r8.fh create mode 100644 test_fms/fms/include/test_fms.inc create mode 100644 test_fms/fms/include/test_fms_r4.fh create mode 100644 test_fms/fms/include/test_fms_r8.fh create mode 100644 test_fms/sat_vapor_pres/Makefile.am create mode 100644 test_fms/sat_vapor_pres/test_sat_vapor_pres.F90 create mode 100755 test_fms/sat_vapor_pres/test_sat_vapor_pres.sh diff --git a/CMakeLists.txt b/CMakeLists.txt index 473d8b91f9..cc60d914c2 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -295,12 +295,16 @@ foreach(kind ${kinds}) target_include_directories(${libTgt}_f PRIVATE include fms + fms/include fms2_io/include string_utils/include mpp/include + sat_vapor_pres/include + horiz_interp/include diag_manager/include constants4 - constants) + constants + axis_utils/include) target_compile_definitions(${libTgt}_f PRIVATE "${fms_defs}") target_compile_definitions(${libTgt}_f PRIVATE "${${kind}_defs}") @@ -334,7 +338,10 @@ foreach(kind ${kinds}) target_include_directories(${libTgt} PUBLIC $ $ + $ $ + $ + $ $ $ $) diff --git a/axis_utils/Makefile.am b/axis_utils/Makefile.am index 691f9c1f2d..a8f1b3528b 100644 --- a/axis_utils/Makefile.am +++ b/axis_utils/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/axis_utils/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build this uninstalled convenience library. @@ -31,7 +31,15 @@ noinst_LTLIBRARIES = libaxis_utils.la libaxis_utils_la_SOURCES = \ axis_utils.F90 \ - axis_utils2.F90 + axis_utils2.F90 \ + include/axis_utils2_r4.fh \ + include/axis_utils2_r8.fh \ + include/axis_utils2.inc + +axis_utils2.$(FC_MODEXT) : \ +include/axis_utils2_r4.fh \ +include/axis_utils2_r8.fh \ +include/axis_utils2.inc # Mod file depends on its o file, is built and then installed. nodist_include_HEADERS = axis_utils_mod.$(FC_MODEXT) axis_utils2_mod.$(FC_MODEXT) diff --git a/axis_utils/axis_utils2.F90 b/axis_utils/axis_utils2.F90 index 3086f3b867..bbc7611a77 100644 --- a/axis_utils/axis_utils2.F90 +++ b/axis_utils/axis_utils2.F90 @@ -25,12 +25,12 @@ !> @addtogroup axis_utils2_mod !> @{ module axis_utils2_mod - use mpp_mod, only: mpp_error, FATAL, stdout - use fms_mod, only: lowercase, uppercase, string_array_index, fms_error_handler - use fms2_io_mod, only: FmsNetcdfDomainFile_t, variable_att_exists, FmsNetcdfFile_t, & - get_variable_num_dimensions, get_variable_attribute, & - get_variable_size, read_data, variable_exists - use platform_mod + use mpp_mod, only: mpp_error, FATAL, stdout + use fms_mod, only: lowercase, uppercase, string_array_index, fms_error_handler + use fms2_io_mod, only: FmsNetcdfDomainFile_t, variable_att_exists, FmsNetcdfFile_t, & + get_variable_num_dimensions, get_variable_attribute, & + get_variable_size, read_data, variable_exists + use platform_mod, only: r4_kind, r8_kind implicit none @@ -40,8 +40,9 @@ module axis_utils2_mod private integer, parameter :: maxatts = 100 - real, parameter :: epsln= 1.e-10 - real, parameter :: fp5 = 0.5, f360 = 360.0 + real(r8_kind), parameter :: epsln = 1.e-10_r8_kind + real(r8_kind), parameter :: fp5 = 0.5_r8_kind, f360 = 360.0_r8_kind + !> @} ! Include variable "version" to be written to log file. #include @@ -55,11 +56,44 @@ module axis_utils2_mod !! @param [inout] data2 Interpolated data !! @param method Either "linear" or "cubic_spline" interpolation method, default="linear" !! @ingroup axis_utils2_mod + + interface axis_edges + module procedure axis_edges_r4, axis_edges_r8 + end interface axis_edges + + interface lon_in_range + module procedure lon_in_range_r4, lon_in_range_r8 + end interface lon_in_range + + interface frac_index + module procedure frac_index_r4, frac_index_r8 + end interface frac_index + + interface nearest_index + module procedure nearest_index_r4, nearest_index_r8 + end interface nearest_index + + interface tranlon + module procedure tranlon_r4, tranlon_r8 + end interface tranlon + + interface interp_1d_linear + module procedure interp_1d_linear_r4, interp_1d_linear_r8 + end interface interp_1d_linear + + interface interp_1d_cubic_spline + module procedure interp_1d_cubic_spline_r4, interp_1d_cubic_spline_r8 + end interface interp_1d_cubic_spline + interface interp_1d - module procedure interp_1d_1d - module procedure interp_1d_2d - module procedure interp_1d_3d - end interface + module procedure interp_1d_1d_r4, interp_1d_1d_r8 + module procedure interp_1d_2d_r4, interp_1d_2d_r8 + module procedure interp_1d_3d_r4, interp_1d_3d_r8 + end interface interp_1d + + interface find_index + module procedure find_index_r4, find_index_r8 + end interface find_index !> @addtogroup axis_utils2_mod !> @{ @@ -139,130 +173,6 @@ subroutine get_axis_cart(fileobj, axisname, cart) end if end subroutine get_axis_cart - !> get axis edge data from a given file - subroutine axis_edges(fileobj, name, edge_data, reproduce_null_char_bug_flag) - - class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object to read from - character(len=*), intent(in) :: name !< Name of a given axis - class(*), dimension(:), intent(out) :: edge_data !< Returned edge data from given axis name - logical, intent(in), optional :: reproduce_null_char_bug_flag !< Flag indicating to reproduce - !! the mpp_io bug where the null characters were not removed - !! after reading a string attribute - - integer :: ndims - character(len=128) :: buffer - integer, dimension(:), allocatable :: dim_sizes - real(kind=r4_kind), dimension(:), allocatable :: r32 - real(kind=r4_kind), dimension(:,:), allocatable :: r322d - real(kind=r8_kind), dimension(:), allocatable :: r64 - real(kind=r8_kind), dimension(:,:), allocatable :: r642d - integer :: i - integer :: n - logical :: reproduce_null_char_bug !< Local flag indicating to reproduce the mpp_io bug where - !! the null characters were not removed after reading a string attribute - - ndims = get_variable_num_dimensions(fileobj, name) - allocate(dim_sizes(ndims)) - call get_variable_size(fileobj, name, dim_sizes) - n = dim_sizes(1) - if (size(edge_data) .ne. n+1) then - call mpp_error(FATAL, "axis_edge: incorrect size of edge_data array.") - endif - deallocate(dim_sizes) - - reproduce_null_char_bug = .false. - if (present(reproduce_null_char_bug_flag)) reproduce_null_char_bug = reproduce_null_char_bug_flag - - buffer = "" - if (variable_att_exists(fileobj, name, "edges")) then - !! If the reproduce_null_char_bug flag is turned on fms2io will not remove the null character - call get_variable_attribute(fileobj, name, "edges", buffer(1:128), & - reproduce_null_char_bug_flag=reproduce_null_char_bug) - - !! Check for a null character here, if it exists *_bnds will be calculated instead of read in - if (reproduce_null_char_bug) then - i = 0 - i = index(buffer, char(0)) - if (i > 0) buffer = "" - endif - elseif (variable_att_exists(fileobj, name, "bounds")) then - !! If the reproduce_null_char_bug flag is turned on fms2io will not remove the null character - call get_variable_attribute(fileobj, name, "bounds", buffer(1:128), & - reproduce_null_char_bug_flag=reproduce_null_char_bug) - - !! Check for a null character here, if it exists *_bnds will be calculated instead of read in - if (reproduce_null_char_bug) then - i = 0 - i = index(buffer, char(0)) - if (i > 0) buffer = "" - endif - endif - if (trim(buffer) .ne. "") then - ndims = get_variable_num_dimensions(fileobj, buffer) - allocate(dim_sizes(ndims)) - call get_variable_size(fileobj, buffer, dim_sizes) - if (size(dim_sizes) .eq. 1) then - if (dim_sizes(1) .ne. n+1) then - call mpp_error(FATAL, "axis_edges: incorrect size of edge data.") - endif - call read_data(fileobj, buffer, edge_data) - elseif (size(dim_sizes) .eq. 2) then - if (dim_sizes(1) .ne. 2) then - call mpp_error(FATAL, "axis_edges: first dimension of edge must be of size 2") - endif - if (dim_sizes(2) .ne. n) then - call mpp_error(FATAL, "axis_edges: incorrect size of edge data.") - endif - select type (edge_data) - type is (real(kind=r4_kind)) - allocate(r322d(dim_sizes(1), dim_sizes(2))) - call read_data(fileobj, buffer, r322d) - edge_data(1:dim_sizes(2)) = r322d(1,:) - edge_data(dim_sizes(2)+1) = r322d(2,dim_sizes(2)) - deallocate(r322d) - type is (real(kind=r8_kind)) - allocate(r642d(dim_sizes(1), dim_sizes(2))) - call read_data(fileobj, buffer, r642d) - edge_data(1:dim_sizes(2)) = r642d(1,:) - edge_data(dim_sizes(2)+1) = r642d(2,dim_sizes(2)) - deallocate(r642d) - class default - call mpp_error(FATAL, "axis_edges: unsupported kind.") - end select - endif - deallocate(dim_sizes) - else - select type (edge_data) - type is (real(kind=r4_kind)) - allocate(r32(n)) - call read_data(fileobj, name, r32) - do i = 2, n - edge_data(i) = r32(i-1) + 0.5_r4_kind*(r32(i) - r32(i-1)) - enddo - edge_data(1) = r32(1) - 0.5_r4_kind*(r32(2) - r32(1)) - if (abs(edge_data(1)) .lt. 1.e-10) then - edge_data(1) = 0._r4_kind - endif - edge_data(n+1) = r32(n) + 0.5_r4_kind*(r32(n) - r32(n-1)) - deallocate(r32) - type is (real(kind=r8_kind)) - allocate(r64(n)) - call read_data(fileobj, name, r64) - do i = 2, n - edge_data(i) = r64(i-1) + 0.5_r8_kind*(r64(i) - r64(i-1)) - enddo - edge_data(1) = r64(1) - 0.5_r8_kind*(r64(2) - r64(1)) - if (abs(edge_data(1)) .lt. 1.d-10) then - edge_data(1) = 0._r8_kind - endif - edge_data(n+1) = r64(n) + 0.5_r8_kind*(r64(n) - r64(n-1)) - deallocate(r64) - class default - call mpp_error(FATAL, "axis_edges: unsupported kind.") - end select - endif -end subroutine axis_edges - !> @brief Checks if 'modulo' variable exists for a given axis. !! !> @return true if modulo variable exists in fileobj for the given axis name. @@ -303,506 +213,8 @@ function get_axis_modulo_times(fileobj, axisname, tbeg, tend) get_axis_modulo_times = found_tbeg end function get_axis_modulo_times - !> @brief Returns lon_strt <= longitude <= lon_strt+360 - !! @return real lon_in_range - function lon_in_range(lon, l_strt) - real, intent(in) :: lon, l_strt - real :: lon_in_range - real :: l_end - - lon_in_range = lon - l_end = l_strt+360. - - if (abs(lon_in_range - l_strt) < 1.e-4) then - lon_in_range = l_strt - return - endif - - if (abs(lon_in_range - l_end) < 1.e-4) then - lon_in_range = l_strt - return - endif - - do - if (lon_in_range < l_strt) then - lon_in_range = lon_in_range + f360 - else if (lon_in_range > l_end) then - lon_in_range = lon_in_range - f360 - else - exit - end if - end do - - end function lon_in_range - - !> @brief Returns monotonic array of longitudes s.t., lon_strt <= lon(:) <= lon_strt+360. - !! - !>
The first istrt-1 entries are moved to the end of the array: - !! - !! e.g. - !! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 ==> - !! tranlon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 - subroutine tranlon(lon, lon_start, istrt) - - ! returns array of longitudes s.t. lon_strt <= lon < lon_strt+360. - ! also, the first istrt-1 entries are moved to the end of the array - ! - ! e.g. - ! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 ==> - ! tranlon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 - - real, intent(inout), dimension(:) :: lon - real, intent(in) :: lon_start - integer, intent(out) :: istrt - - - integer :: len, i - real :: lon_strt, tmp(size(lon(:))-1) - - len = size(lon(:)) - - do i=1,len - lon(i) = lon_in_range(lon(i),lon_start) - enddo - - istrt=0 - do i=1,len-1 - if (lon(i+1) < lon(i)) then - istrt=i+1 - exit - endif - enddo - - if (istrt>1) then ! grid is not monotonic - if (abs(lon(len)-lon(1)) < epsln) then - tmp = cshift(lon(1:len-1),istrt-1) - lon(1:len-1) = tmp - lon(len) = lon(1) - else - lon = cshift(lon,istrt-1) - endif - lon_strt = lon(1) - do i=2,len+1 - lon(i) = lon_in_range(lon(i),lon_strt) - lon_strt = lon(i) - enddo - endif - - return - end subroutine tranlon - - !> nearest_index = index of nearest data point within "array" corresponding to - !! "value". - !! - !! inputs: - !! - !! value = arbitrary data...same units as elements in "array" - !! array = array of data points (must be monotonically increasing) - !! - !! output: - !! - !! nearest_index = index of nearest data point to "value" - !! if "value" is outside the domain of "array" then nearest_index = 1 - !! or "ia" depending on whether array(1) or array(ia) is - !! closest to "value" - !! - !! note: if "array" is dimensioned array(0:ia) in the calling - !! program, then the returned index should be reduced - !! by one to account for the zero base. - !! - !! example: - !! - !! let model depths be defined by the following: - !! parameter (km=5) - !! dimension z(km) - !! data z /5.0, 10.0, 50.0, 100.0, 250.0/ - !! - !! k1 = nearest_index (12.5, z, km) - !! k2 = nearest_index (0.0, z, km) - !! - !! k1 would be set to 2, and k2 would be set to 1 so that - !! z(k1) would be the nearest data point to 12.5 and z(k2) would - !! be the nearest data point to 0.0 - !! - !! @return real frac_index - function frac_index (value, array) - - integer :: ia, i, ii, unit - real :: value !< arbitrary data...same units as elements in "array" - real :: frac_index - real, dimension(:) :: array !< array of data points (must be monotonically increasing) - logical keep_going - - ia = size(array(:)) - - do i=2,ia - if (array(i) < array(i-1)) then - unit = stdout() - write (unit,*) & - '=> Error: "frac_index" array must be monotonically increasing when searching for nearest value to ', value - write (unit,*) ' array(i) < array(i-1) for i=',i - write (unit,*) ' array(i) for i=1..ia follows:' - do ii=1,ia - write (unit,*) 'i=',ii, ' array(i)=',array(ii) - enddo - call mpp_error(FATAL,' "frac_index" array must be monotonically increasing.') - endif - enddo - if (value < array(1) .or. value > array(ia)) then -! if (value < array(1)) frac_index = 1. -! if (value > array(ia)) frac_index = float(ia) - frac_index = -1.0 - else - i=1 - keep_going = .true. - do while (i <= ia .and. keep_going) - i = i+1 - if (value <= array(i)) then - frac_index = float(i-1) + (value-array(i-1))/(array(i)-array(i-1)) - keep_going = .false. - endif - enddo - endif - end function frac_index - - !> @brief Return index of nearest point along axis - !! - !> nearest_index = index of nearest data point within "array" corresponding to - !! "value". - !! - !! inputs: - !! - !! value = arbitrary data...same units as elements in "array" - !! array = array of data points (must be monotonically increasing) - !! ia = dimension of "array" - !! - !! output: - !! - !! nearest_index = index of nearest data point to "value" - !! if "value" is outside the domain of "array" then nearest_index = 1 - !! or "ia" depending on whether array(1) or array(ia) is - !! closest to "value" - !! - !! note: if "array" is dimensioned array(0:ia) in the calling - !! program, then the returned index should be reduced - !! by one to account for the zero base. - !! - !! example: - !! - !! let model depths be defined by the following: - !! parameter (km=5) - !! dimension z(km) - !! data z /5.0, 10.0, 50.0, 100.0, 250.0/ - !! - !! k1 = nearest_index (12.5, z, km) - !! k2 = nearest_index (0.0, z, km) - !! - !! k1 would be set to 2, and k2 would be set to 1 so that - !! z(k1) would be the nearest data point to 12.5 and z(k2) would - !! be the nearest data point to 0.0 - !! @return integer nearest_index - function nearest_index (value, array) - - integer :: nearest_index - integer :: ia !< dimension of "array" - integer :: i, ii, unit - real :: value !< arbitrary data...same units as elements in "array" - real, dimension(:) :: array !< array of data points (must be monotonically increasing) - logical keep_going - - ia = size(array(:)) - - do i=2,ia - if (array(i) < array(i-1)) then - unit = stdout() - write (unit,*) '=> Error: "nearest_index" array must be monotonically increasing & - &when searching for nearest value to ',value - write (unit,*) ' array(i) < array(i-1) for i=',i - write (unit,*) ' array(i) for i=1..ia follows:' - do ii=1,ia - write (unit,*) 'i=',ii, ' array(i)=',array(ii) - enddo - call mpp_error(FATAL,' "nearest_index" array must be monotonically increasing.') - endif - enddo - if (value < array(1) .or. value > array(ia)) then - if (value < array(1)) nearest_index = 1 - if (value > array(ia)) nearest_index = ia - else - i=1 - keep_going = .true. - do while (i <= ia .and. keep_going) - i = i+1 - if (value <= array(i)) then - nearest_index = i - if (array(i)-value > value-array(i-1)) nearest_index = i-1 - keep_going = .false. - endif - enddo - endif - end function nearest_index - - !############################################################################# - - subroutine interp_1d_linear(grid1,grid2,data1,data2) - - real, dimension(:), intent(in) :: grid1, data1, grid2 - real, dimension(:), intent(inout) :: data2 - - integer :: n1, n2, i, n - real :: w - - n1 = size(grid1(:)) - n2 = size(grid2(:)) - - - do i=2,n1 - if (grid1(i) <= grid1(i-1)) call mpp_error(FATAL, 'grid1 not monotonic') - enddo - - do i=2,n2 - if (grid2(i) <= grid2(i-1)) call mpp_error(FATAL, 'grid2 not monotonic') - enddo - - if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1') - if (grid1(n1) < grid2(n2) ) call mpp_error(FATAL, 'grid2 lies outside grid1') - - do i=1,n2 - n = nearest_index(grid2(i),grid1) - - if (grid1(n) < grid2(i)) then - w = (grid2(i)-grid1(n))/(grid1(n+1)-grid1(n)) - data2(i) = (1.-w)*data1(n) + w*data1(n+1) - else - if(n==1) then - data2(i) = data1(n) - else - w = (grid2(i)-grid1(n-1))/(grid1(n)-grid1(n-1)) - data2(i) = (1.-w)*data1(n-1) + w*data1(n) - endif - endif - enddo - - - return - - end subroutine interp_1d_linear - - !################################################################### - subroutine interp_1d_cubic_spline(grid1, grid2, data1, data2, yp1, ypn) - - real, dimension(:), intent(in) :: grid1, grid2, data1 - real, dimension(:), intent(inout) :: data2 - real, intent(in) :: yp1, ypn - - real, dimension(size(grid1)) :: y2, u - real :: sig, p, qn, un, h, a ,b - integer :: n, m, i, k, klo, khi - - n = size(grid1(:)) - m = size(grid2(:)) - - do i=2,n - if (grid1(i) <= grid1(i-1)) call mpp_error(FATAL, 'grid1 not monotonic') - enddo - - do i=2,m - if (grid2(i) <= grid2(i-1)) call mpp_error(FATAL, 'grid2 not monotonic') - enddo - - if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1') - if (grid1(n) < grid2(m) ) call mpp_error(FATAL, 'grid2 lies outside grid1') - - if (yp1 >.99e30) then - y2(1)=0. - u(1)=0. - else - y2(1)=-0.5 - u(1)=(3./(grid1(2)-grid1(1)))*((data1(2)-data1(1))/(grid1(2)-grid1(1))-yp1) - endif - - do i=2,n-1 - sig=(grid1(i)-grid1(i-1))/(grid1(i+1)-grid1(i-1)) - p=sig*y2(i-1)+2. - y2(i)=(sig-1.)/p - u(i)=(6.*((data1(i+1)-data1(i))/(grid1(i+1)-grid1(i))-(data1(i)-data1(i-1)) & - /(grid1(i)-grid1(i-1)))/(grid1(i+1)-grid1(i-1))-sig*u(i-1))/p - enddo - - if (ypn > .99e30) then - qn=0. - un=0. - else - qn=0.5 - un=(3./(grid1(n)-grid1(n-1)))*(ypn-(data1(n)-data1(n-1))/(grid1(n)-grid1(n-1))) - endif - - y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.) - - do k=n-1,1,-1 - y2(k)=y2(k)*y2(k+1)+u(k) - enddo - - do k = 1, m - n = nearest_index(grid2(k),grid1) - if (grid1(n) < grid2(k)) then - klo = n - else - if(n==1) then - klo = n - else - klo = n -1 - endif - endif - khi = klo+1 - h = grid1(khi)-grid1(klo) - a = (grid1(khi) - grid2(k))/h - b = (grid2(k) - grid1(klo))/h - data2(k) = a*data1(klo) + b*data1(khi)+ ((a**3-a)*y2(klo) + (b**3-b)*y2(khi))*(h**2)/6. - enddo - - end subroutine interp_1d_cubic_spline - - !################################################################### - - subroutine interp_1d_1d(grid1,grid2,data1,data2, method, yp1, yp2) - - real, dimension(:), intent(in) :: grid1, data1, grid2 - real, dimension(:), intent(inout) :: data2 - character(len=*), optional, intent(in) :: method - real, optional, intent(in) :: yp1, yp2 - - real :: y1, y2 - character(len=32) :: interp_method - integer :: k2, ks, ke - - k2 = size(grid2(:)) - - interp_method = "linear" - if(present(method)) interp_method = method - y1 = 1.0e30 - if(present(yp1)) y1 = yp1 - y2 = 1.0e30 - if(present(yp2)) y2 = yp2 - call find_index(grid1, grid2(1), grid2(k2), ks, ke) - select case(trim(interp_method)) - case("linear") - call interp_1d_linear(grid1(ks:ke),grid2,data1(ks:ke),data2) - case("cubic_spline") - call interp_1d_cubic_spline(grid1(ks:ke),grid2,data1(ks:ke),data2, y1, y2) - case default - call mpp_error(FATAL,"axis_utils: interp_method should be linear or cubic_spline") - end select - - return - - end subroutine interp_1d_1d - - !################################################################### - - - subroutine interp_1d_2d(grid1,grid2,data1,data2) - - real, dimension(:,:), intent(in) :: grid1, data1, grid2 - real, dimension(:,:), intent(inout) :: data2 - - integer :: n1, n2, n, k2, ks, ke - - n1 = size(grid1,1) - n2 = size(grid2,1) - k2 = size(grid2,2) - - if (n1 /= n2) call mpp_error(FATAL,'grid size mismatch') - - do n=1,n1 - call find_index(grid1(n,:), grid2(n,1), grid2(n,k2), ks, ke) - call interp_1d_linear(grid1(n,ks:ke),grid2(n,:),data1(n,ks:ke),data2(n,:)) - enddo - - return - - end subroutine interp_1d_2d - - !################################################################### - - subroutine interp_1d_3d(grid1,grid2,data1,data2, method, yp1, yp2) - - real, dimension(:,:,:), intent(in) :: grid1, data1, grid2 - real, dimension(:,:,:), intent(inout) :: data2 - character(len=*), optional, intent(in) :: method - real, optional, intent(in) :: yp1, yp2 - - integer :: n1, n2, m1, m2, k2, n, m - real :: y1, y2 - character(len=32) :: interp_method - integer :: ks, ke - n1 = size(grid1,1) - n2 = size(grid2,1) - m1 = size(grid1,2) - m2 = size(grid2,2) - k2 = size(grid2,3) - - interp_method = "linear" - if(present(method)) interp_method = method - y1 = 1.0e30 - if(present(yp1)) y1 = yp1 - y2 = 1.0e30 - if(present(yp2)) y2 = yp2 - - if (n1 /= n2 .or. m1 /= m2) call mpp_error(FATAL,'grid size mismatch') - - select case(trim(interp_method)) - case("linear") - do m=1,m1 - do n=1,n1 - call find_index(grid1(n,m,:), grid2(n,m,1), grid2(n,m,k2), ks, ke) - call interp_1d_linear(grid1(n,m,ks:ke),grid2(n,m,:),data1(n,m,ks:ke),data2(n,m,:)) - enddo - enddo - case("cubic_spline") - do m=1,m1 - do n=1,n1 - call find_index(grid1(n,m,:), grid2(n,m,1), grid2(n,m,k2), ks, ke) - call interp_1d_cubic_spline(grid1(n,m,ks:ke),grid2(n,m,:), data1(n,m,ks:ke),data2(n,m,:), y1, y2) - enddo - enddo - case default - call mpp_error(FATAL,"axis_utils: interp_method should be linear or cubic_spline") - end select - - return - - end subroutine interp_1d_3d - - - !##################################################################### - subroutine find_index(grid1, xs, xe, ks, ke) - real, dimension(:), intent(in) :: grid1 - real, intent(in) :: xs, xe - integer, intent(out) :: ks, ke - - integer :: k, nk - - nk = size(grid1(:)) - - ks = 0; ke = 0 - do k = 1, nk-1 - if(grid1(k) <= xs .and. grid1(k+1) > xs ) then - ks = k - exit - endif - enddo - do k = nk, 2, -1 - if(grid1(k) >= xe .and. grid1(k-1) < xe ) then - ke = k - exit - endif - enddo - - if(ks == 0 ) call mpp_error(FATAL,' xs locate outside of grid1') - if(ke == 0 ) call mpp_error(FATAL,' xe locate outside of grid1') - - end subroutine find_index +#include "axis_utils2_r4.fh" +#include "axis_utils2_r8.fh" end module axis_utils2_mod !> @} diff --git a/axis_utils/include/axis_utils2.inc b/axis_utils/include/axis_utils2.inc new file mode 100644 index 0000000000..53707fcf78 --- /dev/null +++ b/axis_utils/include/axis_utils2.inc @@ -0,0 +1,625 @@ + +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @defgroup axis_utils2_mod axis_utils2_mod +!> @ingroup axis_utils +!> @brief A set of utilities for manipulating axes and extracting axis attributes. +!! FMS2_IO equivalent version of @ref axis_utils_mod. +!> @author M.J. Harrison + +!> @addtogroup axis_utils2_mod +!> @{ + + !> get axis edge data from a given file + subroutine AXIS_EDGES_(fileobj, name, edge_data, reproduce_null_char_bug_flag) + + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object to read from + character(len=*), intent(in) :: name !< Name of a given axis + real(FMS_AU_KIND_), dimension(:), intent(out) :: edge_data !< Returned edge data from given axis name + logical, intent(in), optional :: reproduce_null_char_bug_flag !< Flag indicating to reproduce + !! the mpp_io bug where the null characters were not removed + !! after reading a string attribute + + integer :: ndims + character(len=128) :: buffer + integer, dimension(:), allocatable :: dim_sizes + real(kind=FMS_AU_KIND_), dimension(:), allocatable :: r_var + real(kind=FMS_AU_KIND_), dimension(:,:), allocatable :: r2d + integer :: i + integer :: n + logical :: reproduce_null_char_bug !< Local flag + !! indicating to reproduce the mpp_io bug where + !! the null characters were not removed after reading a string attribute + integer, parameter :: lkind = FMS_AU_KIND_ + + ndims = get_variable_num_dimensions(fileobj, name) + allocate(dim_sizes(ndims)) + + call get_variable_size(fileobj, name, dim_sizes) + + n = dim_sizes(1) + if (size(edge_data) .ne. n+1) then + call mpp_error(FATAL, "axis_edge: incorrect size of edge_data array.") + endif + deallocate(dim_sizes) + + reproduce_null_char_bug = .false. + if (present(reproduce_null_char_bug_flag)) reproduce_null_char_bug = reproduce_null_char_bug_flag + + buffer = "" + if (variable_att_exists(fileobj, name, "edges")) then + !! If the reproduce_null_char_bug flag is turned on fms2io will not remove the null character + call get_variable_attribute(fileobj, name, "edges", buffer(1:128), & + reproduce_null_char_bug_flag=reproduce_null_char_bug) + + !! Check for a null character here, if it exists *_bnds will be calculated instead of read in + if (reproduce_null_char_bug) then + i = 0 + i = index(buffer, char(0)) + if (i > 0) buffer = "" + endif + elseif (variable_att_exists(fileobj, name, "bounds")) then + !! If the reproduce_null_char_bug flag is turned on fms2io will not remove the null character + call get_variable_attribute(fileobj, name, "bounds", buffer(1:128), & + reproduce_null_char_bug_flag=reproduce_null_char_bug) + + !! Check for a null character here, if it exists *_bnds will be calculated instead of read in + if (reproduce_null_char_bug) then + i = 0 + i = index(buffer, char(0)) + if (i > 0) buffer = "" + endif + endif + if (trim(buffer) .ne. "") then + ndims = get_variable_num_dimensions(fileobj, buffer) + allocate(dim_sizes(ndims)) + + call get_variable_size(fileobj, buffer, dim_sizes) + + if (size(dim_sizes) .eq. 1) then + if (dim_sizes(1) .ne. n+1) then + call mpp_error(FATAL, "axis_edges: incorrect size of edge data.") + endif + + call read_data(fileobj, buffer, edge_data) + + elseif (size(dim_sizes) .eq. 2) then + if (dim_sizes(1) .ne. 2) then + call mpp_error(FATAL, "axis_edges: first dimension of edge must be of size 2") + endif + if (dim_sizes(2) .ne. n) then + call mpp_error(FATAL, "axis_edges: incorrect size of edge data.") + endif + + allocate(r2d(dim_sizes(1), dim_sizes(2))) + call read_data(fileobj, buffer, r2d) + edge_data(1:dim_sizes(2)) = r2d(1,:) + edge_data(dim_sizes(2)+1) = r2d(2,dim_sizes(2)) + deallocate(r2d) + endif + deallocate(dim_sizes) + else + allocate(r_var(n)) + + call read_data(fileobj, name, r_var) + + do i = 2, n + edge_data(i) = r_var(i-1) + 0.5_lkind*(r_var(i) - r_var(i-1)) + enddo + edge_data(1) = r_var(1) - 0.5_lkind*(r_var(2) - r_var(1)) + if (abs(edge_data(1)) .lt. 1.e-10_lkind) then + edge_data(1) = 0.0_lkind + endif + edge_data(n+1) = r_var(n) + 0.5_lkind*(r_var(n) - r_var(n-1)) + deallocate(r_var) + endif + end subroutine AXIS_EDGES_ + + !> @brief Returns lon_strt <= longitude <= lon_strt+360 + !! @return real lon_in_range */ + + function LON_IN_RANGE_(lon, l_strt) + real(kind=FMS_AU_KIND_), intent(in) :: lon, l_strt + real(kind=FMS_AU_KIND_) :: LON_IN_RANGE_ + real(kind=FMS_AU_KIND_) :: l_end + integer, parameter :: lkind = FMS_AU_KIND_ + + LON_IN_RANGE_ = lon + l_end = l_strt + 360.0_lkind + + if (abs(LON_IN_RANGE_ - l_strt) < 1.e-4_lkind) then + LON_IN_RANGE_ = l_strt + return + endif + + if (abs(LON_IN_RANGE_ - l_end) < 1.e-4_lkind) then + LON_IN_RANGE_ = l_strt + return + endif + + do + if (LON_IN_RANGE_ < l_strt) then + LON_IN_RANGE_ = real(LON_IN_RANGE_, FMS_AU_KIND_) + real(f360, FMS_AU_KIND_) + else if (LON_IN_RANGE_ > l_end) then + LON_IN_RANGE_ = real(LON_IN_RANGE_, FMS_AU_KIND_) - real(f360, FMS_AU_KIND_) + else + exit + end if + end do + + end function LON_IN_RANGE_ + + !> @brief Returns monotonic array of longitudes s.t., lon_strt <= lon(:) <= lon_strt+360. + !! + !>
The first istrt-1 entries are moved to the end of the array: + !! + !! e.g. + !! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 ==> + !! tranlon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 + + subroutine TRANLON_(lon, lon_start, istrt) + + ! returns array of longitudes s.t. lon_strt <= lon < lon_strt+360. + ! also, the first istrt-1 entries are moved to the end of the array + ! + ! e.g. + ! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 ==> + ! tranlon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 + + real(kind=FMS_AU_KIND_), intent(inout), dimension(:) :: lon + real(kind=FMS_AU_KIND_), intent(in) :: lon_start + integer, intent(out) :: istrt + + + integer :: len, i + real(kind=FMS_AU_KIND_) :: lon_strt, tmp(size(lon(:))-1) + + len = size(lon(:)) + + do i = 1, len + lon(i) = lon_in_range(lon(i),lon_start) + enddo + + istrt = 0 + do i = 1,len-1 + if (lon(i+1) < lon(i)) then + istrt = i+1 + exit + endif + enddo + + if (istrt>1) then ! grid is not monotonic + if (abs(lon(len)-lon(1)) < real(epsln, FMS_AU_KIND_)) then + tmp = cshift(lon(1:len-1),istrt-1) + lon(1:len-1) = tmp + lon(len) = lon(1) + else + lon = cshift(lon,istrt-1) + endif + + lon_strt = lon(1) + do i=2,len+1 + lon(i) = lon_in_range(lon(i),lon_strt) + lon_strt = lon(i) + enddo + endif + + return + end subroutine TRANLON_ + + + function FRAC_INDEX_(value, array) + + integer :: ia, i, ii, unit + real(kind=FMS_AU_KIND_) :: value !< arbitrary data...same units as elements in "array" + real(kind=FMS_AU_KIND_) :: FRAC_INDEX_ + real(kind=FMS_AU_KIND_), dimension(:) :: array !< array of data points (must be monotonically increasing) + logical :: keep_going + integer, parameter :: lkind = FMS_AU_KIND_ + ia = size(array(:)) + + do i = 2, ia + if (array(i) < array(i-1)) then + unit = stdout() + write (unit,*) '=> Error: "frac_index" array must be monotonically' & + & // 'increasing when searching for nearest value to ', value + write (unit,*) ' array(i) < array(i-1) for i=',i + write (unit,*) ' array(i) for i=1..ia follows:' + do ii = 1, ia + write (unit,*) 'i=',ii, ' array(i)=',array(ii) + enddo + call mpp_error(FATAL,' "frac_index" array must be monotonically increasing.') + endif + enddo + + if (value < array(1) .or. value > array(ia)) then + ! if (value < array(1)) frac_index = 1. + ! if (value > array(ia)) frac_index = float(ia) + FRAC_INDEX_ = -1.0_lkind + else + i = 1 + keep_going = .true. + do while (i <= ia .and. keep_going) + i = i+1 + if (value <= array(i)) then + FRAC_INDEX_ = real((i-1), lkind) + (value-array(i-1)) / (array(i) - array(i-1)) + keep_going = .false. + endif + enddo + endif + end function FRAC_INDEX_ + + !> @brief Return index of nearest point along axis + !! + !> nearest_index = index of nearest data point within "array" corresponding to + !! "value". + !! + !! inputs: + !! + !! value = arbitrary data...same units as elements in "array" + !! array = array of data points (must be monotonically increasing) + !! ia = dimension of "array" + !! + !! output: + !! + !! nearest_index = index of nearest data point to "value" + !! if "value" is outside the domain of "array" then nearest_index = 1 + !! or "ia" depending on whether array(1) or array(ia) is + !! closest to "value" + !! + !! note: if "array" is dimensioned array(0:ia) in the calling + !! program, then the returned index should be reduced + !! by one to account for the zero base. + !! + !! example: + !! + !! let model depths be defined by the following: + !! parameter (km=5) + !! dimension z(km) + !! data z /5.0, 10.0, 50.0, 100.0, 250.0/ + !! + !! k1 = nearest_index (12.5, z, km) + !! k2 = nearest_index (0.0, z, km) + !! + !! k1 would be set to 2, and k2 would be set to 1 so that + !! z(k1) would be the nearest data point to 12.5 and z(k2) would + !! be the nearest data point to 0.0 + !! @return integer nearest_index + + + + function NEAREST_INDEX_(value, array) + + integer :: NEAREST_INDEX_ + integer :: ia !< dimension of "array" + integer :: i, ii, unit + real(kind=FMS_AU_KIND_) :: value !< arbitrary data...same units as elements in "array" + real(kind=FMS_AU_KIND_), dimension(:) :: array !< array of data points (must be monotonically increasing) + logical :: keep_going + + ia = size(array(:)) + + do i = 2, ia + if (array(i) < array(i-1)) then + unit = stdout() + write (unit,*) '=> Error: "nearest_index" array must be monotonically increasing' & + & // 'when searching for nearest value to ', value + write (unit,*) ' array(i) < array(i-1) for i=',i + write (unit,*) ' array(i) for i=1..ia follows:' + do ii = 1, ia + write (unit,*) 'i=',ii, ' array(i)=', array(ii) + enddo + call mpp_error(FATAL,' "nearest_index" array must be monotonically increasing.') + endif + enddo + + if (value < array(1) .or. value > array(ia)) then + if (value < array(1)) NEAREST_INDEX_ = 1 + if (value > array(ia)) NEAREST_INDEX_ = ia + else + i = 1 + keep_going = .true. + do while (i <= ia .and. keep_going) + i = i+1 + if (value <= array(i)) then + NEAREST_INDEX_ = i + if (array(i)-value > value-array(i-1)) NEAREST_INDEX_ = i-1 + keep_going = .false. + endif + enddo + endif + end function NEAREST_INDEX_ + + !############################################################################# + + subroutine INTERP_1D_LINEAR_(grid1,grid2,data1,data2) + + real(kind=FMS_AU_KIND_), dimension(:), intent(in) :: grid1, data1, grid2 + real(kind=FMS_AU_KIND_), dimension(:), intent(inout) :: data2 + + integer :: n1, n2, i, n + real(kind=FMS_AU_KIND_) :: w + integer, parameter :: lkind = FMS_AU_KIND_ + + n1 = size(grid1(:)) + n2 = size(grid2(:)) + + + do i = 2, n1 + if (grid1(i) <= grid1(i-1)) call mpp_error(FATAL, 'grid1 not monotonic') + enddo + + do i = 2, n2 + if (grid2(i) <= grid2(i-1)) call mpp_error(FATAL, 'grid2 not monotonic') + enddo + + if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1') + if (grid1(n1) < grid2(n2) ) call mpp_error(FATAL, 'grid2 lies outside grid1') + + do i = 1, n2 + n = nearest_index(grid2(i),grid1) + + if (grid1(n) < grid2(i)) then + w = (grid2(i)-grid1(n))/(grid1(n+1)-grid1(n)) + data2(i) = (1.0_lkind-w)*data1(n) + w*data1(n+1) + else + if(n==1) then + data2(i) = data1(n) + else + w = (grid2(i)-grid1(n-1))/(grid1(n)-grid1(n-1)) + data2(i) = (1.0_lkind-w)*data1(n-1) + w*data1(n) + endif + endif + enddo + + + return + + end subroutine INTERP_1D_LINEAR_ + + !################################################################### + subroutine INTERP_1D_CUBIC_SPLINE_(grid1, grid2, data1, data2, yp1, ypn) + + real(kind=FMS_AU_KIND_), dimension(:), intent(in) :: grid1, grid2, data1 + real(kind=FMS_AU_KIND_), dimension(:), intent(inout) :: data2 + real(kind=FMS_AU_KIND_), intent(in) :: yp1, ypn + + real(kind=FMS_AU_KIND_), dimension(size(grid1)) :: y2, u + real(kind=FMS_AU_KIND_) :: sig, p, qn, un, h, a ,b + integer :: n, m, i, k, klo, khi + integer, parameter :: lkind = FMS_AU_KIND_ + + n = size(grid1(:)) + m = size(grid2(:)) + + do i = 2, n + if (grid1(i) <= grid1(i-1)) call mpp_error(FATAL, 'grid1 not monotonic') + enddo + + do i = 2, m + if (grid2(i) <= grid2(i-1)) call mpp_error(FATAL, 'grid2 not monotonic') + enddo + + if (grid1(1) > grid2(1) ) call mpp_error(FATAL, 'grid2 lies outside grid1') + if (grid1(n) < grid2(m) ) call mpp_error(FATAL, 'grid2 lies outside grid1') + +if (yp1>0.99e30_lkind) then + y2(1) = 0.0_lkind + u(1) = 0.0_lkind + else + y2(1) = -0.5_lkind + u(1) = (3.0_lkind)/(grid1(2)-grid1(1))*((data1(2)-data1(1))/(grid1(2)-grid1(1))-yp1) + endif + + do i = 2, n-1 + sig = (grid1(i)-grid1(i-1))/(grid1(i+1)-grid1(i-1)) + p = sig*y2(i-1) + 2.0_lkind + y2(i) = (sig-1.0_lkind)/p + u(i) = (6.0_lkind*((data1(i+1)-data1(i))/(grid1(i+1)-grid1(i))-(data1(i)-data1(i-1)) & + /(grid1(i)-grid1(i-1)))/(grid1(i+1)-grid1(i-1))-sig*u(i-1))/p + enddo + + if (ypn>0.99e30_lkind) then + qn = 0.0_lkind + un = 0.0_lkind + else + qn = 0.5_lkind + un = (3.0_lkind)/(grid1(n)-grid1(n-1))*(ypn-(data1(n)-data1(n-1))/ & + (grid1(n)-grid1(n-1))) + endif + + y2(n) = (un-qn*u(n-1))/(qn*y2(n-1)+1.0_lkind) + + do k = n-1,1,-1 + y2(k) = y2(k)*y2(k+1)+u(k) + enddo + + do k = 1, m + n = nearest_index(grid2(k),grid1) + if (grid1(n) < grid2(k)) then + klo = n + else + if(n==1) then + klo = n + else + klo = n -1 + endif + endif + + khi = klo+1 + h = grid1(khi)-grid1(klo) + a = (grid1(khi) - grid2(k))/h + b = (grid2(k) - grid1(klo))/h + data2(k) = a*data1(klo) + b*data1(khi)+ ((a**3-a)*y2(klo) + (b**3-b)*y2(khi))*(h**2) & + /6.0_lkind + enddo + + end subroutine INTERP_1D_CUBIC_SPLINE_ + + !################################################################### + + subroutine INTERP_1D_1D_(grid1,grid2,data1,data2, method, yp1, yp2) + + real(kind=FMS_AU_KIND_), dimension(:), intent(in) :: grid1, data1, grid2 + real(kind=FMS_AU_KIND_), dimension(:), intent(inout) :: data2 + character(len=*), optional, intent(in) :: method + real(kind=FMS_AU_KIND_), optional, intent(in) :: yp1, yp2 + + real(kind=FMS_AU_KIND_) :: y1, y2 + character(len=32) :: interp_method + integer :: k2, ks, ke + integer, parameter :: lkind = FMS_AU_KIND_ + + k2 = size(grid2(:)) + + interp_method = "linear" + if(present(method)) interp_method = method + y1 = 1.0e30_lkind + + if(present(yp1)) y1 = yp1 + y2 = 1.0e30_lkind + + if(present(yp2)) y2 = yp2 + call find_index(grid1, grid2(1), grid2(k2), ks, ke) + select case(trim(interp_method)) + case("linear") + call interp_1d_linear(grid1(ks:ke),grid2,data1(ks:ke),data2) + case("cubic_spline") + call interp_1d_cubic_spline(grid1(ks:ke),grid2,data1(ks:ke),data2, y1, y2) + case default + call mpp_error(FATAL,"axis_utils: interp_method should be linear or cubic_spline") + end select + + return + + end subroutine INTERP_1D_1D_ + + !################################################################### + + + subroutine INTERP_1D_2D_(grid1,grid2,data1,data2) + + real(kind=FMS_AU_KIND_), dimension(:,:), intent(in) :: grid1, data1, grid2 + real(kind=FMS_AU_KIND_), dimension(:,:), intent(inout) :: data2 + + integer :: n1, n2, n, k2, ks, ke + + n1 = size(grid1,1) + n2 = size(grid2,1) + k2 = size(grid2,2) + + if (n1 /= n2) call mpp_error(FATAL,'grid size mismatch') + + do n = 1, n1 + call find_index(grid1(n,:), grid2(n,1), grid2(n,k2), ks, ke) + call interp_1d_linear(grid1(n,ks:ke),grid2(n,:),data1(n,ks:ke),data2(n,:)) + enddo + + return + + end subroutine INTERP_1D_2D_ + + !################################################################### + + subroutine INTERP_1D_3D_(grid1,grid2,data1,data2, method, yp1, yp2) + + real(FMS_AU_KIND_), dimension(:,:,:), intent(in) :: grid1, data1, grid2 + real(FMS_AU_KIND_), dimension(:,:,:), intent(inout) :: data2 + character(len=*), optional, intent(in) :: method + real(kind=FMS_AU_KIND_), optional, intent(in) :: yp1, yp2 + + integer :: n1, n2, m1, m2, k2, n, m + real(kind=FMS_AU_KIND_) :: y1, y2 + character(len=32) :: interp_method + integer :: ks, ke + integer, parameter :: lkind = FMS_AU_KIND_ + + n1 = size(grid1,1) + n2 = size(grid2,1) + m1 = size(grid1,2) + m2 = size(grid2,2) + k2 = size(grid2,3) + + interp_method = "linear" + if(present(method)) interp_method = method + y1 = 1.0e30_lkind + + if(present(yp1)) y1 = yp1 + y2 = 1.0e30_lkind + if(present(yp2)) y2 = yp2 + + if (n1 /= n2 .or. m1 /= m2) call mpp_error(FATAL,'grid size mismatch') + + select case(trim(interp_method)) + case("linear") + do m = 1, m1 + do n = 1, n1 + call find_index(grid1(n,m,:), grid2(n,m,1), grid2(n,m,k2), ks, ke) + call interp_1d_linear(grid1(n,m,ks:ke),grid2(n,m,:),data1(n,m,ks:ke),data2(n,m,:)) + enddo + enddo + + case("cubic_spline") + do m = 1, m1 + do n = 1, n1 + call find_index(grid1(n,m,:), grid2(n,m,1), grid2(n,m,k2), ks, ke) + call interp_1d_cubic_spline(grid1(n,m,ks:ke),grid2(n,m,:), data1(n,m,ks:ke),data2(n,m,:), y1, y2) + enddo + enddo + + case default + call mpp_error(FATAL,"axis_utils: interp_method should be linear or cubic_spline") + end select + + return + + end subroutine INTERP_1D_3D_ + + + !##################################################################### + subroutine FIND_INDEX_(grid1, xs, xe, ks, ke) + real(kind=FMS_AU_KIND_), dimension(:), intent(in) :: grid1 + real(kind=FMS_AU_KIND_), intent(in) :: xs, xe + integer, intent(out) :: ks, ke + + integer :: k, nk + + nk = size(grid1(:)) + + ks = 0; ke = 0 + do k = 1, nk-1 + if(grid1(k) <= xs .and. grid1(k+1) > xs ) then + ks = k + exit + endif + enddo + + do k = nk, 2, -1 + if(grid1(k) >= xe .and. grid1(k-1) < xe ) then + ke = k + exit + endif + enddo + + if(ks == 0 ) call mpp_error(FATAL,' xs locate outside of grid1') + if(ke == 0 ) call mpp_error(FATAL,' xe locate outside of grid1') + + end subroutine FIND_INDEX_ + !> @} + ! close documentation grouping diff --git a/axis_utils/include/axis_utils2_r4.fh b/axis_utils/include/axis_utils2_r4.fh new file mode 100644 index 0000000000..b7eb3337c0 --- /dev/null +++ b/axis_utils/include/axis_utils2_r4.fh @@ -0,0 +1,67 @@ +! -*-f90-*- + +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @file +!> @brief Imports checksum, gather, and scatter routines from other include files used +!! for communications and calculations between PE's in @ref mpp_mod + +!> @addtogroup mpp_mod +!> @{ + +#undef FMS_AU_KIND_ +#define FMS_AU_KIND_ r4_kind + +#undef AXIS_EDGES_ +#define AXIS_EDGES_ axis_edges_r4 + +#undef LON_IN_RANGE_ +#define LON_IN_RANGE_ lon_in_range_r4 + +#undef FRAC_INDEX_ +#define FRAC_INDEX_ frac_index_r4 + +#undef NEAREST_INDEX_ +#define NEAREST_INDEX_ nearest_index_r4 + +#undef TRANLON_ +#define TRANLON_ tranlon_r4 + +#undef INTERP_1D_LINEAR_ +#define INTERP_1D_LINEAR_ interp_1d_linear_r4 + +#undef INTERP_1D_CUBIC_SPLINE_ +#define INTERP_1D_CUBIC_SPLINE_ interp_1d_cubic_spline_r4 + +#undef INTERP_1D_1D_ +#define INTERP_1D_1D_ interp_1d_1d_r4 + +#undef INTERP_1D_2D_ +#define INTERP_1D_2D_ interp_1d_2d_r4 + +#undef INTERP_1D_3D_ +#define INTERP_1D_3D_ interp_1d_3d_r4 + +#undef FIND_INDEX_ +#define FIND_INDEX_ find_index_r4 + +#include "axis_utils2.inc" + +!> @} +! close documentation grouping \ No newline at end of file diff --git a/axis_utils/include/axis_utils2_r8.fh b/axis_utils/include/axis_utils2_r8.fh new file mode 100644 index 0000000000..ac6c176996 --- /dev/null +++ b/axis_utils/include/axis_utils2_r8.fh @@ -0,0 +1,67 @@ +! -*-f90-*- + +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @file +!> @brief Imports checksum, gather, and scatter routines from other include files used +!! for communications and calculations between PE's in @ref mpp_mod + +!> @addtogroup mpp_mod +!> @{ + +#undef FMS_AU_KIND_ +#define FMS_AU_KIND_ r8_kind + +#undef AXIS_EDGES_ +#define AXIS_EDGES_ axis_edges_r8 + +#undef LON_IN_RANGE_ +#define LON_IN_RANGE_ lon_in_range_r8 + +#undef FRAC_INDEX_ +#define FRAC_INDEX_ frac_index_r8 + +#undef NEAREST_INDEX_ +#define NEAREST_INDEX_ nearest_index_r8 + +#undef TRANLON_ +#define TRANLON_ tranlon_r8 + +#undef INTERP_1D_LINEAR_ +#define INTERP_1D_LINEAR_ interp_1d_linear_r8 + +#undef INTERP_1D_CUBIC_SPLINE_ +#define INTERP_1D_CUBIC_SPLINE_ interp_1d_cubic_spline_r8 + +#undef INTERP_1D_1D_ +#define INTERP_1D_1D_ interp_1d_1d_r8 + +#undef INTERP_1D_2D_ +#define INTERP_1D_2D_ interp_1d_2d_r8 + +#undef INTERP_1D_3D_ +#define INTERP_1D_3D_ interp_1d_3d_r8 + +#undef FIND_INDEX_ +#define FIND_INDEX_ find_index_r8 + +#include "axis_utils2.inc" + +!> @} +! close documentation grouping \ No newline at end of file diff --git a/configure.ac b/configure.ac index 799fa4ba48..241e08d079 100644 --- a/configure.ac +++ b/configure.ac @@ -480,6 +480,7 @@ AC_CONFIG_FILES([ test_fms/coupler/Makefile test_fms/parser/Makefile test_fms/string_utils/Makefile + test_fms/sat_vapor_pres/Makefile FMS.pc ]) diff --git a/fms/Makefile.am b/fms/Makefile.am index ea443f17e6..8f8c58525b 100644 --- a/fms/Makefile.am +++ b/fms/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/fms/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build these uninstalled convenience libraries. @@ -32,6 +32,9 @@ noinst_LTLIBRARIES = libfms.la # Each convenience library depends on its source. libfms_la_SOURCES = \ fms.F90 \ + include/fms.inc \ + include/fms_r4.fh \ + include/fms_r8.fh \ fms_io.F90 \ fms_io_unstructured_field_exist.inc \ fms_io_unstructured_get_file_name.inc \ @@ -47,7 +50,12 @@ libfms_la_SOURCES = \ fms_io_unstructured_save_restart.inc \ read_data_3d.inc -fms_mod.$(FC_MODEXT): fms_io_mod.$(FC_MODEXT) +fms_mod.$(FC_MODEXT): fms_io_mod.$(FC_MODEXT) \ + fms.F90 \ + include/fms.inc \ + include/fms_r4.fh \ + include/fms_r8.fh + fms_io_mod.$(FC_MODEXT): fms_io_unstructured_field_exist.inc \ fms_io_unstructured_get_file_name.inc \ fms_io_unstructured_register_restart_axis.inc \ diff --git a/fms/fms.F90 b/fms/fms.F90 index e37139a056..7067b86aee 100644 --- a/fms/fms.F90 +++ b/fms/fms.F90 @@ -96,7 +96,7 @@ module fms_mod ! ! uppercase Convert character strings to all upper case ! -! monotonic_array Determines if the real input array has +! monotonic_array Determines if the real input array has strictly ! monotonically increasing or decreasing values. ! ! string_array_index Match the input character string to a string @@ -162,6 +162,7 @@ module fms_mod use memutils_mod, only: print_memuse_stats, memutils_init use grid2_mod, only: grid_init, grid_end use fms_string_utils_mod, only: fms_c2f_string, fms_cstring2cpointer, string +use platform_mod, only: r4_kind, r8_kind use, intrinsic :: iso_c_binding @@ -214,6 +215,10 @@ module fms_mod ! public mpp-io interfaces public :: do_cf_compliance +interface monotonic_array + module procedure :: monotonic_array_r4, monotonic_array_r8 +end interface monotonic_array + !Balaji !this is published by fms and applied to any initialized clocks !of course you can go and set the flag to SYNC or DETAILED by hand @@ -720,51 +725,6 @@ function string_array_index ( string, string_array, index ) result (found) end function string_array_index -!####################################################################### - -!> @brief Determines if a real input array has monotonically increasing or -!! decreasing values. -!! @return If the input array of real values either increases or decreases monotonically then true -!! is returned, otherwise false is returned. -function monotonic_array ( array, direction ) -real, intent(in) :: array(:) !< An array of real values. If the size(array) < 2 this function - !! assumes the array is not monotonic, no fatal error will occur. -integer, intent(out), optional :: direction !< If the input array is: - !! >> monotonic (small to large) then direction = +1. - !! >> monotonic (large to small) then direction = -1. - !! >> not monotonic then direction = 0. -logical :: monotonic_array !< If the input array of real values either increases or decreases monotonically - !! then TRUE is returned, otherwise FALSE is returned. -integer :: i - -! initialize - monotonic_array = .false. - if (present(direction)) direction = 0 - -! array too short - if ( size(array(:)) < 2 ) return - -! ascending - if ( array(1) < array(size(array(:))) ) then - do i = 2, size(array(:)) - if (array(i-1) < array(i)) cycle - return - enddo - monotonic_array = .true. - if (present(direction)) direction = +1 - -! descending - else - do i = 2, size(array(:)) - if (array(i-1) > array(i)) cycle - return - enddo - monotonic_array = .true. - if (present(direction)) direction = -1 - endif - -end function monotonic_array - !####################################################################### !> @brief Prints to the log file (or a specified unit) the version id string and !! tag name. @@ -794,6 +754,9 @@ subroutine write_version_number (version, tag, unit) end subroutine write_version_number +#include "fms_r4.fh" +#include "fms_r8.fh" + end module fms_mod ! ! diff --git a/fms/include/fms.inc b/fms/include/fms.inc new file mode 100644 index 0000000000..960a529ced --- /dev/null +++ b/fms/include/fms.inc @@ -0,0 +1,64 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @brief Determines if a real input array has values which increase or +!! decrease with strict monotonicity. +!! @return If the input array of real values either increases or decreases in a strictly monotonic manner, +!! then true is returned. Otherwise, false is returned. + +function MONOTONIC_ARRAY_(array, direction) result(ret) +real(FMS_MOD_KIND_), intent(in) :: array(:) !< An array of real values. If size(array) < 2, this function + !! assumes the array is not monotonic; no fatal error will occur + !! in this case. +integer, intent(out), optional :: direction !< If the input array is: + !! >> strictly monotonic (small to large), then direction = +1. + !! >> strictly monotonic (large to small), then direction = -1. + !! >> not strictly monotonic, then direction = 0. +logical :: ret !< If the input array of real values either increases or + !! decreases with strict monotonicity, then TRUE is returned; + !! otherwise, FALSE is returned. +integer :: i + +! initialize + ret = .false. + if (present(direction)) direction = 0 + +! array too short + if ( size(array(:)) < 2 ) return + +! ascending + if ( array(1) < array(size(array(:))) ) then + do i = 2, size(array(:)) + if (array(i-1) < array(i)) cycle + return + enddo + ret = .true. + if (present(direction)) direction = +1 + +! descending + else + do i = 2, size(array(:)) + if (array(i-1) > array(i)) cycle + return + enddo + ret = .true. + if (present(direction)) direction = -1 + endif + +end function diff --git a/fms/include/fms_r4.fh b/fms/include/fms_r4.fh new file mode 100644 index 0000000000..1347478c4b --- /dev/null +++ b/fms/include/fms_r4.fh @@ -0,0 +1,8 @@ +#undef FMS_MOD_KIND_ +#undef MONOTONIC_ARRAY_ + +#define FMS_MOD_KIND_ r4_kind +#define MONOTONIC_ARRAY_ monotonic_array_r4 +#include "fms.inc" +#undef FMS_MOD_KIND_ +#undef MONOTONIC_ARRAY_ diff --git a/fms/include/fms_r8.fh b/fms/include/fms_r8.fh new file mode 100644 index 0000000000..37cd103093 --- /dev/null +++ b/fms/include/fms_r8.fh @@ -0,0 +1,8 @@ +#undef FMS_MOD_KIND_ +#undef MONOTONIC_ARRAY_ + +#define FMS_MOD_KIND_ r8_kind +#define MONOTONIC_ARRAY_ monotonic_array_r8 +#include "fms.inc" +#undef FMS_MOD_KIND_ +#undef MONOTONIC_ARRAY_ diff --git a/horiz_interp/Makefile.am b/horiz_interp/Makefile.am index ead18ecbb2..55f8f1cbbd 100644 --- a/horiz_interp/Makefile.am +++ b/horiz_interp/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/horiz_interp/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build these uninstalled convenience libraries. @@ -36,7 +36,25 @@ libhoriz_interp_la_SOURCES = \ horiz_interp_conserve.F90 \ horiz_interp.F90 \ horiz_interp_spherical.F90 \ - horiz_interp_type.F90 + horiz_interp_type.F90 \ + include/horiz_interp_bicubic.inc \ + include/horiz_interp_bilinear.inc \ + include/horiz_interp_conserve.inc \ + include/horiz_interp.inc \ + include/horiz_interp_spherical.inc \ + include/horiz_interp_type.inc \ + include/horiz_interp_bicubic_r4.fh \ + include/horiz_interp_bilinear_r4.fh \ + include/horiz_interp_conserve_r4.fh \ + include/horiz_interp_r4.fh \ + include/horiz_interp_spherical_r4.fh \ + include/horiz_interp_type_r4.fh \ + include/horiz_interp_bicubic_r8.fh \ + include/horiz_interp_bilinear_r8.fh \ + include/horiz_interp_conserve_r8.fh \ + include/horiz_interp_r8.fh \ + include/horiz_interp_spherical_r8.fh \ + include/horiz_interp_type_r8.fh # Some mods are dependant on other mods in this dir. horiz_interp_bicubic_mod.$(FC_MODEXT): horiz_interp_type_mod.$(FC_MODEXT) diff --git a/horiz_interp/horiz_interp.F90 b/horiz_interp/horiz_interp.F90 index 9d694f4d21..5b29559f3d 100644 --- a/horiz_interp/horiz_interp.F90 +++ b/horiz_interp/horiz_interp.F90 @@ -58,6 +58,7 @@ module horiz_interp_mod use horiz_interp_bicubic_mod, only: horiz_interp_bicubic_new, horiz_interp_bicubic_del use horiz_interp_spherical_mod, only: horiz_interp_spherical_init, horiz_interp_spherical use horiz_interp_spherical_mod, only: horiz_interp_spherical_new, horiz_interp_spherical_del +use platform_mod, only: r4_kind, r8_kind implicit none private @@ -122,10 +123,18 @@ module horiz_interp_mod !! interpolations. To reinitialize this variable for a different grid-to-grid !! interpolation you must first use the "horiz_interp_del" interface. interface horiz_interp_new - module procedure horiz_interp_new_1d ! Source grid is 1d, destination grid is 1d - module procedure horiz_interp_new_1d_src ! Source grid is 1d, destination grid is 2d - module procedure horiz_interp_new_2d ! Source grid is 2d, destination grid is 2d - module procedure horiz_interp_new_1d_dst ! Source grid is 2d, destination grid is 1d + ! Source grid is 1d, destination grid is 1d + module procedure horiz_interp_new_1d_r4 + module procedure horiz_interp_new_1d_r8 + ! Source grid is 1d, destination grid is 2d + module procedure horiz_interp_new_1d_src_r4 + module procedure horiz_interp_new_1d_src_r8 + ! Source grid is 2d, destination grid is 2d + module procedure horiz_interp_new_2d_r4 + module procedure horiz_interp_new_2d_r8 + ! Source grid is 2d, destination grid is 1d + module procedure horiz_interp_new_1d_dst_r4 + module procedure horiz_interp_new_1d_dst_r8 end interface @@ -186,15 +195,33 @@ module horiz_interp_mod !! sure you have the correct grid size. !> @ingroup horiz_interp_mod interface horiz_interp - module procedure horiz_interp_base_2d - module procedure horiz_interp_base_3d - module procedure horiz_interp_solo_1d - module procedure horiz_interp_solo_1d_src - module procedure horiz_interp_solo_2d - module procedure horiz_interp_solo_1d_dst - module procedure horiz_interp_solo_old + module procedure horiz_interp_base_2d_r4 + module procedure horiz_interp_base_2d_r8 + module procedure horiz_interp_base_3d_r4 + module procedure horiz_interp_base_3d_r8 + module procedure horiz_interp_solo_1d_r4 + module procedure horiz_interp_solo_1d_r8 + module procedure horiz_interp_solo_1d_src_r4 + module procedure horiz_interp_solo_1d_src_r8 + module procedure horiz_interp_solo_2d_r4 + module procedure horiz_interp_solo_2d_r8 + module procedure horiz_interp_solo_1d_dst_r4 + module procedure horiz_interp_solo_1d_dst_r8 + module procedure horiz_interp_solo_old_r4 + module procedure horiz_interp_solo_old_r8 end interface +!> Private helper routines +interface is_lat_lon + module procedure is_lat_lon_r4 + module procedure is_lat_lon_r8 +end interface + +interface horiz_interp_solo_1d + module procedure horiz_interp_solo_1d_r4 + module procedure horiz_interp_solo_1d_r8 +end interface + !> @addtogroup horiz_interp_mod !> @{ @@ -247,778 +274,6 @@ subroutine horiz_interp_init end subroutine horiz_interp_init -!####################################################################### - - !> @brief Creates a 1D @ref horiz_interp_type with the given parameters - subroutine horiz_interp_new_1d (Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, & - grid_at_center, mask_in, mask_out) - - !----------------------------------------------------------------------- - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:) :: lon_out, lat_out - integer, intent(in), optional :: verbose - character(len=*), intent(in), optional :: interp_method - integer, intent(in), optional :: num_nbrs - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo - logical, intent(in), optional :: grid_at_center - real, intent(in), dimension(:,:), optional :: mask_in !< dummy variable - real, intent(inout),dimension(:,:), optional :: mask_out !< dummy variable - !----------------------------------------------------------------------- - real, dimension(:,:), allocatable :: lon_src, lat_src, lon_dst, lat_dst - real, dimension(:), allocatable :: lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d - integer :: i, j, nlon_in, nlat_in, nlon_out, nlat_out - logical :: center - character(len=40) :: method - !----------------------------------------------------------------------- - call horiz_interp_init - - method = 'conservative' - if(present(interp_method)) method = interp_method - - select case (trim(method)) - case ("conservative") - Interp%interp_method = CONSERVE - call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose) - case ("bilinear") - Interp%interp_method = BILINEAR - center = .false. - if(present(grid_at_center) ) center = grid_at_center - if(center) then - nlon_out = size(lon_out(:)); nlat_out = size(lat_out(:)) - allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) - do i = 1, nlon_out - lon_dst(i,:) = lon_out(i) - enddo - do j = 1, nlat_out - lat_dst(:,j) = lat_out(j) - enddo - - call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, & - verbose, src_modulo) - deallocate(lon_dst, lat_dst) - else - nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 - nlon_out = size(lon_out(:))-1; nlat_out = size(lat_out(:))-1 - allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) - allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) - do i = 1, nlon_in - lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5 - enddo - do j = 1, nlat_in - lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5 - enddo - do i = 1, nlon_out - lon_dst(i,:) = (lon_out(i) + lon_out(i+1)) * 0.5 - enddo - do j = 1, nlat_out - lat_dst(:,j) = (lat_out(j) + lat_out(j+1)) * 0.5 - enddo - call horiz_interp_bilinear_new ( Interp, lon_src_1d, lat_src_1d, lon_dst, lat_dst, & - verbose, src_modulo) - deallocate(lon_src_1d, lat_src_1d, lon_dst, lat_dst) - endif - case ("bicubic") - Interp%interp_method = BICUBIC - center = .false. - if(present(grid_at_center) ) center = grid_at_center - !No need to expand to 2d, horiz_interp_bicubic_new does 1d-1d - if(center) then - call horiz_interp_bicubic_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo) - else - nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 - nlon_out = size(lon_out(:))-1; nlat_out = size(lat_out(:))-1 - allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) - allocate(lon_dst_1d(nlon_out), lat_dst_1d(nlat_out)) - do i = 1, nlon_in - lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5 - enddo - do j = 1, nlat_in - lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5 - enddo - do i = 1, nlon_out - lon_dst_1d(i) = (lon_out(i) + lon_out(i+1)) * 0.5 - enddo - do j = 1, nlat_out - lat_dst_1d(j) = (lat_out(j) + lat_out(j+1)) * 0.5 - enddo - call horiz_interp_bicubic_new ( Interp, lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d, & - verbose, src_modulo) - deallocate(lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d) - endif - case ("spherical") - Interp%interp_method = SPHERICA - nlon_in = size(lon_in(:)); nlat_in = size(lat_in(:)) - nlon_out = size(lon_out(:)); nlat_out = size(lat_out(:)) - allocate(lon_src(nlon_in,nlat_in), lat_src(nlon_in,nlat_in)) - allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) - do i = 1, nlon_in - lon_src(i,:) = lon_in(i) - enddo - do j = 1, nlat_in - lat_src(:,j) = lat_in(j) - enddo - do i = 1, nlon_out - lon_dst(i,:) = lon_out(i) - enddo - do j = 1, nlat_out - lat_dst(:,j) = lat_out(j) - enddo - call horiz_interp_spherical_new ( Interp, lon_src, lat_src, lon_dst, lat_dst, & - num_nbrs, max_dist, src_modulo) - deallocate(lon_src, lat_src, lon_dst, lat_dst) - case default - call mpp_error(FATAL,'horiz_interp_mod: interp_method should be conservative, bilinear, bicubic, spherical') - end select - - !----------------------------------------------------------------------- - Interp%I_am_initialized = .true. - - end subroutine horiz_interp_new_1d - -!####################################################################### - - subroutine horiz_interp_new_1d_src (Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, interp_method, num_nbrs, max_dist, & - src_modulo, grid_at_center, mask_in, mask_out, is_latlon_out ) - - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - integer, intent(in), optional :: verbose - character(len=*), intent(in), optional :: interp_method - integer, intent(in), optional :: num_nbrs !< minimum number of neighbors - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo - logical, intent(in), optional :: grid_at_center - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out),dimension(:,:), optional :: mask_out - logical, intent(in), optional :: is_latlon_out - - real, dimension(:,:), allocatable :: lon_src, lat_src - real, dimension(:), allocatable :: lon_src_1d, lat_src_1d - integer :: i, j, nlon_in, nlat_in - character(len=40) :: method - logical :: center - logical :: dst_is_latlon - !----------------------------------------------------------------------- - call horiz_interp_init - - method = 'conservative' - if(present(interp_method)) method = interp_method - - select case (trim(method)) - case ("conservative") - Interp%interp_method = CONSERVE - !--- check to see if the source grid is regular lat-lon grid or not. - if(PRESENT(is_latlon_out)) then - dst_is_latlon = is_latlon_out - else - dst_is_latlon = is_lat_lon(lon_out, lat_out) - end if - if(dst_is_latlon ) then - if(present(mask_in)) then - if ( ANY(mask_in < -.0001) .or. ANY(mask_in > 1.0001) ) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_1d_src(horiz_interp_conserve_mod): input mask not between 0,1') - allocate(Interp%mask_in(size(mask_in,1), size(mask_in,2)) ) - Interp%mask_in = mask_in - end if - call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out(:,1), lat_out(1,:), & - verbose=verbose ) - else - call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose=verbose, mask_in=mask_in, mask_out=mask_out ) - end if - case ("bilinear") - Interp%interp_method = BILINEAR - center = .false. - if(present(grid_at_center) ) center = grid_at_center - if(center) then - call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo ) - else - nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 - allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) - do i = 1, nlon_in - lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5 - enddo - do j = 1, nlat_in - lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5 - enddo - call horiz_interp_bilinear_new ( Interp, lon_src_1d, lat_src_1d, lon_out, lat_out, & - verbose, src_modulo ) - deallocate(lon_src_1d,lat_src_1d) - endif - case ("bicubic") - Interp%interp_method = BICUBIC - center = .false. - if(present(grid_at_center) ) center = grid_at_center - if(center) then - call horiz_interp_bicubic_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo ) - else - nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 - allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) - do i = 1, nlon_in - lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5 - enddo - do j = 1, nlat_in - lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5 - enddo - call horiz_interp_bicubic_new ( Interp, lon_src_1d, lat_src_1d, lon_out, lat_out, & - verbose, src_modulo ) - deallocate(lon_src_1d,lat_src_1d) - endif - case ("spherical") - Interp%interp_method = SPHERICA - nlon_in = size(lon_in(:)); nlat_in = size(lat_in(:)) - allocate(lon_src(nlon_in,nlat_in), lat_src(nlon_in,nlat_in)) - do i = 1, nlon_in - lon_src(i,:) = lon_in(i) - enddo - do j = 1, nlat_in - lat_src(:,j) = lat_in(j) - enddo - call horiz_interp_spherical_new ( Interp, lon_src, lat_src, lon_out, lat_out, & - num_nbrs, max_dist, src_modulo) - deallocate(lon_src, lat_src) - case default - call mpp_error(FATAL,'interp_method should be conservative, bilinear, bicubic, spherical') - end select - - !----------------------------------------------------------------------- - Interp%I_am_initialized = .true. - - end subroutine horiz_interp_new_1d_src - -!####################################################################### - - subroutine horiz_interp_new_2d (Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, interp_method, num_nbrs, max_dist, & - src_modulo, mask_in, mask_out, is_latlon_in, is_latlon_out ) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - integer, intent(in), optional :: verbose - character(len=*), intent(in), optional :: interp_method - integer, intent(in), optional :: num_nbrs - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out),dimension(:,:), optional :: mask_out - logical, intent(in), optional :: is_latlon_in, is_latlon_out - logical :: src_is_latlon, dst_is_latlon - character(len=40) :: method -!----------------------------------------------------------------------- - call horiz_interp_init - - method = 'bilinear' - if(present(interp_method)) method = interp_method - - select case (trim(method)) - case ("conservative") - Interp%interp_method = CONSERVE - if(PRESENT(is_latlon_in)) then - src_is_latlon = is_latlon_in - else - src_is_latlon = is_lat_lon(lon_in, lat_in) - end if - if(PRESENT(is_latlon_out)) then - dst_is_latlon = is_latlon_out - else - dst_is_latlon = is_lat_lon(lon_out, lat_out) - end if - if(src_is_latlon .AND. dst_is_latlon) then - if(present(mask_in)) then - if ( ANY(mask_in < -.0001) .or. ANY(mask_in > 1.0001) ) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_2d(horiz_interp_conserve_mod): input mask not between 0,1') - allocate(Interp%mask_in(size(mask_in,1), size(mask_in,2)) ) - Interp%mask_in = mask_in - end if - call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out(:,1), lat_out(1,:), & - verbose=verbose ) - else if(src_is_latlon) then - call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out, lat_out, & - verbose=verbose, mask_in=mask_in, mask_out=mask_out ) - else if(dst_is_latlon) then - call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out(:,1), lat_out(1,:), & - verbose=verbose, mask_in=mask_in, mask_out=mask_out ) - else - call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose=verbose, mask_in=mask_in, mask_out=mask_out ) - end if - - case ("spherical") - Interp%interp_method = SPHERICA - call horiz_interp_spherical_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - num_nbrs, max_dist, src_modulo ) - case ("bilinear") - Interp%interp_method = BILINEAR - call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo ) - case default - call mpp_error(FATAL,'when source grid are 2d, interp_method should be spherical or bilinear') - end select - -!----------------------------------------------------------------------- - Interp%I_am_initialized = .true. - - end subroutine horiz_interp_new_2d - -!####################################################################### - subroutine horiz_interp_new_1d_dst (Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, interp_method, num_nbrs, max_dist, src_modulo, mask_in, mask_out, is_latlon_in ) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:) :: lon_out, lat_out - integer, intent(in), optional :: verbose - character(len=*), intent(in), optional :: interp_method - integer, intent(in), optional :: num_nbrs - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out),dimension(:,:), optional :: mask_out - logical, intent(in), optional :: is_latlon_in - - character(len=40) :: method - !-------------some local variables----------------------------------------------- - integer :: i, j, nlon_out, nlat_out - real, dimension(:,:), allocatable :: lon_dst, lat_dst - logical :: src_is_latlon - !----------------------------------------------------------------------- - call horiz_interp_init - - method = 'bilinear' - if(present(interp_method)) method = interp_method - - nlon_out = size(lon_out(:)); nlat_out = size(lat_out(:)) - allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) - do i = 1, nlon_out - lon_dst(i,:) = lon_out(i) - enddo - do j = 1, nlat_out - lat_dst(:,j) = lat_out(j) - enddo - - select case (trim(method)) - case ("conservative") - Interp%interp_method = CONSERVE - if(PRESENT(is_latlon_in)) then - src_is_latlon = is_latlon_in - else - src_is_latlon = is_lat_lon(lon_in, lat_in) - end if - - if(src_is_latlon) then - if(present(mask_in)) then - if ( ANY(mask_in < -.0001) .or. ANY(mask_in > 1.0001) ) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_1d_dst(horiz_interp_conserve_mod): input mask not between 0,1') - allocate(Interp%mask_in(size(mask_in,1), size(mask_in,2)) ) - Interp%mask_in = mask_in - end if - call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out, lat_out, & - verbose=verbose) - else - call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose=verbose, mask_in=mask_in, mask_out=mask_out ) - end if - case ("bilinear") - Interp%interp_method = BILINEAR - call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, & - verbose, src_modulo ) - case ("spherical") - Interp%interp_method = SPHERICA - call horiz_interp_spherical_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, & - num_nbrs, max_dist, src_modulo) - case default - call mpp_error(FATAL,'when source grid are 2d, interp_method should be spherical or bilinear') - end select - - deallocate(lon_dst,lat_dst) - - !----------------------------------------------------------------------- - Interp%I_am_initialized = .true. - - end subroutine horiz_interp_new_1d_dst - -!####################################################################### - - subroutine horiz_interp_base_2d ( Interp, data_in, data_out, verbose, & - mask_in, mask_out, missing_value, missing_permit, & - err_msg, new_missing_handle ) -!----------------------------------------------------------------------- - type (horiz_interp_type), intent(in) :: Interp - real, intent(in), dimension(:,:) :: data_in - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - character(len=*), intent(out), optional :: err_msg - logical, intent(in), optional :: new_missing_handle -!----------------------------------------------------------------------- - if(present(err_msg)) err_msg = '' - if(.not.Interp%I_am_initialized) then - if(fms_error_handler('horiz_interp','The horiz_interp_type variable is not initialized',err_msg)) return - endif - - select case(Interp%interp_method) - case(CONSERVE) - call horiz_interp_conserve(Interp,data_in, data_out, verbose, mask_in, mask_out) - case(BILINEAR) - call horiz_interp_bilinear(Interp,data_in, data_out, verbose, mask_in, mask_out, & - missing_value, missing_permit, new_missing_handle ) - case(BICUBIC) - call horiz_interp_bicubic(Interp,data_in, data_out, verbose, mask_in, mask_out, & - missing_value, missing_permit ) - case(SPHERICA) - call horiz_interp_spherical(Interp,data_in, data_out, verbose, mask_in, mask_out, & - missing_value ) - case default - call mpp_error(FATAL,'interp_method should be conservative, bilinear, bicubic, spherical') - end select - - return - - end subroutine horiz_interp_base_2d - -!####################################################################### - - !> Overload of interface horiz_interp_base_2d - !! uses 3d arrays for data and mask - !! this allows for multiple interpolations with one call - subroutine horiz_interp_base_3d ( Interp, data_in, data_out, verbose, mask_in, mask_out, & - missing_value, missing_permit, err_msg ) - !----------------------------------------------------------------------- - ! overload of interface horiz_interp_base_2d - ! uses 3d arrays for data and mask - ! this allows for multiple interpolations with one call - !----------------------------------------------------------------------- - type (horiz_interp_type), intent(in) :: Interp - real, intent(in), dimension(:,:,:) :: data_in - real, intent(out), dimension(:,:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:,:), optional :: mask_in - real, intent(out), dimension(:,:,:), optional :: mask_out - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - character(len=*), intent(out), optional :: err_msg - !----------------------------------------------------------------------- - integer :: n - - if(present(err_msg)) err_msg = '' - if(.not.Interp%I_am_initialized) then - if(fms_error_handler('horiz_interp','The horiz_interp_type variable is not initialized',err_msg)) return - endif - - do n = 1, size(data_in,3) - if (present(mask_in))then - if(present(mask_out)) then - call horiz_interp_base_2d ( Interp, data_in(:,:,n), data_out(:,:,n), & - verbose, mask_in(:,:,n), mask_out(:,:,n), & - missing_value, missing_permit ) - else - call horiz_interp_base_2d ( Interp, data_in(:,:,n), data_out(:,:,n), & - verbose, mask_in(:,:,n), missing_value = missing_value, & - missing_permit = missing_permit ) - endif - else - if(present(mask_out)) then - call horiz_interp_base_2d ( Interp, data_in(:,:,n), data_out(:,:,n), & - verbose, mask_out=mask_out(:,:,n), missing_value = missing_value, & - missing_permit = missing_permit ) - else - call horiz_interp_base_2d ( Interp, data_in(:,:,n), data_out(:,:,n), & - verbose, missing_value = missing_value, & - missing_permit = missing_permit ) - endif - endif - enddo - - return -!----------------------------------------------------------------------- - end subroutine horiz_interp_base_3d - -!####################################################################### - -!> Interpolates from a rectangular grid to rectangular grid. -!! interp_method can be the value conservative, bilinear or spherical. -!! horiz_interp_new don't need to be called before calling this routine. - subroutine horiz_interp_solo_1d ( data_in, lon_in, lat_in, lon_out, lat_out, & - data_out, verbose, mask_in, mask_out, & - interp_method, missing_value, missing_permit, & - num_nbrs, max_dist,src_modulo, grid_at_center ) -!----------------------------------------------------------------------- - real, intent(in), dimension(:,:) :: data_in - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:) :: lon_out, lat_out - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out - character(len=*), intent(in), optional :: interp_method - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - integer, intent(in), optional :: num_nbrs - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo - logical, intent(in), optional :: grid_at_center -!----------------------------------------------------------------------- - type (horiz_interp_type) :: Interp -!----------------------------------------------------------------------- - call horiz_interp_init - - call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, grid_at_center ) - - call horiz_interp ( Interp, data_in, data_out, verbose, & - mask_in, mask_out, missing_value, missing_permit ) - - call horiz_interp_del ( Interp ) -!----------------------------------------------------------------------- - - end subroutine horiz_interp_solo_1d - -!####################################################################### - -!> Interpolates from a uniformly spaced grid to any output grid. -!! interp_method can be the value "onservative","bilinear" or "spherical". -!! horiz_interp_new don't need to be called before calling this routine. - subroutine horiz_interp_solo_1d_src ( data_in, lon_in, lat_in, lon_out, lat_out, & - data_out, verbose, mask_in, mask_out, & - interp_method, missing_value, missing_permit, & - num_nbrs, max_dist, src_modulo, grid_at_center ) -!----------------------------------------------------------------------- - real, intent(in), dimension(:,:) :: data_in - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out - character(len=*), intent(in), optional :: interp_method - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - integer, intent(in), optional :: num_nbrs - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo - logical, intent(in), optional :: grid_at_center - -!----------------------------------------------------------------------- - type (horiz_interp_type) :: Interp - logical :: dst_is_latlon - character(len=128) :: method -!----------------------------------------------------------------------- - call horiz_interp_init - method = 'conservative' - if(present(interp_method)) method = interp_method - dst_is_latlon = .true. - if(trim(method) == 'conservative') dst_is_latlon = is_lat_lon(lon_out, lat_out) - - if(dst_is_latlon) then - call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, & - grid_at_center, is_latlon_out = dst_is_latlon ) - call horiz_interp ( Interp, data_in, data_out, verbose, & - mask_in, mask_out, missing_value, missing_permit ) - else - call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, & - grid_at_center, mask_in, mask_out, is_latlon_out = dst_is_latlon) - - call horiz_interp ( Interp, data_in, data_out, verbose, & - missing_value=missing_value, missing_permit=missing_permit ) - end if - - call horiz_interp_del ( Interp ) - -!----------------------------------------------------------------------- - - end subroutine horiz_interp_solo_1d_src - - -!####################################################################### - -!> Interpolates from any grid to any grid. interp_method should be "spherical" -!! horiz_interp_new don't need to be called before calling this routine. - subroutine horiz_interp_solo_2d ( data_in, lon_in, lat_in, lon_out, lat_out, data_out, & - verbose, mask_in, mask_out, interp_method, missing_value,& - missing_permit, num_nbrs, max_dist, src_modulo ) -!----------------------------------------------------------------------- - real, intent(in), dimension(:,:) :: data_in - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out - character(len=*), intent(in), optional :: interp_method - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - integer, intent(in), optional :: num_nbrs - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo -!----------------------------------------------------------------------- - type (horiz_interp_type) :: Interp - logical :: dst_is_latlon, src_is_latlon - character(len=128) :: method -!----------------------------------------------------------------------- - call horiz_interp_init - - method = 'conservative' - if(present(interp_method)) method = interp_method - dst_is_latlon = .true. - src_is_latlon = .true. - if(trim(method) == 'conservative') then - dst_is_latlon = is_lat_lon(lon_out, lat_out) - src_is_latlon = is_lat_lon(lon_in, lat_in) - end if - - if(dst_is_latlon .and. src_is_latlon) then - call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, & - is_latlon_in=dst_is_latlon, is_latlon_out = dst_is_latlon ) - call horiz_interp ( Interp, data_in, data_out, verbose, & - mask_in, mask_out, missing_value, missing_permit ) - else - call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, & - mask_in, mask_out, & - is_latlon_in=dst_is_latlon, is_latlon_out = dst_is_latlon) - call horiz_interp ( Interp, data_in, data_out, verbose, & - missing_value=missing_value, missing_permit=missing_permit ) - end if - - call horiz_interp_del ( Interp ) - -!----------------------------------------------------------------------- - - end subroutine horiz_interp_solo_2d - -!####################################################################### - -!> interpolates from any grid to rectangular longitude/latitude grid. -!! interp_method should be "spherical". -!! horiz_interp_new don't need to be called before calling this routine. - subroutine horiz_interp_solo_1d_dst ( data_in, lon_in, lat_in, lon_out, lat_out, data_out, & - verbose, mask_in, mask_out,interp_method,missing_value, & - missing_permit, num_nbrs, max_dist, src_modulo) -!----------------------------------------------------------------------- - real, intent(in), dimension(:,:) :: data_in - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:) :: lon_out, lat_out - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out - character(len=*), intent(in), optional :: interp_method - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - integer, intent(in), optional :: num_nbrs - real, intent(in), optional :: max_dist - logical, intent(in), optional :: src_modulo -!----------------------------------------------------------------------- - type (horiz_interp_type) :: Interp - logical :: src_is_latlon - character(len=128) :: method -!----------------------------------------------------------------------- - call horiz_interp_init - - method = 'conservative' - if(present(interp_method)) method = interp_method - src_is_latlon = .true. - if(trim(method) == 'conservative') src_is_latlon = is_lat_lon(lon_in, lat_in) - - if(src_is_latlon) then - call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, & - is_latlon_in = src_is_latlon ) - call horiz_interp ( Interp, data_in, data_out, verbose, & - mask_in, mask_out, missing_value, missing_permit ) - else - call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & - interp_method, num_nbrs, max_dist, src_modulo, & - mask_in, mask_out, is_latlon_in = src_is_latlon) - - call horiz_interp ( Interp, data_in, data_out, verbose, & - missing_value=missing_value, missing_permit=missing_permit ) - end if - - call horiz_interp_del ( Interp ) - -!----------------------------------------------------------------------- - - end subroutine horiz_interp_solo_1d_dst - -!####################################################################### - -!> Overloaded version of interface horiz_interp_solo_2 - subroutine horiz_interp_solo_old (data_in, wb, sb, dx, dy, & - lon_out, lat_out, data_out, & - verbose, mask_in, mask_out) - -!----------------------------------------------------------------------- - real, intent(in), dimension(:,:) :: data_in !< Global input data stored from west to east - !! (1st dimension), south to north (2nd dimension) - real, intent(in) :: wb !< Longitude (radians) that correspond to western-most - !! boundary of grid box j=1 in array data_in - real, intent(in) :: sb !< Latitude (radians) that correspond to western-most - !! boundary of grid box j=1 in array data_in - real, intent(in) :: dx !< Grid spacing (in radians) for the longitude axis - !! (first dimension) for the input data - real, intent(in) :: dy !< Grid spacing (in radians) for the latitude axis - !! (first dimension) for the input data - real, intent(in), dimension(:) :: lon_out !< The longitude edges (in radians) for output - !! data grid boxes. The values are for adjacent grid boxes - !! and must increase in value. If there are MLON grid boxes - !! there must be MLON+1 edge values - real, intent(in), dimension(:) :: lat_out !< The latitude edges (in radians) for output - !! data grid boxes. The values are for adjacent grid boxes - !! and may increase or decrease in value. If there are NLAT - !! grid boxes there must be NLAT+1 edge values - real, intent(out), dimension(:,:) :: data_out !< Output data on the output grid defined by grid box - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out -!----------------------------------------------------------------------- - real, dimension(size(data_in,1)+1) :: blon_in - real, dimension(size(data_in,2)+1) :: blat_in - integer :: i, j, nlon_in, nlat_in - real :: tpi -!----------------------------------------------------------------------- - call horiz_interp_init - - tpi = 2.*pi - nlon_in = size(data_in,1) - nlat_in = size(data_in,2) - - do i = 1, nlon_in+1 - blon_in(i) = wb + float(i-1)*dx - enddo - if (abs(blon_in(nlon_in+1)-blon_in(1)-tpi) < epsilon(blon_in)) & - blon_in(nlon_in+1)=blon_in(1)+tpi - - do j = 2, nlat_in - blat_in(j) = sb + float(j-1)*dy - enddo - blat_in(1) = -0.5*pi - blat_in(nlat_in+1) = 0.5*pi - - - call horiz_interp_solo_1d (data_in, blon_in, blat_in, & - lon_out, lat_out, data_out, & - verbose, mask_in, mask_out ) - -!----------------------------------------------------------------------- - - end subroutine horiz_interp_solo_old - -!####################################################################### - !> Deallocates memory used by "horiz_interp_type" variables. !! Must be called before reinitializing with horiz_interp_new. subroutine horiz_interp_del ( Interp ) @@ -1055,48 +310,8 @@ subroutine horiz_interp_end return end subroutine horiz_interp_end - !#################################################################### - function is_lat_lon(lon, lat) - real, dimension(:,:), intent(in) :: lon, lat - logical :: is_lat_lon - integer :: i, j, nlon, nlat, num - - is_lat_lon = .true. - nlon = size(lon,1) - nlat = size(lon,2) - LOOP_LAT: do j = 1, nlat - do i = 2, nlon - if(lat(i,j) .NE. lat(1,j)) then - is_lat_lon = .false. - exit LOOP_LAT - end if - end do - end do LOOP_LAT - - if(is_lat_lon) then - LOOP_LON: do i = 1, nlon - do j = 2, nlat - if(lon(i,j) .NE. lon(i,1)) then - is_lat_lon = .false. - exit LOOP_LON - end if - end do - end do LOOP_LON - end if - - num = 0 - if(is_lat_lon) num = 1 - call mpp_min(num) - if(num == 1) then - is_lat_lon = .true. - else - is_lat_lon = .false. - end if - - return - end function is_lat_lon - -!##################################################################### +#include "horiz_interp_r4.fh" +#include "horiz_interp_r8.fh" end module horiz_interp_mod !> @} diff --git a/horiz_interp/horiz_interp_bicubic.F90 b/horiz_interp/horiz_interp_bicubic.F90 index b57fad23ca..25ac5c1a54 100644 --- a/horiz_interp/horiz_interp_bicubic.F90 +++ b/horiz_interp/horiz_interp_bicubic.F90 @@ -43,13 +43,13 @@ !! The module is thought to interact with MOM-4. !! Alle benotigten Felder werden extern von MOM verwaltet, da sie !! nicht fur alle interpolierten Daten die gleiche Dimension haben mussen. - module horiz_interp_bicubic_mod use mpp_mod, only: mpp_error, FATAL, stdout, mpp_pe, mpp_root_pe use fms_mod, only: write_version_number use horiz_interp_type_mod, only: horiz_interp_type use constants_mod, only: PI + use platform_mod, only: r4_kind, r8_kind implicit none @@ -60,10 +60,20 @@ module horiz_interp_bicubic_mod public :: horiz_interp_bicubic_init !> Creates a new @ref horiz_interp_type for bicubic interpolation. + !! Allocates space and initializes a derived-type variable + !! that contains pre-computed interpolation indices and weights. !> @ingroup horiz_interp_bicubic_mod interface horiz_interp_bicubic_new - module procedure horiz_interp_bicubic_new_1d - module procedure horiz_interp_bicubic_new_1d_s + module procedure horiz_interp_bicubic_new_1d_r8 + module procedure horiz_interp_bicubic_new_1d_s_r8 + module procedure horiz_interp_bicubic_new_1d_r4 + module procedure horiz_interp_bicubic_new_1d_s_r4 + end interface + + !> @brief Perform bicubic horizontal interpolation + interface horiz_interp_bicubic + module procedure horiz_interp_bicubic_r4 + module procedure horiz_interp_bicubic_r8 end interface !> @addtogroup horiz_interp_bicubic_mod @@ -87,12 +97,36 @@ module horiz_interp_bicubic_mod ! dff_xy : x-y-derivative of fc at the fine grid - real :: tpi + real(r8_kind) :: tpi + + !! Private interfaces for mixed precision helper routines interface fill_xy - module procedure fill_xy + module procedure fill_xy_r4 + module procedure fill_xy_r8 + end interface + + interface bcuint + module procedure bcuint_r4 + module procedure bcuint_r8 + end interface + + interface bcucof + module procedure bcucof_r4 + module procedure bcucof_r8 end interface + !> find the lower neighbour of xf in field xc, return is the index + interface indl + module procedure indl_r4 + module procedure indl_r8 + end interface + + !> find the upper neighbour of xf in field xc, return is the index + interface indu + module procedure indu_r4 + module procedure indu_r8 + end interface contains @@ -102,650 +136,39 @@ subroutine horiz_interp_bicubic_init if(module_is_initialized) return call write_version_number("HORIZ_INTERP_BICUBIC_MOD", version) module_is_initialized = .true. - tpi = 2.0*PI + tpi = real(2.0_r8_kind*PI, R8_KIND) end subroutine horiz_interp_bicubic_init - !####################################################################### - - !> @brief Creates a new @ref horiz_interp_type - !! - !> Allocates space and initializes a derived-type variable - !! that contains pre-computed interpolation indices and weights. - subroutine horiz_interp_bicubic_new_1d_s ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo ) - - !----------------------------------------------------------------------- - type(horiz_interp_type), intent(inout) :: Interp !< A derived-type variable containing indices - !! and weights used for subsequent interpolations. To - !! reinitialize this variable for a different grid-to-grid - !! interpolation you must first use the - !! @ref horiz_interp_bicubic_del interface. - real, intent(in), dimension(:) :: lon_in !< Longitude (radians) for source data grid - real, intent(in), dimension(:) :: lat_in !< Latitude (radians) for source data grid - real, intent(in), dimension(:,:) :: lon_out !< Longitude (radians) for output data grid - real, intent(in), dimension(:,:) :: lat_out !< Latitude (radians) for output data grid - integer, intent(in), optional :: verbose !< flag for print output amount - logical, intent(in), optional :: src_modulo !< indicates if the boundary condition along - !! zonal boundary is cyclic or not. Zonal boundary condition - !!is cyclic when true - integer :: i, j, ip1, im1, jp1, jm1 - logical :: src_is_modulo - integer :: nlon_in, nlat_in, nlon_out, nlat_out - integer :: jcl, jcu, icl, icu, jj - real :: xz, yz - integer :: unit - - if(present(verbose)) verbose_bicubic = verbose - src_is_modulo = .false. - if (present(src_modulo)) src_is_modulo = src_modulo - - if(size(lon_out,1) /= size(lat_out,1) .or. size(lon_out,2) /= size(lat_out,2) ) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear ' // & - 'interplation, the output grids should be geographical grids') - - !--- get the grid size - nlon_in = size(lon_in) ; nlat_in = size(lat_in) - nlon_out = size(lon_out,1); nlat_out = size(lat_out,2) - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out -! use wti(:,:,1) for x-derivative, wti(:,:,2) for y-derivative, wti(:,:,3) for xy-derivative - allocate ( Interp%wti (nlon_in, nlat_in, 3) ) - allocate ( Interp%lon_in (nlon_in) ) - allocate ( Interp%lat_in (nlat_in) ) - allocate ( Interp%rat_x (nlon_out, nlat_out) ) - allocate ( Interp%rat_y (nlon_out, nlat_out) ) - allocate ( Interp%i_lon (nlon_out, nlat_out, 2) ) - allocate ( Interp%j_lat (nlon_out, nlat_out, 2) ) - - Interp%lon_in = lon_in - Interp%lat_in = lat_in - - if ( verbose_bicubic > 0 ) then - unit = stdout() - write (unit,'(/,"Initialising bicubic interpolation, interface horiz_interp_bicubic_new_1d_s")') - write (unit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src - write (unit,'(1x,10f10.4)') (Interp%lon_in(jj),jj=1,Interp%nlon_src) - write (unit,'(/," Latitude of coarse grid points (radian): yc(j) j=1, ",i4)') Interp%nlat_src - write (unit,'(1x,10f10.4)') (Interp%lat_in(jj),jj=1,Interp%nlat_src) - do i=1, Interp%nlat_dst - write (unit,*) - write (unit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst - write (unit,'(1x,10f10.4)') (lon_out(jj,i),jj=1,Interp%nlon_dst) - enddo - do i=1, Interp%nlon_dst - write (unit,*) - write (unit,'(/," Latitude of fine grid points (radian): yf(j) j=1, ",i4)') Interp%nlon_dst - write (unit,'(1x,10f10.4)') (lat_out(i,jj),jj=1,Interp%nlat_dst) - enddo - endif - - -!--------------------------------------------------------------------------- -! Find the x-derivative. Use central differences and forward or -! backward steps at the boundaries - - do j=1,nlat_in - do i=1,nlon_in - ip1=min(i+1,nlon_in) - im1=max(i-1,1) - Interp%wti(i,j,1) = 1./(Interp%lon_in(ip1)-Interp%lon_in(im1)) - enddo - enddo - - -!--------------------------------------------------------------------------- - -! Find the y-derivative. Use central differences and forward or -! backward steps at the boundaries - do j=1,nlat_in - jp1=min(j+1,nlat_in) - jm1=max(j-1,1) - do i=1,nlon_in - Interp%wti(i,j,2) = 1./(Interp%lat_in(jp1)-Interp%lat_in(jm1)) - enddo - enddo - -!--------------------------------------------------------------------------- - -! Find the xy-derivative. Use central differences and forward or -! backward steps at the boundaries - do j=1,nlat_in - jp1=min(j+1,nlat_in) - jm1=max(j-1,1) - do i=1,nlon_in - ip1=min(i+1,nlon_in) - im1=max(i-1,1) - Interp%wti(i,j,3) = 1./((Interp%lon_in(ip1)-Interp%lon_in(im1))*(Interp%lat_in(jp1)-Interp%lat_in(jm1))) - enddo - enddo -!--------------------------------------------------------------------------- -! Now for each point at the dest-grid find the boundary points of -! the source grid - do j=1, nlat_out - do i=1,nlon_out - yz = lat_out(i,j) - xz = lon_out(i,j) - - jcl = 0 - jcu = 0 - if( yz .le. Interp%lat_in(1) ) then - jcl = 1 - jcu = 1 - else if( yz .ge. Interp%lat_in(nlat_in) ) then - jcl = nlat_in - jcu = nlat_in - else - jcl = indl(Interp%lat_in, yz) - jcu = indu(Interp%lat_in, yz) - endif - - icl = 0 - icu = 0 - !--- cyclic condition, do we need to use do while - if( xz .gt. Interp%lon_in(nlon_in) ) xz = xz - tpi - if( xz .le. Interp%lon_in(1) ) xz = xz + tpi - if( xz .ge. Interp%lon_in(nlon_in) ) then - icl = nlon_in - icu = 1 - Interp%rat_x(i,j) = (xz - Interp%lon_in(icl))/(Interp%lon_in(icu) - Interp%lon_in(icl) + tpi) - else - icl = indl(Interp%lon_in, xz) - icu = indu(Interp%lon_in, xz) - Interp%rat_x(i,j) = (xz - Interp%lon_in(icl))/(Interp%lon_in(icu) - Interp%lon_in(icl)) - endif - Interp%j_lat(i,j,1) = jcl - Interp%j_lat(i,j,2) = jcu - Interp%i_lon(i,j,1) = icl - Interp%i_lon(i,j,2) = icu - if(jcl == jcu) then - Interp%rat_y(i,j) = 0.0 - else - Interp%rat_y(i,j) = (yz - Interp%lat_in(jcl))/(Interp%lat_in(jcu) - Interp%lat_in(jcl)) - endif -! if(yz.gt.Interp%lat_in(jcu)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d_s: -! yf < ycl, no valid boundary point') -! if(yz.lt.Interp%lat_in(jcl)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d_s: -! yf > ycu, no valid boundary point') -! if(xz.gt.Interp%lon_in(icu)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d_s: -! xf < xcl, no valid boundary point') -! if(xz.lt.Interp%lon_in(icl)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d_s: -! xf > xcu, no valid boundary point') - enddo - enddo - end subroutine horiz_interp_bicubic_new_1d_s - - !> @brief Creates a new @ref horiz_interp_type - !! - !> Allocates space and initializes a derived-type variable - !! that contains pre-computed interpolation indices and weights. - subroutine horiz_interp_bicubic_new_1d ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo ) - - !----------------------------------------------------------------------- + !> Free memory from a horiz_interp_type used for bicubic interpolation + !! (allocated via @ref horiz_bicubic_new) + subroutine horiz_interp_bicubic_del( Interp ) type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:) :: lon_out, lat_out - integer, intent(in), optional :: verbose - logical, intent(in), optional :: src_modulo - integer :: i, j, ip1, im1, jp1, jm1 - logical :: src_is_modulo - integer :: nlon_in, nlat_in, nlon_out, nlat_out - integer :: jcl, jcu, icl, icu, jj - real :: xz, yz - integer :: unit - if(present(verbose)) verbose_bicubic = verbose - src_is_modulo = .false. - if (present(src_modulo)) src_is_modulo = src_modulo - - !--- get the grid size - nlon_in = size(lon_in) ; nlat_in = size(lat_in) - nlon_out = size(lon_out); nlat_out = size(lat_out) - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out - allocate ( Interp%wti (nlon_in, nlat_in, 3) ) - allocate ( Interp%lon_in (nlon_in) ) - allocate ( Interp%lat_in (nlat_in) ) - allocate ( Interp%rat_x (nlon_out, nlat_out) ) - allocate ( Interp%rat_y (nlon_out, nlat_out) ) - allocate ( Interp%i_lon (nlon_out, nlat_out, 2) ) - allocate ( Interp%j_lat (nlon_out, nlat_out, 2) ) - - Interp%lon_in = lon_in - Interp%lat_in = lat_in - - if ( verbose_bicubic > 0 ) then - unit = stdout() - write (unit,'(/,"Initialising bicubic interpolation, interface horiz_interp_bicubic_new_1d")') - write (unit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src - write (unit,'(1x,10f10.4)') (Interp%lon_in(jj),jj=1,Interp%nlon_src) - write (unit,'(/," Latitude of coarse grid points (radian): yc(j) j=1, ",i4)') Interp%nlat_src - write (unit,'(1x,10f10.4)') (Interp%lat_in(jj),jj=1,Interp%nlat_src) - write (unit,*) - write (unit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst - write (unit,'(1x,10f10.4)') (lon_out(jj),jj=1,Interp%nlon_dst) - write (unit,'(/," Latitude of fine grid points (radian): yf(j) j=1, ",i4)') Interp%nlon_dst - write (unit,'(1x,10f10.4)') (lat_out(jj),jj=1,Interp%nlat_dst) + if(Interp%horizInterpReals8_type%is_allocated) then + if(allocated(Interp%horizInterpReals8_type%rat_x)) deallocate ( Interp%horizInterpReals8_type%rat_x ) + if(allocated(Interp%horizInterpReals8_type%rat_y)) deallocate ( Interp%horizInterpReals8_type%rat_y ) + if(allocated(Interp%horizInterpReals8_type%lon_in)) deallocate ( Interp%horizInterpReals8_type%lon_in ) + if(allocated(Interp%horizInterpReals8_type%lat_in)) deallocate ( Interp%horizInterpReals8_type%lat_in ) + if(allocated(Interp%horizInterpReals8_type%wti)) deallocate ( Interp%horizInterpReals8_type%wti ) + else if(Interp%horizInterpReals4_type%is_allocated) then + if(allocated(Interp%horizInterpReals4_type%rat_x)) deallocate ( Interp%horizInterpReals4_type%rat_x ) + if(allocated(Interp%horizInterpReals4_type%rat_y)) deallocate ( Interp%horizInterpReals4_type%rat_y ) + if(allocated(Interp%horizInterpReals4_type%lon_in)) deallocate ( Interp%horizInterpReals4_type%lon_in ) + if(allocated(Interp%horizInterpReals4_type%lat_in)) deallocate ( Interp%horizInterpReals4_type%lat_in ) + if(allocated(Interp%horizInterpReals4_type%wti)) deallocate ( Interp%horizInterpReals4_type%wti ) endif + if( allocated(Interp%i_lon) ) deallocate( Interp%i_lon ) + if( allocated(Interp%j_lat) ) deallocate( Interp%j_lat ) - -!--------------------------------------------------------------------------- -! Find the x-derivative. Use central differences and forward or -! backward steps at the boundaries - - do j=1,nlat_in - do i=1,nlon_in - ip1=min(i+1,nlon_in) - im1=max(i-1,1) - Interp%wti(i,j,1) = 1./(lon_in(ip1)-lon_in(im1)) - enddo - enddo - - -!--------------------------------------------------------------------------- - -! Find the y-derivative. Use central differences and forward or -! backward steps at the boundaries - do j=1,nlat_in - jp1=min(j+1,nlat_in) - jm1=max(j-1,1) - do i=1,nlon_in - Interp%wti(i,j,2) = 1./(lat_in(jp1)-lat_in(jm1)) - enddo - enddo - -!--------------------------------------------------------------------------- - -! Find the xy-derivative. Use central differences and forward or -! backward steps at the boundaries - do j=1,nlat_in - jp1=min(j+1,nlat_in) - jm1=max(j-1,1) - do i=1,nlon_in - ip1=min(i+1,nlon_in) - im1=max(i-1,1) - Interp%wti(i,j,3) = 1./((lon_in(ip1)-lon_in(im1))*(lat_in(jp1)-lat_in(jm1))) - enddo - enddo -!--------------------------------------------------------------------------- -! Now for each point at the dest-grid find the boundary points of -! the source grid - do j=1, nlat_out - yz = lat_out(j) - jcl = 0 - jcu = 0 - if( yz .le. lat_in(1) ) then - jcl = 1 - jcu = 1 - else if( yz .ge. lat_in(nlat_in) ) then - jcl = nlat_in - jcu = nlat_in - else - jcl = indl(lat_in, yz) - jcu = indu(lat_in, yz) - endif - do i=1,nlon_out - xz = lon_out(i) - icl = 0 - icu = 0 - !--- cyclic condition, do we need to use do while - if( xz .gt. lon_in(nlon_in) ) xz = xz - tpi - if( xz .le. lon_in(1) ) xz = xz + tpi - if( xz .ge. lon_in(nlon_in) ) then - icl = nlon_in - icu = 1 - Interp%rat_x(i,j) = (xz - Interp%lon_in(icl))/(Interp%lon_in(icu) - Interp%lon_in(icl) + tpi) - else - icl = indl(lon_in, xz) - icu = indu(lon_in, xz) - Interp%rat_x(i,j) = (xz - Interp%lon_in(icl))/(Interp%lon_in(icu) - Interp%lon_in(icl)) - endif - icl = indl(lon_in, xz) - icu = indu(lon_in, xz) - Interp%j_lat(i,j,1) = jcl - Interp%j_lat(i,j,2) = jcu - Interp%i_lon(i,j,1) = icl - Interp%i_lon(i,j,2) = icu - if(jcl == jcu) then - Interp%rat_y(i,j) = 0.0 - else - Interp%rat_y(i,j) = (yz - Interp%lat_in(jcl))/(Interp%lat_in(jcu) - Interp%lat_in(jcl)) - endif -! if(yz.gt.lat_in(jcu)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d: yf < -! ycl, no valid boundary point') -! if(yz.lt.lat_in(jcl)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d: yf > -! ycu, no valid boundary point') -! if(xz.gt.lon_in(icu)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d: xf < -! xcl, no valid boundary point') -! if(xz.lt.lon_in(icl)) call mpp_error(FATAL, ' horiz_interp_bicubic_new_1d: xf > -! xcu, no valid boundary point') - enddo - enddo - - end subroutine horiz_interp_bicubic_new_1d - - !> @brief Perform bicubic horizontal interpolation - subroutine horiz_interp_bicubic( Interp, data_in, data_out, verbose, mask_in, mask_out, missing_value, & - & missing_permit) - type (horiz_interp_type), intent(in) :: Interp - real, intent(in), dimension(:,:) :: data_in - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - real :: yz, ycu, ycl - real :: xz, xcu, xcl - real :: val, val1, val2 - real, dimension(4) :: y, y1, y2, y12 - integer :: icl, icu, jcl, jcu - integer :: iclp1, icup1, jclp1, jcup1 - integer :: iclm1, icum1, jclm1, jcum1 - integer :: i,j - - if ( present(verbose) ) verbose_bicubic = verbose -! fill_in = .false. -! if ( present(fill) ) fill_in = fill -! use dfc_x and dfc_y as workspace -! if ( fill_in ) call fill_xy(fc(ics:ice,jcs:jce), ics, ice, jcs, jce, maxpass=2) -! where ( data_in .le. missing ) data_in(:,:) = 0. -!! - do j=1, Interp%nlat_dst - do i=1, Interp%nlon_dst - yz = Interp%rat_y(i,j) - xz = Interp%rat_x(i,j) - jcl = Interp%j_lat(i,j,1) - jcu = Interp%j_lat(i,j,2) - icl = Interp%i_lon(i,j,1) - icu = Interp%i_lon(i,j,2) - if( icl > icu ) then - iclp1 = icu - icum1 = icl - xcl = Interp%lon_in(icl) - xcu = Interp%lon_in(icu)+tpi - else - iclp1 = min(icl+1,Interp%nlon_src) - icum1 = max(icu-1,1) - xcl = Interp%lon_in(icl) - xcu = Interp%lon_in(icu) - endif - iclm1 = max(icl-1,1) - icup1 = min(icu+1,Interp%nlon_src) - jclp1 = min(jcl+1,Interp%nlat_src) - jclm1 = max(jcl-1,1) - jcup1 = min(jcu+1,Interp%nlat_src) - jcum1 = max(jcu-1,1) - ycl = Interp%lat_in(jcl) - ycu = Interp%lat_in(jcu) -! xcl = Interp%lon_in(icl) -! xcu = Interp%lon_in(icu) - y(1) = data_in(icl,jcl) - y(2) = data_in(icu,jcl) - y(3) = data_in(icu,jcu) - y(4) = data_in(icl,jcu) - y1(1) = ( data_in(iclp1,jcl) - data_in(iclm1,jcl) ) * Interp%wti(icl,jcl,1) - y1(2) = ( data_in(icup1,jcl) - data_in(icum1,jcl) ) * Interp%wti(icu,jcl,1) - y1(3) = ( data_in(icup1,jcu) - data_in(icum1,jcu) ) * Interp%wti(icu,jcu,1) - y1(4) = ( data_in(iclp1,jcu) - data_in(iclm1,jcu) ) * Interp%wti(icl,jcu,1) - y2(1) = ( data_in(icl,jclp1) - data_in(icl,jclm1) ) * Interp%wti(icl,jcl,2) - y2(2) = ( data_in(icu,jclp1) - data_in(icu,jclm1) ) * Interp%wti(icu,jcl,2) - y2(3) = ( data_in(icu,jcup1) - data_in(icu,jcum1) ) * Interp%wti(icu,jcu,2) - y2(4) = ( data_in(icl,jcup1) - data_in(icl,jcum1) ) * Interp%wti(icl,jcu,2) - y12(1)= ( data_in(iclp1,jclp1) + data_in(iclm1,jclm1) - data_in(iclm1,jclp1) & - - data_in(iclp1,jclm1) ) * Interp%wti(icl,jcl,3) - y12(2)= ( data_in(icup1,jclp1) + data_in(icum1,jclm1) - data_in(icum1,jclp1) & - - data_in(icup1,jclm1) ) * Interp%wti(icu,jcl,3) - y12(3)= ( data_in(icup1,jcup1) + data_in(icum1,jcum1) - data_in(icum1,jcup1) & - - data_in(icup1,jcum1) ) * Interp%wti(icu,jcu,3) - y12(4)= ( data_in(iclp1,jcup1) + data_in(iclm1,jcum1) - data_in(iclm1,jcup1) & - - data_in(iclp1,jcum1) ) * Interp%wti(icl,jcu,3) - - call bcuint(y,y1,y2,y12,xcl,xcu,ycl,ycu,xz,yz,val,val1,val2) - data_out (i,j) = val - if(present(mask_out)) mask_out(i,j) = 1. -!! dff_x(i,j) = val1 -!! dff_y(i,j) = val2 - enddo - enddo - return - end subroutine horiz_interp_bicubic - - -!--------------------------------------------------------------------------- - - subroutine bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,t,u,ansy,ansy1,ansy2) - real ansy,ansy1,ansy2,x1l,x1u,x2l,x2u,y(4),y1(4),y12(4),y2(4) -! uses bcucof - integer i - real t,u,c(4,4) - call bcucof(y,y1,y2,y12,x1u-x1l,x2u-x2l,c) - ansy=0. - ansy2=0. - ansy1=0. - do i=4,1,-1 - ansy=t*ansy+((c(i,4)*u+c(i,3))*u+c(i,2))*u+c(i,1) -! ansy2=t*ansy2+(3.*c(i,4)*u+2.*c(i,3))*u+c(i,2) -! ansy1=u*ansy1+(3.*c(4,i)*t+2.*c(3,i))*t+c(2,i) - enddo -! ansy1=ansy1/(x1u-x1l) ! could be used for accuracy checks -! ansy2=ansy2/(x2u-x2l) ! could be used for accuracy checks - return -! (c) copr. 1986-92 numerical recipes software -3#(-)f. - end subroutine bcuint -!--------------------------------------------------------------------------- - - subroutine bcucof(y,y1,y2,y12,d1,d2,c) - real d1,d2,c(4,4),y(4),y1(4),y12(4),y2(4) - integer i,j,k,l - real d1d2,xx,cl(16),wt(16,16),x(16) - save wt - data wt/1., 0., -3., 2., 4*0., -3., 0., 9., -6., 2., 0., -6., 4., 8*0., & - 3., 0., -9., 6., -2., 0., 6., -4., 10*0., 9., -6., 2*0., -6., & - 4., 2*0., 3., -2., 6*0., -9., 6., 2*0., 6., -4., 4*0., 1., 0., & - -3., 2., -2., 0., 6., -4., 1., 0., -3., 2., 8*0., -1., 0., 3., & - -2., 1., 0., -3., 2., 10*0., -3., 2., 2*0., 3., -2., 6*0., 3., & - -2., 2*0., -6., 4., 2*0., 3., -2., 0., 1., -2., 1., 5*0., -3., & - 6., -3., 0., 2., -4., 2., 9*0., 3., -6., 3., 0., -2., 4., -2., & - 10*0., -3., 3., 2*0., 2., -2., 2*0., -1., 1., 6*0., 3., -3., & - 2*0., -2., 2., 5*0., 1., -2., 1., 0., -2., 4., -2., 0., 1., -2., & - 1., 9*0., -1., 2., -1., 0., 1., -2., 1., 10*0., 1., -1., 2*0., & - -1., 1., 6*0., -1., 1., 2*0., 2., -2., 2*0., -1., 1./ - - d1d2=d1*d2 - do i=1,4 - x(i)=y(i) - x(i+4)=y1(i)*d1 - x(i+8)=y2(i)*d2 - x(i+12)=y12(i)*d1d2 - enddo - do i=1,16 - xx=0. - do k=1,16 - xx=xx+wt(i,k)*x(k) - enddo - cl(i)=xx - enddo - l=0 - do i=1,4 - do j=1,4 - l=l+1 - c(i,j)=cl(l) - enddo - enddo - return -! (c) copr. 1986-92 numerical recipes software -3#(-)f. - end subroutine bcucof - -!----------------------------------------------------------------------- - -!> find the lower neighbour of xf in field xc, return is the index - function indl(xc, xf) - real, intent(in) :: xc(1:) - real, intent(in) :: xf - integer :: indl - integer :: ii - indl = 1 - do ii=1, size(xc) - if(xc(ii).gt.xf) return - indl = ii - enddo - call mpp_error(FATAL,'Error in indl') - return - end function indl - -!----------------------------------------------------------------------- - -!> find the upper neighbour of xf in field xc, return is the index - function indu(xc, xf) - real, intent(in) :: xc(1:) - real, intent(in) :: xf - integer :: indu - integer :: ii - do ii=1, size(xc) - indu = ii - if(xc(ii).gt.xf) return - enddo - call mpp_error(FATAL,'Error in indu') - return - end function indu - -!----------------------------------------------------------------------- - - subroutine fill_xy(fi, ics, ice, jcs, jce, mask, maxpass) - integer, intent(in) :: ics,ice,jcs,jce - real, intent(inout) :: fi(ics:ice,jcs:jce) - real, intent(in), optional :: mask(ics:ice,jcs:jce) - integer, intent(in) :: maxpass - real :: work_old(ics:ice,jcs:jce) - real :: work_new(ics:ice,jcs:jce) - logical :: ready - real :: blank = -1.e30 - real :: tavr - integer :: ipass = 0 - integer :: inl, inr, jnl, jnu, i, j, is, js, iavr - - - ready = .false. - - work_new(:,:) = fi(:,:) - work_old(:,:) = work_new(:,:) - ipass = 0 - if ( present(mask) ) then - do while (.not.ready) - ipass = ipass+1 - ready = .true. - do j=jcs, jce - do i=ics, ice - if (work_old(i,j).le.blank) then - tavr=0. - iavr=0 - inl = max(i-1,ics) - inr = min(i+1,ice) - jnl = max(j-1,jcs) - jnu = min(j+1,jce) - do js=jnl,jnu - do is=inl,inr - if (work_old(is,js) .ne. blank .and. mask(is,js).ne.0.) then - tavr = tavr + work_old(is,js) - iavr = iavr+1 - endif - enddo - enddo - if (iavr.gt.0) then - if (iavr.eq.1) then -! spreading is not allowed if the only valid neighbor is a corner point -! otherwise an ill posed cellular automaton is established leading to -! a spreading of constant values in diagonal direction -! if all corner points are blanked the valid neighbor must be a direct one -! and spreading is allowed - if (work_old(inl,jnu).eq.blank.and.& - work_old(inr,jnu).eq.blank.and.& - work_old(inr,jnl).eq.blank.and.& - work_old(inl,jnl).eq.blank) then - work_new(i,j)=tavr/iavr - ready = .false. - endif - else - work_new(i,j)=tavr/iavr - ready = .false. - endif - endif - endif - enddo ! j - enddo ! i -! save changes made during this pass to work_old - work_old(:,:)=work_new(:,:) - if(ipass.eq.maxpass) ready=.true. - enddo !while (.not.ready) - fi(:,:) = work_new(:,:) - else - do while (.not.ready) - ipass = ipass+1 - ready = .true. - do j=jcs, jce - do i=ics, ice - if (work_old(i,j).le.blank) then - tavr=0. - iavr=0 - inl = max(i-1,ics) - inr = min(i+1,ice) - jnl = max(j-1,jcs) - jnu = min(j+1,jce) - do is=inl,inr - do js=jnl,jnu - if (work_old(is,js).gt.blank) then - tavr = tavr + work_old(is,js) - iavr = iavr+1 - endif - enddo - enddo - if (iavr.gt.0) then - if (iavr.eq.1) then -! spreading is not allowed if the only valid neighbor is a corner point -! otherwise an ill posed cellular automaton is established leading to -! a spreading of constant values in diagonal direction -! if all corner points are blanked the valid neighbor must be a direct one -! and spreading is allowed - if (work_old(inl,jnu).le.blank.and. & - work_old(inr,jnu).le.blank.and. & - work_old(inr,jnl).le.blank.and. & - work_old(inl,jnl).le.blank) then - work_new(i,j)=tavr/iavr - ready = .false. - endif - else - work_new(i,j)=tavr/iavr - ready = .false. - endif - endif - endif - enddo ! j - enddo ! i -! save changes made during this pass to work_old - work_old(:,:)=work_new(:,:) - if(ipass.eq.maxpass) ready=.true. - enddo !while (.not.ready) - fi(:,:) = work_new(:,:) - endif - return - end subroutine fill_xy - - subroutine horiz_interp_bicubic_del( Interp ) - - type (horiz_interp_type), intent(inout) :: Interp - - if(allocated(Interp%rat_x)) deallocate ( Interp%rat_x ) - if(allocated(Interp%rat_y)) deallocate ( Interp%rat_y ) - if(allocated(Interp%lon_in)) deallocate ( Interp%lon_in ) - if(allocated(Interp%lat_in)) deallocate ( Interp%lat_in ) - if(allocated(Interp%i_lon)) deallocate ( Interp%i_lon ) - if(allocated(Interp%j_lat)) deallocate ( Interp%j_lat ) - if(allocated(Interp%wti)) deallocate ( Interp%wti ) + Interp%horizInterpReals8_type%is_allocated = .false. + Interp%horizInterpReals4_type%is_allocated = .false. end subroutine horiz_interp_bicubic_del +#include "horiz_interp_bicubic_r4.fh" +#include "horiz_interp_bicubic_r8.fh" + end module horiz_interp_bicubic_mod !> @} ! close documentation diff --git a/horiz_interp/horiz_interp_bilinear.F90 b/horiz_interp/horiz_interp_bilinear.F90 index 126b46087c..64abf15263 100644 --- a/horiz_interp/horiz_interp_bilinear.F90 +++ b/horiz_interp/horiz_interp_bilinear.F90 @@ -33,6 +33,7 @@ module horiz_interp_bilinear_mod use fms_mod, only: write_version_number use constants_mod, only: PI use horiz_interp_type_mod, only: horiz_interp_type, stats + use platform_mod, only: r4_kind, r8_kind implicit none private @@ -44,16 +45,35 @@ module horiz_interp_bilinear_mod !> Creates a @ref horiz_interp_type for bilinear interpolation. !> @ingroup horiz_interp_bilinear_mod interface horiz_interp_bilinear_new - module procedure horiz_interp_bilinear_new_1d - module procedure horiz_interp_bilinear_new_2d + module procedure horiz_interp_bilinear_new_1d_r4 + module procedure horiz_interp_bilinear_new_1d_r8 + module procedure horiz_interp_bilinear_new_2d_r4 + module procedure horiz_interp_bilinear_new_2d_r8 + end interface + + interface horiz_interp_bilinear + module procedure horiz_interp_bilinear_r4 + module procedure horiz_interp_bilinear_r8 end interface !> @addtogroup horiz_interp_bilinear_mod !> @{ - real, parameter :: epsln=1.e-10 + real(r8_kind), parameter :: epsln=1.e-10_r8_kind integer, parameter :: DUMMY = -999 +!! Private helper routines, interfaces for mixed real precision support + + interface indp + module procedure indp_r4 + module procedure indp_r8 + end interface + + interface intersect + module procedure intersect_r4 + module procedure intersect_r8 + end interface + !----------------------------------------------------------------------- ! Include variable "version" to be written to log file. #include @@ -70,1166 +90,6 @@ subroutine horiz_interp_bilinear_init end subroutine horiz_interp_bilinear_init - - !######################################################################## - - subroutine horiz_interp_bilinear_new_1d ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo ) - - !----------------------------------------------------------------------- - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - integer, intent(in), optional :: verbose - logical, intent(in), optional :: src_modulo - - logical :: src_is_modulo - integer :: nlon_in, nlat_in, nlon_out, nlat_out, n, m - integer :: ie, is, je, js, ln_err, lt_err, warns, unit - real :: wtw, wte, wts, wtn, lon, lat, tpi, hpi - real :: glt_min, glt_max, gln_min, gln_max, min_lon, max_lon - - warns = 0 - if(present(verbose)) warns = verbose - src_is_modulo = .true. - if (present(src_modulo)) src_is_modulo = src_modulo - - hpi = 0.5*pi - tpi = 4.0*hpi - glt_min = hpi - glt_max = -hpi - gln_min = tpi - gln_max = -tpi - min_lon = 0.0 - max_lon = tpi - ln_err = 0 - lt_err = 0 - !----------------------------------------------------------------------- - - allocate ( Interp % wti (size(lon_out,1),size(lon_out,2),2), & - Interp % wtj (size(lon_out,1),size(lon_out,2),2), & - Interp % i_lon (size(lon_out,1),size(lon_out,2),2), & - Interp % j_lat (size(lon_out,1),size(lon_out,2),2)) - !----------------------------------------------------------------------- - - nlon_in = size(lon_in(:)) ; nlat_in = size(lat_in(:)) - nlon_out = size(lon_out, 1); nlat_out = size(lon_out, 2) - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out - - if(src_is_modulo) then - if(lon_in(nlon_in) - lon_in(1) .gt. tpi + epsln) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: '// & - 'The range of source grid longitude should be no larger than tpi') - - if(lon_in(1) .lt. 0.0 .OR. lon_in(nlon_in) > tpi ) then - min_lon = lon_in(1) - max_lon = lon_in(nlon_in) - endif - endif - - do n = 1, nlat_out - do m = 1, nlon_out - lon = lon_out(m,n) - lat = lat_out(m,n) - - if(src_is_modulo) then - if(lon .lt. min_lon) then - lon = lon + tpi - else if(lon .gt. max_lon) then - lon = lon - tpi - endif - else ! when the input grid is in not cyclic, the output grid should located inside - ! the input grid - if((lon .lt. lon_in(1)) .or. (lon .gt. lon_in(nlon_in))) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: ' //& - 'when input grid is not modulo, output grid should locate inside input grid') - endif - - glt_min = min(lat,glt_min); glt_max = max(lat,glt_max) - gln_min = min(lon,gln_min); gln_max = max(lon,gln_max) - - is = indp(lon, lon_in ) - if( lon_in(is) .gt. lon ) is = max(is-1,1) - if( lon_in(is) .eq. lon .and. is .eq. nlon_in) is = max(is - 1,1) - ie = min(is+1,nlon_in) - if(lon_in(is) .ne. lon_in(ie) .and. lon_in(is) .le. lon) then - wtw = ( lon_in(ie) - lon) / (lon_in(ie) - lon_in(is) ) - else - ! east or west of the last data value. this could be because a - ! cyclic condition is needed or the dataset is too small. - ln_err = 1 - ie = 1 - is = nlon_in - if (lon_in(ie) .ge. lon ) then - wtw = (lon_in(ie) -lon)/(lon_in(ie)-lon_in(is)+tpi+epsln) - else - wtw = (lon_in(ie) -lon+tpi+epsln)/(lon_in(ie)-lon_in(is)+tpi+epsln) - endif - endif - wte = 1. - wtw - - js = indp(lat, lat_in ) - - if( lat_in(js) .gt. lat ) js = max(js - 1, 1) - if( lat_in(js) .eq. lat .and. js .eq. nlat_in) js = max(js - 1, 1) - je = min(js + 1, nlat_in) - - if ( lat_in(js) .ne. lat_in(je) .and. lat_in(js) .le. lat) then - wts = ( lat_in(je) - lat )/(lat_in(je)-lat_in(js)) - else - ! north or south of the last data value. this could be because a - ! pole is not included in the data set or the dataset is too small. - ! in either case extrapolate north or south - lt_err = 1 - wts = 1. - endif - - wtn = 1. - wts - - Interp % i_lon (m,n,1) = is; Interp % i_lon (m,n,2) = ie - Interp % j_lat (m,n,1) = js; Interp % j_lat (m,n,2) = je - Interp % wti (m,n,1) = wtw - Interp % wti (m,n,2) = wte - Interp % wtj (m,n,1) = wts - Interp % wtj (m,n,2) = wtn - - enddo - enddo - - unit = stdout() - - if (ln_err .eq. 1 .and. warns > 0) then - write (unit,'(/,(1x,a))') & - '==> Warning: the geographic data set does not extend far ', & - ' enough east or west - a cyclic boundary ', & - ' condition was applied. check if appropriate ' - write (unit,'(/,(1x,a,2f8.4))') & - ' data required between longitudes:', gln_min, gln_max, & - ' data set is between longitudes:', lon_in(1), lon_in(nlon_in) - warns = warns - 1 - endif - - if (lt_err .eq. 1 .and. warns > 0) then - write (unit,'(/,(1x,a))') & - '==> Warning: the geographic data set does not extend far ',& - ' enough north or south - extrapolation from ',& - ' the nearest data was applied. this may create ',& - ' artificial gradients near a geographic pole ' - write (unit,'(/,(1x,a,2f8.4))') & - ' data required between latitudes:', glt_min, glt_max, & - ' data set is between latitudes:', lat_in(1), lat_in(nlat_in) - endif - - return - - end subroutine horiz_interp_bilinear_new_1d - - !####################################################################### - - !> Initialization routine. - !! - !> Allocates space and initializes a derived-type variable - !! that contains pre-computed interpolation indices and weights. - subroutine horiz_interp_bilinear_new_2d ( Interp, lon_in, lat_in, lon_out, lat_out, & - verbose, src_modulo, new_search, no_crash_when_not_found ) - - !----------------------------------------------------------------------- - type(horiz_interp_type), intent(inout) :: Interp !< A derived type variable containing indices - !! and weights for subsequent interpolations. To - !! reinitialize for different grid-to-grid interpolation - !! @ref horiz_interp_del must be used first. - real, intent(in), dimension(:,:) :: lon_in !< Latitude (radians) for source data grid - real, intent(in), dimension(:,:) :: lat_in !< Longitude (radians) for source data grid - real, intent(in), dimension(:,:) :: lon_out !< Longitude (radians) for output data grid - real, intent(in), dimension(:,:) :: lat_out !< Latitude (radians) for output data grid - integer, intent(in), optional :: verbose !< flag for amount of print output - logical, intent(in), optional :: src_modulo !< indicates if the boundary condition - !! along zonal boundary is cyclic or not. Cyclic when true - logical, intent(in), optional :: new_search - logical, intent(in), optional :: no_crash_when_not_found - integer :: warns - logical :: src_is_modulo - integer :: nlon_in, nlat_in, nlon_out, nlat_out - integer :: m, n, is, ie, js, je, num_solution - real :: lon, lat, quadra, x, y, y1, y2 - real :: a1, b1, c1, d1, a2, b2, c2, d2, a, b, c - real :: lon1, lat1, lon2, lat2, lon3, lat3, lon4, lat4 - real :: tpi, lon_min, lon_max - real :: epsln2 - logical :: use_new_search, no_crash - - tpi = 2.0*pi - - warns = 0 - if(present(verbose)) warns = verbose - src_is_modulo = .true. - if (present(src_modulo)) src_is_modulo = src_modulo - use_new_search = .false. - if (present(new_search)) use_new_search = new_search - no_crash = .false. - if(present(no_crash_when_not_found)) no_crash = no_crash_when_not_found - - ! make sure lon and lat has the same dimension - if(size(lon_out,1) /= size(lat_out,1) .or. size(lon_out,2) /= size(lat_out,2) ) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear ' // & - 'interplation, the output grids should be geographical grids') - - if(size(lon_in,1) /= size(lat_in,1) .or. size(lon_in,2) /= size(lat_in,2) ) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear '// & - 'interplation, the input grids should be geographical grids') - - !--- get the grid size - nlon_in = size(lon_in,1) ; nlat_in = size(lat_in,2) - nlon_out = size(lon_out,1); nlat_out = size(lon_out,2) - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out - - allocate ( Interp % wti (size(lon_out,1),size(lon_out,2),2), & - Interp % wtj (size(lon_out,1),size(lon_out,2),2), & - Interp % i_lon (size(lon_out,1),size(lon_out,2),2), & - Interp % j_lat (size(lon_out,1),size(lon_out,2),2)) - - !--- first fine the neighbor points for the destination points. - if(use_new_search) then - epsln2 = epsln*1e5 - call find_neighbor_new(Interp, lon_in, lat_in, lon_out, lat_out, src_is_modulo, no_crash) - else - epsln2 = epsln - call find_neighbor(Interp, lon_in, lat_in, lon_out, lat_out, src_is_modulo) - endif - - !*************************************************************************** - ! Algorithm explanation (from disscussion with Steve Garner ) * - ! * - ! lon(x,y) = a1*x + b1*y + c1*x*y + d1 (1) * - ! lat(x,y) = a2*x + b2*y + c2*x*y + d2 (2) * - ! f (x,y) = a3*x + b3*y + c3*x*y + d3 (3) * - ! with x and y is between 0 and 1. * - ! lon1 = lon(0,0) = d1, lat1 = lat(0,0) = d2 * - ! lon2 = lon(1,0) = a1+d1, lat2 = lat(1,0) = a2+d2 * - ! lon3 = lon(1,1) = a1+b1+c1+d1, lat3 = lat(1,1) = a2+b2+c2+d2 * - ! lon4 = lon(0,1) = b1+d1, lat4 = lat(0,1) = b2+d2 * - ! where (lon1,lat1),(lon2,lat2),(lon3,lat3),(lon4,lat4) represents * - ! the four corners starting from the left lower corner of grid box * - ! that encloses a destination grid ( the rotation direction is * - ! counterclockwise ). With these conditions, we get * - ! a1 = lon2-lon1, a2 = lat2-lat1 * - ! b1 = lon4-lon1, b2 = lat4-lat1 * - ! c1 = lon3-lon2-lon4+lon1, c2 = lat3-lat2-lat4+lat1 * - ! d1 = lon1 d2 = lat1 * - ! So given any point (lon,lat), from equation (1) and (2) we can * - ! solve (x,y). * - ! From equation (3) * - ! f1 = f(0,0) = d3, f2 = f(1,0) = a3+d3 * - ! f3 = f(1,1) = a3+b3+c3+d3, f4 = f(0,1) = b3+d3 * - ! we obtain * - ! a3 = f2-f1, b3 = f4-f1 * - ! c3 = f3-f2-f4+f1, d3 = f1 * - ! at point (lon,lat) ---> (x,y) * - ! f(x,y) = (f2-f1)x + (f4-f1)y + (f3-f2-f4+f1)xy + f1 * - ! = f1*(1-x)*(1-y) + f2*x*(1-y) + f3*x*y + f4*y*(1-x) * - ! wtw=1-x; wte=x; wts=1-y; xtn=y * - ! * - !*************************************************************************** - - lon_min = minval(lon_in); - lon_max = maxval(lon_in); - !--- calculate the weight - do n = 1, nlat_out - do m = 1, nlon_out - lon = lon_out(m,n) - lat = lat_out(m,n) - if(lon .lt. lon_min) then - lon = lon + tpi - else if(lon .gt. lon_max) then - lon = lon - tpi - endif - is = Interp%i_lon(m,n,1); ie = Interp%i_lon(m,n,2) - js = Interp%j_lat(m,n,1); je = Interp%j_lat(m,n,2) - if( is == DUMMY) cycle - lon1 = lon_in(is,js); lat1 = lat_in(is,js); - lon2 = lon_in(ie,js); lat2 = lat_in(ie,js); - lon3 = lon_in(ie,je); lat3 = lat_in(ie,je); - lon4 = lon_in(is,je); lat4 = lat_in(is,je); - if(lon .lt. lon_min) then - lon1 = lon1 -tpi; lon4 = lon4 - tpi - else if(lon .gt. lon_max) then - lon2 = lon2 +tpi; lon3 = lon3 + tpi - endif - a1 = lon2-lon1 - b1 = lon4-lon1 - c1 = lon1+lon3-lon4-lon2 - d1 = lon1 - a2 = lat2-lat1 - b2 = lat4-lat1 - c2 = lat1+lat3-lat4-lat2 - d2 = lat1 - !--- the coefficient of the quadratic equation - a = b2*c1-b1*c2 - b = a1*b2-a2*b1+c1*d2-c2*d1+c2*lon-c1*lat - c = a2*lon-a1*lat+a1*d2-a2*d1 - quadra = b*b-4.*a*c - if(abs(quadra) < epsln) quadra = 0.0 - if(quadra < 0.0) call mpp_error(FATAL, & - "horiz_interp_bilinear_mod: No solution existed for this quadratic equation") - if ( abs(a) .lt. epsln2) then ! a = 0 is a linear equation - if( abs(b) .lt. epsln) call mpp_error(FATAL, & - "horiz_interp_bilinear_mod: no unique solution existed for this linear equation") - y = -c/b - else - y1 = 0.5*(-b+sqrt(quadra))/a - y2 = 0.5*(-b-sqrt(quadra))/a - if(abs(y1) < epsln2) y1 = 0.0 - if(abs(y2) < epsln2) y2 = 0.0 - if(abs(1.0-y1) < epsln2) y1 = 1.0 - if(abs(1.0-y2) < epsln2) y2 = 1.0 - num_solution = 0 - if(y1 >= 0.0 .and. y1 <= 1.0) then - y = y1 - num_solution = num_solution +1 - endif - if(y2 >= 0.0 .and. y2 <= 1.0) then - y = y2 - num_solution = num_solution + 1 - endif - if(num_solution == 0) then - call mpp_error(FATAL, "horiz_interp_bilinear_mod: No solution found") - else if(num_solution == 2) then - call mpp_error(FATAL, "horiz_interp_bilinear_mod: Two solutions found") - endif - endif - if(abs(a1+c1*y) < epsln) call mpp_error(FATAL, & - "horiz_interp_bilinear_mod: the denomenator is 0") - if(abs(y) < epsln2) y = 0.0 - if(abs(1.0-y) < epsln2) y = 1.0 - x = (lon-b1*y-d1)/(a1+c1*y) - if(abs(x) < epsln2) x = 0.0 - if(abs(1.0-x) < epsln2) x = 1.0 - ! x and y should be between 0 and 1. - !! Added for ECDA - if(use_new_search) then - if (x < 0.0) x = 0.0 ! snz - if (y < 0.0) y = 0.0 ! snz - if (x > 1.0) x = 1.0 - if (y > 1.0) y = 1.0 - endif - if( x>1. .or. x<0. .or. y>1. .or. y < 0.) call mpp_error(FATAL, & - "horiz_interp_bilinear_mod: weight should be between 0 and 1") - Interp % wti(m,n,1)=1.0-x; Interp % wti(m,n,2)=x - Interp % wtj(m,n,1)=1.0-y; Interp % wtj(m,n,2)=y - enddo - enddo - - end subroutine horiz_interp_bilinear_new_2d - - !####################################################################### - !> this routine will search the source grid to fine the grid box that encloses - !! each destination grid. - subroutine find_neighbor( Interp, lon_in, lat_in, lon_out, lat_out, src_modulo ) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - logical, intent(in) :: src_modulo - integer :: nlon_in, nlat_in, nlon_out, nlat_out - integer :: max_step, n, m, l, i, j, ip1, jp1, step - integer :: is, js, jstart, jend, istart, iend, npts - integer, allocatable, dimension(:) :: ilon, jlat - real :: lon_min, lon_max, lon, lat, tpi - logical :: found - real :: lon1, lat1, lon2, lat2, lon3, lat3, lon4, lat4 - - tpi = 2.0*pi - nlon_in = size(lon_in,1) ; nlat_in = size(lat_in,2) - nlon_out = size(lon_out,1); nlat_out = size(lon_out,2) - - lon_min = minval(lon_in); - lon_max = maxval(lon_in); - - max_step = max(nlon_in,nlat_in) ! can be adjusted if needed - allocate(ilon(5*max_step), jlat(5*max_step) ) - - do n = 1, nlat_out - do m = 1, nlon_out - found = .false. - lon = lon_out(m,n) - lat = lat_out(m,n) - - if(src_modulo) then - if(lon .lt. lon_min) then - lon = lon + tpi - else if(lon .gt. lon_max) then - lon = lon - tpi - endif - else - if(lon .lt. lon_min .or. lon .gt. lon_max ) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: ' //& - 'when input grid is not modulo, output grid should locate inside input grid') - endif - !--- search for the surrounding four points locatioon. - if(m==1 .and. n==1) then - J_LOOP: do j = 1, nlat_in-1 - do i = 1, nlon_in - ip1 = i+1 - jp1 = j+1 - if(i==nlon_in) then - if(src_modulo)then - ip1 = 1 - else - cycle - endif - endif - lon1 = lon_in(i, j); lat1 = lat_in(i,j) - lon2 = lon_in(ip1,j); lat2 = lat_in(ip1,j) - lon3 = lon_in(ip1,jp1); lat3 = lat_in(ip1,jp1) - lon4 = lon_in(i, jp1); lat4 = lat_in(i, jp1) - - if(lon .lt. lon_min .or. lon .gt. lon_max) then - if(i .ne. nlon_in) then - cycle - else - if(lon .lt. lon_min) then - lon1 = lon1 -tpi; lon4 = lon4 - tpi - else if(lon .gt. lon_max) then - lon2 = lon2 +tpi; lon3 = lon3 + tpi - endif - endif - endif - - if(lat .ge. intersect(lon1,lat1,lon2,lat2,lon))then ! south - if(lon .le. intersect(lat2,lon2,lat3,lon3,lat))then ! east - if(lat .le. intersect(lon3,lat3,lon4,lat4,lon))then ! north - if(lon .ge. intersect(lat4,lon4,lat1,lon1,lat))then ! west - found = .true. - Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 - Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 - exit J_LOOP - endif - endif - endif - endif - enddo - enddo J_LOOP - else - step = 0 - do while ( .not. found .and. step .lt. max_step ) - !--- take the adajcent point as the starting point - if(m == 1) then - is = Interp % i_lon (m,n-1,1) - js = Interp % j_lat (m,n-1,1) - else - is = Interp % i_lon (m-1,n,1) - js = Interp % j_lat (m-1,n,1) - endif - if(step==0) then - npts = 1 - ilon(1) = is - jlat(1) = js - else - npts = 0 - !--- bottom boundary - jstart = max(js-step,1) - jend = min(js+step,nlat_in) - - do l = -step, step - i = is+l - if(src_modulo)then - if( i < 1) then - i = i + nlon_in - else if (i > nlon_in) then - i = i - nlon_in - endif - if( i < 1 .or. i > nlon_in) call mpp_error(FATAL, & - 'horiz_interp_bilinear_mod: max_step is too big, decrease max_step' ) - else - if( i < 1 .or. i > nlon_in) cycle - endif - - npts = npts + 1 - ilon(npts) = i - jlat(npts) = jstart - enddo - - !--- right and left boundary ----------------------------------------------- - istart = is - step - iend = is + step - if(src_modulo) then - if( istart < 1) istart = istart + nlon_in - if( iend > nlon_in) iend = iend - nlon_in - else - istart = max(istart,1) - iend = min(iend, nlon_in) - endif - do l = -step, step - j = js+l - if( j < 1 .or. j > nlat_in .or. j==jstart .or. j==jend) cycle - npts = npts+1 - ilon(npts) = istart - jlat(npts) = j - npts = npts+1 - ilon(npts) = iend - jlat(npts) = j - end do - - !--- top boundary - - do l = -step, step - i = is+l - if(src_modulo)then - if( i < 1) then - i = i + nlon_in - else if (i > nlon_in) then - i = i - nlon_in - endif - if( i < 1 .or. i > nlon_in) call mpp_error(FATAL, & - 'horiz_interp_bilinear_mod: max_step is too big, decrease max_step' ) - else - if( i < 1 .or. i > nlon_in) cycle - endif - - npts = npts + 1 - ilon(npts) = i - jlat(npts) = jend - enddo - - - end if - - !--- find the surrouding points - do l = 1, npts - i = ilon(l) - j = jlat(l) - ip1 = i+1 - if(ip1>nlon_in) then - if(src_modulo) then - ip1 = 1 - else - cycle - endif - endif - jp1 = j+1 - if(jp1>nlat_in) cycle - lon1 = lon_in(i, j); lat1 = lat_in(i,j) - lon2 = lon_in(ip1,j); lat2 = lat_in(ip1,j) - lon3 = lon_in(ip1,jp1); lat3 = lat_in(ip1,jp1) - lon4 = lon_in(i, jp1); lat4 = lat_in(i, jp1) - - if(lon .lt. lon_min .or. lon .gt. lon_max) then - if(i .ne. nlon_in) then - cycle - else - if(lon .lt. lon_min) then - lon1 = lon1 -tpi; lon4 = lon4 - tpi - else if(lon .gt. lon_max) then - lon2 = lon2 +tpi; lon3 = lon3 + tpi - endif - endif - endif - - if(lat .ge. intersect(lon1,lat1,lon2,lat2,lon))then ! south - if(lon .le. intersect(lat2,lon2,lat3,lon3,lat))then ! east - if(lat .le. intersect(lon3,lat3,lon4,lat4,lon))then !north - if(lon .ge. intersect(lat4,lon4,lat1,lon1,lat))then ! west - found = .true. - is=i; js=j - Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 - Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 - exit - endif - endif - endif - endif - enddo - step = step + 1 - enddo - endif - if(.not.found) then - print *,'lon,lat=',lon*180./PI,lat*180./PI - print *,'npts=',npts - print *,'is,ie= ',istart,iend - print *,'js,je= ',jstart,jend - print *,'lon_in(is,js)=',lon_in(istart,jstart)*180./PI - print *,'lon_in(ie,js)=',lon_in(iend,jstart)*180./PI - print *,'lat_in(is,js)=',lat_in(istart,jstart)*180./PI - print *,'lat_in(ie,js)=',lat_in(iend,jstart)*180./PI - print *,'lon_in(is,je)=',lon_in(istart,jend)*180./PI - print *,'lon_in(ie,je)=',lon_in(iend,jend)*180./PI - print *,'lat_in(is,je)=',lat_in(istart,jend)*180./PI - print *,'lat_in(ie,je)=',lat_in(iend,jend)*180./PI - - call mpp_error(FATAL, & - 'find_neighbor: the destination point is not inside the source grid' ) - endif - enddo - enddo - - end subroutine find_neighbor - - !####################################################################### - - !> The function will return true if the point x,y is inside a polygon, or - !! false if it is not. If the point is exactly on the edge of a polygon, - !! the function will return .true. - function inside_polygon(polyx, polyy, x, y) - real, dimension(:), intent(in) :: polyx !< longitude coordinates of corners - real, dimension(:), intent(in) :: polyy !< latitude coordinates of corners - real, intent(in) :: x !< x coordinate of point to be tested - real, intent(in) :: y !< y coordinate of point to be tested - logical :: inside_polygon - integer :: i, j, nedges - real :: xx - - inside_polygon = .false. - nedges = size(polyx(:)) - j = nedges - do i = 1, nedges - if( (polyy(i) < y .AND. polyy(j) >= y) .OR. (polyy(j) < y .AND. polyy(i) >= y) ) then - xx = polyx(i)+(y-polyy(i))/(polyy(j)-polyy(i))*(polyx(j)-polyx(i)) - if( xx == x ) then - inside_polygon = .true. - return - else if( xx < x ) then - inside_polygon = .not. inside_polygon - endif - endif - j = i - enddo - - return - - end function inside_polygon - - !####################################################################### - !> this routine will search the source grid to fine the grid box that encloses - !! each destination grid. - subroutine find_neighbor_new( Interp, lon_in, lat_in, lon_out, lat_out, src_modulo, no_crash ) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - logical, intent(in) :: src_modulo, no_crash - integer :: nlon_in, nlat_in, nlon_out, nlat_out - integer :: max_step, n, m, l, i, j, ip1, jp1, step - integer :: is, js, jstart, jend, istart, iend, npts - integer, allocatable, dimension(:) :: ilon, jlat - real :: lon_min, lon_max, lon, lat, tpi - logical :: found - real :: polyx(4), polyy(4) - real :: min_lon, min_lat, max_lon, max_lat - - integer, parameter :: step_div=8 - - tpi = 2.0*pi - nlon_in = size(lon_in,1) ; nlat_in = size(lat_in,2) - nlon_out = size(lon_out,1); nlat_out = size(lon_out,2) - - lon_min = minval(lon_in); - lon_max = maxval(lon_in); - - max_step = min(nlon_in,nlat_in)/step_div ! can be adjusted if needed - allocate(ilon(step_div*max_step), jlat(step_div*max_step) ) - - do n = 1, nlat_out - do m = 1, nlon_out - found = .false. - lon = lon_out(m,n) - lat = lat_out(m,n) - - if(src_modulo) then - if(lon .lt. lon_min) then - lon = lon + tpi - else if(lon .gt. lon_max) then - lon = lon - tpi - endif - else - if(lon .lt. lon_min .or. lon .gt. lon_max ) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: ' //& - 'when input grid is not modulo, output grid should locate inside input grid') - endif - !--- search for the surrounding four points locatioon. - if(m==1 .and. n==1) then - J_LOOP: do j = 1, nlat_in-1 - do i = 1, nlon_in - ip1 = i+1 - jp1 = j+1 - if(i==nlon_in) then - if(src_modulo)then - ip1 = 1 - else - cycle - endif - endif - - polyx(1) = lon_in(i, j); polyy(1) = lat_in(i,j) - polyx(2) = lon_in(ip1,j); polyy(2) = lat_in(ip1,j) - polyx(3) = lon_in(ip1,jp1); polyy(3) = lat_in(ip1,jp1) - polyx(4) = lon_in(i, jp1); polyy(4) = lat_in(i, jp1) - if(lon .lt. lon_min .or. lon .gt. lon_max) then - if(i .ne. nlon_in) then - cycle - else - if(lon .lt. lon_min) then - polyx(1) = polyx(1) -tpi; polyx(4) = polyx(4) - tpi - else if(lon .gt. lon_max) then - polyx(2) = polyx(2) +tpi; polyx(3) = polyx(3) + tpi - endif - endif - endif - - min_lon = minval(polyx) - max_lon = maxval(polyx) - min_lat = minval(polyy) - max_lat = maxval(polyy) -! if( lon .GE. min_lon .AND. lon .LE. max_lon .AND. & -! lat .GE. min_lat .AND. lat .LE. max_lat ) then -! print*, 'i =', i, 'j = ', j -! print '(5f15.11)', lon, polyx -! print '(5f15.11)', lat, polyy -! endif - - if(inside_polygon(polyx, polyy, lon, lat)) then - found = .true. -! print*, " found ", i, j - Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 - Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 - exit J_LOOP - endif - enddo - enddo J_LOOP - else - step = 0 - do while ( .not. found .and. step .lt. max_step ) - !--- take the adajcent point as the starting point - if(m == 1) then - is = Interp % i_lon (m,n-1,1) - js = Interp % j_lat (m,n-1,1) - else - is = Interp % i_lon (m-1,n,1) - js = Interp % j_lat (m-1,n,1) - endif - if(step==0) then - npts = 1 - ilon(1) = is - jlat(1) = js - else - npts = 0 - !--- bottom and top boundary - jstart = max(js-step,1) - jend = min(js+step,nlat_in) - - do l = -step, step - i = is+l - if(src_modulo)then - if( i < 1) then - i = i + nlon_in - else if (i > nlon_in) then - i = i - nlon_in - endif - if( i < 1 .or. i > nlon_in) call mpp_error(FATAL, & - 'horiz_interp_bilinear_mod: max_step is too big, decrease max_step' ) - else - if( i < 1 .or. i > nlon_in) cycle - endif - - npts = npts + 1 - ilon(npts) = i - jlat(npts) = jstart - npts = npts + 1 - ilon(npts) = i - jlat(npts) = jend - enddo - - !--- right and left boundary ----------------------------------------------- - istart = is - step - iend = is + step - if(src_modulo) then - if( istart < 1) istart = istart + nlon_in - if( iend > nlon_in) iend = iend - nlon_in - else - istart = max(istart,1) - iend = min(iend, nlon_in) - endif - do l = -step, step - j = js+l - if( j < 1 .or. j > nlat_in) cycle - npts = npts+1 - ilon(npts) = istart - jlat(npts) = j - npts = npts+1 - ilon(npts) = iend - jlat(npts) = j - end do - end if - - !--- find the surrouding points - do l = 1, npts - i = ilon(l) - j = jlat(l) - ip1 = i+1 - if(ip1>nlon_in) then - if(src_modulo) then - ip1 = 1 - else - cycle - endif - endif - jp1 = j+1 - if(jp1>nlat_in) cycle - polyx(1) = lon_in(i, j); polyy(1) = lat_in(i,j) - polyx(2) = lon_in(ip1,j); polyy(2) = lat_in(ip1,j) - polyx(3) = lon_in(ip1,jp1); polyy(3) = lat_in(ip1,jp1) - polyx(4) = lon_in(i, jp1); polyy(4) = lat_in(i, jp1) - if(inside_polygon(polyx, polyy, lon, lat)) then - found = .true. - Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 - Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 - exit - endif - enddo - step = step + 1 - enddo - endif - if(.not.found) then - if(no_crash) then - Interp % i_lon (m,n,1:2) = DUMMY - Interp % j_lat (m,n,1:2) = DUMMY - print*,'lon,lat=',lon,lat ! snz - else - call mpp_error(FATAL, & - 'horiz_interp_bilinear_mod: the destination point is not inside the source grid' ) - endif - endif - enddo - enddo - - end subroutine find_neighbor_new - - !####################################################################### - function intersect(x1, y1, x2, y2, x) - real, intent(in) :: x1, y1, x2, y2, x - real :: intersect - - intersect = (y2-y1)*(x-x1)/(x2-x1) + y1 - - return - - end function intersect - - !####################################################################### - - !> Subroutine for performing the horizontal interpolation between two grids - !! - !! @ref horiz_interp_bilinear_new must be called before calling this routine. - subroutine horiz_interp_bilinear ( Interp, data_in, data_out, verbose, mask_in,mask_out, & - missing_value, missing_permit, new_handle_missing ) - !----------------------------------------------------------------------- - type (horiz_interp_type), intent(in) :: Interp !< Derived type variable containing - !! interpolation indices and weights. Returned by a - !! previous call to horiz_interp_bilinear_new - real, intent(in), dimension(:,:) :: data_in !< input data on source grid - real, intent(out), dimension(:,:) :: data_out !< output data on source grid - integer, intent(in), optional :: verbose !< 0 = no output; 1 = min,max,means; 2 = - !! all output - real, intent(in), dimension(:,:), optional :: mask_in !< Input mask, must be the same size as - !! the input data. The real value of mask_in must be in the - !! range (0.,1.). Set mask_in=0.0 for data points - !! that should not be used or have missing data - real, intent(out), dimension(:,:), optional :: mask_out !< output mask that specifies whether - !! data was computed - real, intent(in), optional :: missing_value - integer, intent(in), optional :: missing_permit - logical, intent(in), optional :: new_handle_missing - !----------------------------------------------------------------------- - integer :: nlon_in, nlat_in, nlon_out, nlat_out, n, m, & - is, ie, js, je, iverbose, max_missing, num_missing, & - miss_in, miss_out, unit - real :: dwtsum, wtsum, min_in, max_in, avg_in, & - min_out, max_out, avg_out, wtw, wte, wts, wtn - real :: mask(size(data_in,1), size(data_in,2) ) - logical :: set_to_missing, is_missing(4), new_handler - real :: f1, f2, f3, f4, middle, w, s - - num_missing = 0 - - nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src - nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst - - if(present(mask_in)) then - mask = mask_in - else - mask = 1.0 - endif - - if (present(verbose)) then - iverbose = verbose - else - iverbose = 0 - endif - - if(present(missing_permit)) then - max_missing = missing_permit - else - max_missing = 0 - endif - - if(present(new_handle_missing)) then - new_handler = new_handle_missing - else - new_handler = .false. - endif - - if(max_missing .gt. 3 .or. max_missing .lt. 0) call mpp_error(FATAL, & - 'horiz_interp_bilinear_mod: missing_permit should be between 0 and 3') - - if (size(data_in,1) /= nlon_in .or. size(data_in,2) /= nlat_in) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: size of input array incorrect') - - if (size(data_out,1) /= nlon_out .or. size(data_out,2) /= nlat_out) & - call mpp_error(FATAL,'horiz_interp_bilinear_mod: size of output array incorrect') - - if(new_handler) then - if( .not. present(missing_value) ) call mpp_error(FATAL, & - "horiz_interp_bilinear_mod: misisng_value must be present when new_handle_missing is .true.") - if( present(mask_in) ) call mpp_error(FATAL, & - "horiz_interp_bilinear_mod: mask_in should not be present when new_handle_missing is .true.") - do n = 1, nlat_out - do m = 1, nlon_out - is = Interp % i_lon (m,n,1); ie = Interp % i_lon (m,n,2) - js = Interp % j_lat (m,n,1); je = Interp % j_lat (m,n,2) - wtw = Interp % wti (m,n,1) - wte = Interp % wti (m,n,2) - wts = Interp % wtj (m,n,1) - wtn = Interp % wtj (m,n,2) - - is_missing = .false. - num_missing = 0 - set_to_missing = .false. - if(data_in(is,js) == missing_value) then - num_missing = num_missing+1 - is_missing(1) = .true. - if(wtw .GE. 0.5 .AND. wts .GE. 0.5) set_to_missing = .true. - endif - - if(data_in(ie,js) == missing_value) then - num_missing = num_missing+1 - is_missing(2) = .true. - if(wte .GE. 0.5 .AND. wts .GE. 0.5) set_to_missing = .true. - endif - if(data_in(ie,je) == missing_value) then - num_missing = num_missing+1 - is_missing(3) = .true. - if(wte .GE. 0.5 .AND. wtn .GE. 0.5) set_to_missing = .true. - endif - if(data_in(is,je) == missing_value) then - num_missing = num_missing+1 - is_missing(4) = .true. - if(wtw .GE. 0.5 .AND. wtn .GE. 0.5) set_to_missing = .true. - endif - - if( num_missing == 4 .OR. set_to_missing ) then - data_out(m,n) = missing_value - if(present(mask_out)) mask_out(m,n) = 0.0 - cycle - else if(num_missing == 0) then - f1 = data_in(is,js) - f2 = data_in(ie,js) - f3 = data_in(ie,je) - f4 = data_in(is,je) - w = wtw - s = wts - else if(num_missing == 3) then !--- three missing value - if(.not. is_missing(1) ) then - data_out(m,n) = data_in(is,js) - else if(.not. is_missing(2) ) then - data_out(m,n) = data_in(ie,js) - else if(.not. is_missing(3) ) then - data_out(m,n) = data_in(ie,je) - else if(.not. is_missing(4) ) then - data_out(m,n) = data_in(is,je) - endif - if(present(mask_out) ) mask_out(m,n) = 1.0 - cycle - else !--- one or two missing value - if( num_missing == 1) then - if( is_missing(1) .OR. is_missing(3) ) then - middle = 0.5*(data_in(ie,js)+data_in(is,je)) - else - middle = 0.5*(data_in(is,js)+data_in(ie,je)) - endif - else ! num_missing = 2 - if( is_missing(1) .AND. is_missing(2) ) then - middle = 0.5*(data_in(ie,je)+data_in(is,je)) - else if( is_missing(1) .AND. is_missing(3) ) then - middle = 0.5*(data_in(ie,js)+data_in(is,je)) - else if( is_missing(1) .AND. is_missing(4) ) then - middle = 0.5*(data_in(ie,js)+data_in(ie,je)) - else if( is_missing(2) .AND. is_missing(3) ) then - middle = 0.5*(data_in(is,js)+data_in(is,je)) - else if( is_missing(2) .AND. is_missing(4) ) then - middle = 0.5*(data_in(is,js)+data_in(ie,je)) - else if( is_missing(3) .AND. is_missing(4) ) then - middle = 0.5*(data_in(is,js)+data_in(ie,js)) - endif - endif - - if( wtw .GE. 0.5 .AND. wts .GE. 0.5 ) then ! zone 1 - w = 2.0*(wtw-0.5) - s = 2.0*(wts-0.5) - f1 = data_in(is,js) - if(is_missing(2)) then - f2 = f1 - else - f2 = 0.5*(data_in(is,js)+data_in(ie,js)) - endif - f3 = middle - if(is_missing(4)) then - f4 = f1 - else - f4 = 0.5*(data_in(is,js)+data_in(is,je)) - endif - else if( wte .GE. 0.5 .AND. wts .GE. 0.5 ) then ! zone 2 - w = 2.0*(1.0-wte) - s = 2.0*(wts-0.5) - f2 = data_in(ie,js) - if(is_missing(1)) then - f1 = f2 - else - f1 = 0.5*(data_in(is,js)+data_in(ie,js)) - endif - f4 = middle - if(is_missing(3)) then - f3 = f2 - else - f3 = 0.5*(data_in(ie,js)+data_in(ie,je)) - endif - else if( wte .GE. 0.5 .AND. wtn .GE. 0.5 ) then ! zone 3 - w = 2.0*(1.0-wte) - s = 2.0*(1.0-wtn) - f3 = data_in(ie,je) - if(is_missing(2)) then - f2 = f3 - else - f2 = 0.5*(data_in(ie,js)+data_in(ie,je)) - endif - f1 = middle - if(is_missing(4)) then - f4 = f3 - else - f4 = 0.5*(data_in(ie,je)+data_in(is,je)) - endif - else if( wtw .GE. 0.5 .AND. wtn .GE. 0.5 ) then ! zone 4 - w = 2.0*(wtw-0.5) - s = 2.0*(1.0-wtn) - f4 = data_in(is,je) - if(is_missing(1)) then - f1 = f4 - else - f1 = 0.5*(data_in(is,js)+data_in(is,je)) - endif - f2 = middle - if(is_missing(3)) then - f3 = f4 - else - f3 = 0.5*(data_in(ie,je)+data_in(is,je)) - endif - else - call mpp_error(FATAL, & - "horiz_interp_bilinear_mod: the point should be in one of the four zone") - endif - endif - - data_out(m,n) = f3 + (f4-f3)*w + (f2-f3)*s + ((f1-f2)+(f3-f4))*w*s - if(present(mask_out)) mask_out(m,n) = 1.0 - enddo - enddo - else - do n = 1, nlat_out - do m = 1, nlon_out - is = Interp % i_lon (m,n,1); ie = Interp % i_lon (m,n,2) - js = Interp % j_lat (m,n,1); je = Interp % j_lat (m,n,2) - wtw = Interp % wti (m,n,1) - wte = Interp % wti (m,n,2) - wts = Interp % wtj (m,n,1) - wtn = Interp % wtj (m,n,2) - - if(present(missing_value) ) then - num_missing = 0 - if(data_in(is,js) == missing_value) then - num_missing = num_missing+1 - mask(is,js) = 0.0 - endif - if(data_in(ie,js) == missing_value) then - num_missing = num_missing+1 - mask(ie,js) = 0.0 - endif - if(data_in(ie,je) == missing_value) then - num_missing = num_missing+1 - mask(ie,je) = 0.0 - endif - if(data_in(is,je) == missing_value) then - num_missing = num_missing+1 - mask(is,je) = 0.0 - endif - endif - - dwtsum = data_in(is,js)*mask(is,js)*wtw*wts & - + data_in(ie,js)*mask(ie,js)*wte*wts & - + data_in(ie,je)*mask(ie,je)*wte*wtn & - + data_in(is,je)*mask(is,je)*wtw*wtn - wtsum = mask(is,js)*wtw*wts + mask(ie,js)*wte*wts & - + mask(ie,je)*wte*wtn + mask(is,je)*wtw*wtn - - if(.not. present(mask_in) .and. .not. present(missing_value)) wtsum = 1.0 - - if(num_missing .gt. max_missing ) then - data_out(m,n) = missing_value - if(present(mask_out)) mask_out(m,n) = 0.0 - else if(wtsum .lt. epsln) then - if(present(missing_value)) then - data_out(m,n) = missing_value - else - data_out(m,n) = 0.0 - endif - if(present(mask_out)) mask_out(m,n) = 0.0 - else - data_out(m,n) = dwtsum/wtsum - if(present(mask_out)) mask_out(m,n) = wtsum - endif - enddo - enddo - endif - !*********************************************************************** - ! compute statistics: minimum, maximum, and mean - !----------------------------------------------------------------------- - if (iverbose > 0) then - - ! compute statistics of input data - - call stats (data_in, min_in, max_in, avg_in, miss_in, missing_value, mask_in) - - ! compute statistics of output data - call stats (data_out, min_out, max_out, avg_out, miss_out, missing_value, mask_out) - - !---- output statistics ---- - unit = stdout() - write (unit,900) - write (unit,901) min_in ,max_in, avg_in - if (present(mask_in)) write (unit,903) miss_in - write (unit,902) min_out,max_out,avg_out - if (present(mask_out)) write (unit,903) miss_out - -900 format (/,1x,10('-'),' output from horiz_interp ',10('-')) -901 format (' input: min=',f16.9,' max=',f16.9,' avg=',f22.15) -902 format (' output: min=',f16.9,' max=',f16.9,' avg=',f22.15) -903 format (' number of missing points = ',i6) - - endif - - return - - end subroutine horiz_interp_bilinear - - !####################################################################### - !> @brief Deallocates memory used by "horiz_interp_type" variables. !! !> Must be called before reinitializing with horiz_interp_bilinear_new. @@ -1240,60 +100,23 @@ subroutine horiz_interp_bilinear_del( Interp ) !! have allocated arrays. The returned variable will contain !! deallocated arrays - if(allocated(Interp%wti)) deallocate(Interp%wti) - if(allocated(Interp%wtj)) deallocate(Interp%wtj) + if( Interp%horizInterpReals4_type%is_allocated) then + if(allocated(Interp%horizInterpReals4_type%wti)) deallocate(Interp%horizInterpReals4_type%wti) + if(allocated(Interp%horizInterpReals4_type%wtj)) deallocate(Interp%horizInterpReals4_type%wtj) + else if (Interp%horizInterpReals8_type%is_allocated) then + if(allocated(Interp%horizInterpReals8_type%wti)) deallocate(Interp%horizInterpReals8_type%wti) + if(allocated(Interp%horizInterpReals8_type%wtj)) deallocate(Interp%horizInterpReals8_type%wtj) + endif if(allocated(Interp%i_lon)) deallocate(Interp%i_lon) if(allocated(Interp%j_lat)) deallocate(Interp%j_lat) - end subroutine horiz_interp_bilinear_del - - !####################################################################### - !> @returns index of nearest data point to "value" - !! if "value" is outside the domain of "array" then indp = 1 - !! or "ia" depending on whether array(1) or array(ia) is - !! closest to "value" - function indp (value, array) - integer :: indp !< index of nearest data point within "array" - !! corresponding to "value". - real, dimension(:), intent(in) :: array !< array of data points (must be monotonically increasing) - real, intent(in) :: value !< arbitrary data, same units as elements in 'array' - - !======================================================================= + Interp%horizInterpReals4_type%is_allocated = .false. + Interp%horizInterpReals8_type%is_allocated = .false. - integer i, ia, unit - logical keep_going - ! - ia = size(array(:)) - do i=2,ia - if (array(i) .lt. array(i-1)) then - unit = stdout() - write (unit,*) & - ' => Error: array must be monotonically increasing in "indp"' , & - ' when searching for nearest element to value=',value - write (unit,*) ' array(i) < array(i-1) for i=',i - write (unit,*) ' array(i) for i=1..ia follows:' - call mpp_error() - endif - enddo - if (value .lt. array(1) .or. value .gt. array(ia)) then - if (value .lt. array(1)) indp = 1 - if (value .gt. array(ia)) indp = ia - else - i=1 - keep_going = .true. - do while (i .le. ia .and. keep_going) - i = i+1 - if (value .le. array(i)) then - indp = i - if (array(i)-value .gt. value-array(i-1)) indp = i-1 - keep_going = .false. - endif - enddo - endif - return - end function indp + end subroutine horiz_interp_bilinear_del - !###################################################################### +#include "horiz_interp_bilinear_r4.fh" +#include "horiz_interp_bilinear_r8.fh" end module horiz_interp_bilinear_mod !> @} diff --git a/horiz_interp/horiz_interp_conserve.F90 b/horiz_interp/horiz_interp_conserve.F90 index 1f73062997..b1b04a1b34 100644 --- a/horiz_interp/horiz_interp_conserve.F90 +++ b/horiz_interp/horiz_interp_conserve.F90 @@ -37,7 +37,7 @@ module horiz_interp_conserve_mod -#include + use platform_mod, only: r4_kind, r8_kind use mpp_mod, only: mpp_send, mpp_recv, mpp_pe, mpp_root_pe, mpp_npes use mpp_mod, only: mpp_error, FATAL, mpp_sync_self use mpp_mod, only: COMM_TAG_1, COMM_TAG_2 @@ -90,12 +90,44 @@ module horiz_interp_conserve_mod !! !> @ingroup horiz_interp_conserve_mod interface horiz_interp_conserve_new - module procedure horiz_interp_conserve_new_1dx1d - module procedure horiz_interp_conserve_new_1dx2d - module procedure horiz_interp_conserve_new_2dx1d - module procedure horiz_interp_conserve_new_2dx2d + module procedure horiz_interp_conserve_new_1dx1d_r4 + module procedure horiz_interp_conserve_new_1dx2d_r4 + module procedure horiz_interp_conserve_new_2dx1d_r4 + module procedure horiz_interp_conserve_new_2dx2d_r4 + module procedure horiz_interp_conserve_new_1dx1d_r8 + module procedure horiz_interp_conserve_new_1dx2d_r8 + module procedure horiz_interp_conserve_new_2dx1d_r8 + module procedure horiz_interp_conserve_new_2dx2d_r8 end interface + interface horiz_interp_conserve + module procedure horiz_interp_conserve_r4 + module procedure horiz_interp_conserve_r8 + end interface + +!> private helper routines + interface data_sum + module procedure data_sum_r4 + module procedure data_sum_r8 + end interface + + interface stats + module procedure stats_r4 + module procedure stats_r8 + end interface + + interface horiz_interp_conserve_version1 + module procedure horiz_interp_conserve_version1_r8 + module procedure horiz_interp_conserve_version1_r4 + end interface + + interface horiz_interp_conserve_version2 + module procedure horiz_interp_conserve_version2_r8 + module procedure horiz_interp_conserve_version2_r4 + end interface + + + !> @addtogroup horiz_interp_conserve_mod !> @{ public :: horiz_interp_conserve_init @@ -111,8 +143,6 @@ module horiz_interp_conserve_mod contains - !####################################################################### - !> Writes version number to logfile. subroutine horiz_interp_conserve_init @@ -125,796 +155,7 @@ subroutine horiz_interp_conserve_init end subroutine horiz_interp_conserve_init - !####################################################################### - - subroutine horiz_interp_conserve_new_1dx1d ( Interp, lon_in, lat_in, lon_out, lat_out, verbose) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:) :: lon_out, lat_out - integer, intent(in), optional :: verbose - - !----------------------------------------------------------------------- - real, dimension(size(lat_out(:))-1,2) :: sph - real, dimension(size(lon_out(:))-1,2) :: theta - real, dimension(size(lat_in(:))) :: slat_in - real, dimension(size(lon_in(:))-1) :: dlon_in - real, dimension(size(lat_in(:))-1) :: dsph_in - real, dimension(size(lon_out(:))-1) :: dlon_out - real, dimension(size(lat_out(:))-1) :: dsph_out - real :: blon, fac, hpi, tpi, eps - integer :: num_iters = 4 - integer :: i, j, m, n, nlon_in, nlat_in, nlon_out, nlat_out, & - iverbose, m2, n2, iter - logical :: s2n - character(len=64) :: mesg - - if(.not. module_is_initialized) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_1dx1d: horiz_interp_conserve_init is not called') - - if(great_circle_algorithm) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_1dx1d: great_circle_algorithm is not implemented, contact developer') - !----------------------------------------------------------------------- - iverbose = 0; if (present(verbose)) iverbose = verbose - - pe = mpp_pe() - root_pe = mpp_root_pe() - !----------------------------------------------------------------------- - hpi = 0.5*pi - tpi = 4.*hpi - Interp%version = 1 - nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 - nlon_out = size(lon_out(:))-1; nlat_out = size(lat_out(:))-1 - - allocate ( Interp % facj (nlat_out,2), Interp % jlat (nlat_out,2), & - Interp % faci (nlon_out,2), Interp % ilon (nlon_out,2), & - Interp % area_src (nlon_in, nlat_in), & - Interp % area_dst (nlon_out, nlat_out) ) - - !----------------------------------------------------------------------- - ! --- set-up for input grid boxes --- - - do j = 1, nlat_in+1 - slat_in(j) = sin(lat_in(j)) - enddo - - do j = 1, nlat_in - dsph_in(j) = abs(slat_in(j+1)-slat_in(j)) - enddo - - do i = 1,nlon_in - dlon_in(i) = abs(lon_in(i+1)-lon_in(i)) - enddo - - ! set south to north flag - s2n = .true. - if (lat_in(1) > lat_in(nlat_in+1)) s2n = .false. - - !----------------------------------------------------------------------- - ! --- set-up for output grid boxes --- - - do n = 1, nlat_out - dsph_out(n) = abs(sin(lat_out(n+1))-sin(lat_out(n))) - enddo - - do m = 1,nlon_out - theta(m,1) = lon_out(m) - theta(m,2) = lon_out(m+1) - dlon_out(m) = abs(lon_out(m+1)-lon_out(m)) - enddo - - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out - !*********************************************************************** - - !------ set up latitudinal indexing ------ - !------ make sure output grid goes south to north ------ - - do n = 1, nlat_out - if (lat_out(n) < lat_out(n+1)) then - sph(n,1) = sin(lat_out(n)) - sph(n,2) = sin(lat_out(n+1)) - else - sph(n,1) = sin(lat_out(n+1)) - sph(n,2) = sin(lat_out(n)) - endif - enddo - - Interp%jlat = 0 - do n2 = 1, 2 ! looping on grid box edges - do n = 1, nlat_out ! looping on output latitudes - eps = 0.0 - do iter=1,num_iters - ! find indices from input latitudes - do j = 1, nlat_in - if ( (s2n .and. (slat_in(j)-sph(n,n2)) <= eps .and. & - (sph(n,n2)-slat_in(j+1)) <= eps) .or. & - (.not.s2n .and. (slat_in(j+1)-sph(n,n2)) <= eps .and. & - (sph(n,n2)-slat_in(j)) <= eps) ) then - Interp%jlat(n,n2) = j - ! weight with sin(lat) to exactly conserve area-integral - fac = (sph(n,n2)-slat_in(j))/(slat_in(j+1)-slat_in(j)) - if (s2n) then - if (n2 == 1) Interp%facj(n,n2) = 1.0 - fac - if (n2 == 2) Interp%facj(n,n2) = fac - else - if (n2 == 1) Interp%facj(n,n2) = fac - if (n2 == 2) Interp%facj(n,n2) = 1.0 - fac - endif - exit - endif - enddo - if ( Interp%jlat(n,n2) /= 0 ) exit - ! did not find this output grid edge in the input grid - ! increase tolerance for multiple passes - eps = epsilon(sph)*real(10**iter) - enddo - ! no match - if ( Interp%jlat(n,n2) == 0 ) then - write (mesg,710) n,sph(n,n2) -710 format (': n,sph=',i3,f14.7,40x) - call mpp_error(FATAL, 'horiz_interp_conserve_mod:no latitude index found'//trim(mesg)) - endif - enddo - enddo - - !------ set up longitudinal indexing ------ - - Interp%ilon = 0 - do m2 = 1, 2 ! looping on grid box edges - do m = 1, nlon_out ! looping on output longitudes - blon = theta(m,m2) - if ( blon < lon_in(1) ) blon = blon + tpi - if ( blon > lon_in(nlon_in+1) ) blon = blon - tpi - eps = 0.0 - do iter=1,num_iters - ! find indices from input longitudes - do i = 1, nlon_in - if ( (lon_in(i)-blon) <= eps .and. & - (blon-lon_in(i+1)) <= eps ) then - Interp%ilon(m,m2) = i - fac = (blon-lon_in(i))/(lon_in(i+1)-lon_in(i)) - if (m2 == 1) Interp%faci(m,m2) = 1.0 - fac - if (m2 == 2) Interp%faci(m,m2) = fac - exit - endif - enddo - if ( Interp%ilon(m,m2) /= 0 ) exit - ! did not find this output grid edge in the input grid - ! increase tolerance for multiple passes - eps = epsilon(blon)*real(10**iter) - enddo - ! no match - if ( Interp%ilon(m,m2) == 0 ) then - print *, 'lon_out,blon,blon_in,eps=', & - theta(m,m2),blon,lon_in(1),lon_in(nlon_in+1),eps - call mpp_error(FATAL, 'horiz_interp_conserve_mod: no longitude index found') - endif - enddo - enddo - - ! --- area of input grid boxes --- - - do j = 1,nlat_in - do i = 1,nlon_in - Interp%area_src(i,j) = dlon_in(i) * dsph_in(j) - enddo - enddo - - ! --- area of output grid boxes --- - - do n = 1, nlat_out - do m = 1, nlon_out - Interp%area_dst(m,n) = dlon_out(m) * dsph_out(n) - enddo - enddo - - !----------------------------------------------------------------------- - ! this output may be quite lengthy and is not recommended - ! when using more than one processor - if (iverbose > 2) then - write (*,801) (i,Interp%ilon(i,1),Interp%ilon(i,2), & - Interp%faci(i,1),Interp%faci(i,2),i=1,nlon_out) - write (*,802) (j,Interp%jlat(j,1),Interp%jlat(j,2), & - Interp%facj(j,1),Interp%facj(j,2),j=1,nlat_out) -801 format (/,2x,'i',4x,'is',5x,'ie',4x,'facis',4x,'facie', & - /,(i4,2i7,2f10.5)) -802 format (/,2x,'j',4x,'js',5x,'je',4x,'facjs',4x,'facje', & - /,(i4,2i7,2f10.5)) - endif - !----------------------------------------------------------------------- - - end subroutine horiz_interp_conserve_new_1dx1d - - !####################################################################### - - subroutine horiz_interp_conserve_new_1dx2d ( Interp, lon_in, lat_in, lon_out, lat_out, & - mask_in, mask_out, verbose) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - real, intent(in), optional, dimension(:,:) :: mask_in - real, intent(inout), optional, dimension(:,:) :: mask_out - integer, intent(in), optional :: verbose - - - integer :: create_xgrid_1DX2D_order1, get_maxxgrid, maxxgrid - integer :: create_xgrid_great_circle - integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i, j - real(DOUBLE_KIND), dimension(size(lon_in(:))-1, size(lat_in(:))-1) :: mask_src - integer, allocatable, dimension(:) :: i_src, j_src, i_dst, j_dst - real(DOUBLE_KIND), allocatable, dimension(:) :: xgrid_area, clon, clat - real(DOUBLE_KIND), allocatable, dimension(:,:) :: dst_area, lon_src, lat_src - real(DOUBLE_KIND), allocatable, dimension(:) :: lat_in_flip - real(DOUBLE_KIND), allocatable, dimension(:,:) :: mask_src_flip - real(DOUBLE_KIND), allocatable, dimension(:) :: lon_in_r8, lat_in_r8 - real(DOUBLE_KIND), allocatable, dimension(:,:) :: lon_out_r8, lat_out_r8 - - integer :: nincrease, ndecrease - logical :: flip_lat - integer :: wordsz - integer(kind=1) :: one_byte(8) - - if(.not. module_is_initialized) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_1dx2d: horiz_interp_conserve_init is not called') - - wordsz=size(transfer(lon_in(1), one_byte)) - if(wordsz .NE. 4 .AND. wordsz .NE. 8) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_1dx2d: wordsz should be 4 or 8') - - if( (size(lon_out,1) .NE. size(lat_out,1)) .OR. (size(lon_out,2) .NE. size(lat_out,2)) ) & - call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_out and lat_out') - nlon_in = size(lon_in(:)) - 1; nlat_in = size(lat_in(:)) - 1 - nlon_out = size(lon_out,1) - 1; nlat_out = size(lon_out,2) - 1 - - mask_src = 1. - if(present(mask_in)) then - if( (size(mask_in,1) .NE. nlon_in) .OR. (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, & - 'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in') - mask_src = mask_in - end if - - maxxgrid = get_maxxgrid() - allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) ) - allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) ) - - !--- check if source latitude is flipped - nincrease = 0 - ndecrease = 0 - do j = 1, nlat_in - if( lat_in(j+1) > lat_in(j) ) then - nincrease = nincrease + 1 - else if ( lat_in(j+1) < lat_in(j) ) then - ndecrease = ndecrease + 1 - endif - enddo - - if(nincrease == nlat_in) then - flip_lat = .false. - else if(ndecrease == nlat_in) then - flip_lat = .true. - else - call mpp_error(FATAL, 'horiz_interp_conserve_mod: nlat_in should be equal to nincreaase or ndecrease') - endif - - allocate(lon_out_r8(size(lon_out,1),size(lon_out,2))) - allocate(lat_out_r8(size(lat_out,1),size(lat_out,2))) - lon_out_r8 = lon_out - lat_out_r8 = lat_out - - if( .not. great_circle_algorithm ) then - if(flip_lat) then - allocate(lat_in_flip(nlat_in+1), mask_src_flip(nlon_in,nlat_in)) - do j = 1, nlat_in+1 - lat_in_flip(j) = lat_in(nlat_in+2-j) - enddo - do j = 1, nlat_in - mask_src_flip(:,j) = mask_src(:,nlat_in+1-j) - enddo - allocate(lon_in_r8(size(lon_in))) - lon_in_r8 = lon_in - nxgrid = create_xgrid_1DX2D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_flip, & - lon_out_r8, lat_out_r8, mask_src_flip, i_src, j_src, i_dst, j_dst, xgrid_area) - deallocate(lon_in_r8, lat_in_flip, mask_src_flip) - else - allocate(lon_in_r8(size(lon_in))) - allocate(lat_in_r8(size(lat_in))) - lon_in_r8 = lon_in - lat_in_r8 = lat_in - nxgrid = create_xgrid_1DX2D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_out_r8, & - & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area) - deallocate(lon_in_r8,lat_in_r8) - endif - else - allocate(lon_src(nlon_in+1,nlat_in+1), lat_src(nlon_in+1,nlat_in+1)) - allocate(clon(maxxgrid), clat(maxxgrid)) - if(flip_lat) then - allocate(mask_src_flip(nlon_in,nlat_in)) - do j = 1, nlat_in+1 - do i = 1, nlon_in+1 - lon_src(i,j) = lon_in(i) - lat_src(i,j) = lat_in(nlat_in+2-j) - enddo - enddo - do j = 1, nlat_in - mask_src_flip(:,j) = mask_src(:,nlat_in+1-j) - enddo - nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_src, lat_src, lon_out_r8, & - & lat_out_r8, mask_src_flip, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) - deallocate(mask_src_flip) - else - do j = 1, nlat_in+1 - do i = 1, nlon_in+1 - lon_src(i,j) = lon_in(i) - lat_src(i,j) = lat_in(j) - enddo - enddo - nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_src, lat_src, lon_out_r8, & - & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) - endif - deallocate(lon_src, lat_src, clon, clat) - endif - - deallocate(lon_out_r8, lat_out_r8) - - allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) ) - allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) ) - allocate(Interp%area_frac_dst(nxgrid) ) - Interp%version = 2 - Interp%nxgrid = nxgrid - Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0 - Interp%j_src = j_src(1:nxgrid)+1 - if(flip_lat) Interp%j_src = nlat_in+1-Interp%j_src - Interp%i_dst = i_dst(1:nxgrid)+1 - Interp%j_dst = j_dst(1:nxgrid)+1 - - ! sum over exchange grid area to get destination grid area - dst_area = 0. - do i = 1, nxgrid - dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i) - end do - - do i = 1, nxgrid - Interp%area_frac_dst(i) = xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i) ) - end do - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out - if(present(mask_out)) then - if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, & - 'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out') - mask_out = 0.0 - do i = 1, nxgrid - mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i), & - & Interp%j_dst(i)) + Interp%area_frac_dst(i) - end do - end if - - deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area ) - - end subroutine horiz_interp_conserve_new_1dx2d - - !####################################################################### - - subroutine horiz_interp_conserve_new_2dx1d ( Interp, lon_in, lat_in, lon_out, lat_out, & - mask_in, mask_out, verbose) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:) :: lon_out, lat_out - real, intent(in), optional, dimension(:,:) :: mask_in - real, intent(inout), optional, dimension(:,:) :: mask_out - integer, intent(in), optional :: verbose - - integer :: create_xgrid_2DX1D_order1, get_maxxgrid, maxxgrid - integer :: create_xgrid_great_circle - integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i, j - integer, allocatable, dimension(:) :: i_src, j_src, i_dst, j_dst - real, allocatable, dimension(:,:) :: dst_area - real(DOUBLE_KIND), dimension(size(lon_in,1)-1, size(lon_in,2)-1) :: mask_src - real(DOUBLE_KIND), allocatable, dimension(:) :: xgrid_area, clon, clat - real(DOUBLE_KIND), allocatable, dimension(:) :: lon_out_r8, lat_out_r8 - real(DOUBLE_KIND), allocatable, dimension(:,:) :: lon_in_r8, lat_in_r8 - real(DOUBLE_KIND), allocatable, dimension(:,:) :: lon_dst, lat_dst - integer :: wordsz - integer(kind=1) :: one_byte(8) - - if(.not. module_is_initialized) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_2dx1d: horiz_interp_conserve_init is not called') - - wordsz=size(transfer(lon_in(1,1), one_byte)) - if(wordsz .NE. 8) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_2dx1d: currently only support 64-bit real, contact developer') - - if( (size(lon_in,1) .NE. size(lat_in,1)) .OR. (size(lon_in,2) .NE. size(lat_in,2)) ) & - call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_in and lat_in') - nlon_in = size(lon_in,1) - 1; nlat_in = size(lon_in,2) - 1 - nlon_out = size(lon_out(:)) - 1; nlat_out = size(lat_out(:)) - 1 - - mask_src = 1. - if(present(mask_in)) then - if( (size(mask_in,1) .NE. nlon_in) .OR. (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, & - 'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in') - mask_src = mask_in - end if - - maxxgrid = get_maxxgrid() - allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) ) - allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) ) - - if( .not. great_circle_algorithm ) then - allocate(lon_out_r8(size(lon_out))) - allocate(lat_out_r8(size(lat_out))) - lon_out_r8 = lon_out - lat_out_r8 = lat_out - nxgrid = create_xgrid_2DX1D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in, lat_in, lon_out, lat_out, & - mask_src, i_src, j_src, i_dst, j_dst, xgrid_area) - deallocate(lon_out_r8,lat_out_r8) - else - allocate(lon_in_r8(size(lon_in,1),size(lon_in,2))) - allocate(lat_in_r8(size(lat_in,1),size(lat_in,2))) - lon_in_r8 = lon_in - lat_in_r8 = lat_in - allocate(lon_dst(nlon_out+1, nlat_out+1), lat_dst(nlon_out+1, nlat_out+1) ) - allocate(clon(maxxgrid), clat(maxxgrid)) - do j = 1, nlat_out+1 - do i = 1, nlon_out+1 - lon_dst(i,j) = lon_out(i) - lat_dst(i,j) = lat_out(j) - enddo - enddo - nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_dst, & - & lat_dst, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) - deallocate(lon_in_r8, lat_in_r8, lon_dst, lat_dst, clon, clat) - endif - allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) ) - allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) ) - allocate(Interp%area_frac_dst(nxgrid) ) - Interp%version = 2 - Interp%nxgrid = nxgrid - Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0 - Interp%j_src = j_src(1:nxgrid)+1 - Interp%i_dst = i_dst(1:nxgrid)+1 - Interp%j_dst = j_dst(1:nxgrid)+1 - - ! sum over exchange grid area to get destination grid area - dst_area = 0. - do i = 1, nxgrid - dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i) - end do - - do i = 1, nxgrid - Interp%area_frac_dst(i) = xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i) ) - end do - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out - if(present(mask_out)) then - if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, & - 'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out') - mask_out = 0.0 - do i = 1, nxgrid - mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i), & - & Interp%j_dst(i)) + Interp%area_frac_dst(i) - end do - end if - - deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area) - - end subroutine horiz_interp_conserve_new_2dx1d - - !####################################################################### - - subroutine horiz_interp_conserve_new_2dx2d ( Interp, lon_in, lat_in, lon_out, lat_out, & - mask_in, mask_out, verbose) - type(horiz_interp_type), intent(inout) :: Interp - real, intent(in), dimension(:,:) :: lon_in , lat_in - real, intent(in), dimension(:,:) :: lon_out, lat_out - real, intent(in), optional, dimension(:,:) :: mask_in - real, intent(inout), optional, dimension(:,:) :: mask_out - integer, intent(in), optional :: verbose - - integer :: create_xgrid_2DX2D_order1, get_maxxgrid, maxxgrid - integer :: create_xgrid_great_circle - integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i - integer, allocatable, dimension(:) :: i_src, j_src, i_dst, j_dst - real(DOUBLE_KIND), dimension(size(lon_in,1)-1, size(lon_in,2)-1) :: mask_src - real(DOUBLE_KIND), allocatable, dimension(:) :: xgrid_area, clon, clat - real(DOUBLE_KIND), allocatable, dimension(:,:) :: dst_area - real(DOUBLE_KIND), allocatable, dimension(:,:) :: lon_in_r8, lat_in_r8 - real(DOUBLE_KIND), allocatable, dimension(:,:) :: lon_out_r8, lat_out_r8 - integer :: wordsz - integer(kind=1) :: one_byte(8) - - if(.not. module_is_initialized) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_2dx2d: horiz_interp_conserve_init is not called') - - wordsz=size(transfer(lon_in(1,1), one_byte)) - if(wordsz .NE. 4 .AND. wordsz .NE. 8) call mpp_error(FATAL, & - 'horiz_interp_conserve_new_2dx2d: wordsz should be 4 or 8') - - if( (size(lon_in,1) .NE. size(lat_in,1)) .OR. (size(lon_in,2) .NE. size(lat_in,2)) ) & - call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_in and lat_in') - if( (size(lon_out,1) .NE. size(lat_out,1)) .OR. (size(lon_out,2) .NE. size(lat_out,2)) ) & - call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_out and lat_out') - nlon_in = size(lon_in,1) - 1; nlat_in = size(lon_in,2) - 1 - nlon_out = size(lon_out,1) - 1; nlat_out = size(lon_out,2) - 1 - - mask_src = 1. - if(present(mask_in)) then - if( (size(mask_in,1) .NE. nlon_in) .OR. (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, & - 'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in') - mask_src = mask_in - end if - - maxxgrid = get_maxxgrid() - allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) ) - allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) ) - - allocate(lon_in_r8(size(lon_in,1),size(lon_in,2))) - allocate(lat_in_r8(size(lat_in,1),size(lat_in,2))) - allocate(lon_out_r8(size(lon_out,1),size(lon_out,2))) - allocate(lat_out_r8(size(lat_out,1),size(lat_out,2))) - lon_in_r8 = lon_in - lat_in_r8 = lat_in - lon_out_r8 = lon_out - lat_out_r8 = lat_out - - if( .not. great_circle_algorithm ) then - nxgrid = create_xgrid_2DX2D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_out_r8, & - & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area) - else - allocate(clon(maxxgrid), clat(maxxgrid)) - nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_out_r8, & - & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) - deallocate(clon, clat) - endif - - deallocate(lon_in_r8, lat_in_r8, lon_out_r8, lat_out_r8) - - allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) ) - allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) ) - allocate(Interp%area_frac_dst(nxgrid) ) - Interp%version = 2 - Interp%nxgrid = nxgrid - Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0 - Interp%j_src = j_src(1:nxgrid)+1 - Interp%i_dst = i_dst(1:nxgrid)+1 - Interp%j_dst = j_dst(1:nxgrid)+1 - - ! sum over exchange grid area to get destination grid area - dst_area = 0. - do i = 1, nxgrid - dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i) - end do - - do i = 1, nxgrid - Interp%area_frac_dst(i) = xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i) ) - end do - - Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in - Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out - if(present(mask_out)) then - if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, & - 'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out') - mask_out = 0.0 - do i = 1, nxgrid - mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i), & - & Interp%j_dst(i)) + Interp%area_frac_dst(i) - end do - end if - - deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area ) - - end subroutine horiz_interp_conserve_new_2dx2d - - !######################################################################## - - !> @brief Subroutine for performing the horizontal interpolation between two grids. - !! - !> Subroutine for performing the horizontal interpolation between two grids. - !! horiz_interp_conserve_new must be called before calling this routine. - subroutine horiz_interp_conserve ( Interp, data_in, data_out, verbose, & - mask_in, mask_out) - !----------------------------------------------------------------------- - type (horiz_interp_type), intent(in) :: Interp - real, intent(in), dimension(:,:) :: data_in !< Input data on source grid - real, intent(out), dimension(:,:) :: data_out !< Output data on destination grid - integer, intent(in), optional :: verbose !< 0 = no output; 1 = min,max,means; - !! 2 = max output - real, intent(in), dimension(:,:), optional :: mask_in !< Input mask, must be the same size as - !! the input data. The real value of mask_in must be in the range (0.,1.). - !! Set mask_in=0.0 for data points that should not be used or have missing - !! data. mask_in will be applied only when horiz_interp_conserve_new_1d is - !! called. mask_in will be passed into horiz_interp_conserve_new_2d - real, intent(out), dimension(:,:), optional :: mask_out !< Output mask that specifies whether - !! data was computed. mask_out will be computed only when - !! horiz_interp_conserve_new_1d is called. mask_out will be computed in - !! horiz_interp_conserve_new_2d - - ! --- error checking --- - if (size(data_in,1) /= Interp%nlon_src .or. size(data_in,2) /= Interp%nlat_src) & - call mpp_error(FATAL, 'horiz_interp_conserve_mod: size of input array incorrect') - - if (size(data_out,1) /= Interp%nlon_dst .or. size(data_out,2) /= Interp%nlat_dst) & - call mpp_error(FATAL, 'horiz_interp_conserve_mod: size of output array incorrect') - - select case ( Interp%version) - case (1) - call horiz_interp_conserve_version1(Interp, data_in, data_out, verbose, mask_in, mask_out) - case (2) - if(present(mask_in) .OR. present(mask_out) ) call mpp_error(FATAL, 'horiz_interp_conserve:'// & - & ' for version 2, mask_in and mask_out must be passed in horiz_interp_new, not in horiz_interp') - call horiz_interp_conserve_version2(Interp, data_in, data_out, verbose) - end select - - end subroutine horiz_interp_conserve - - !############################################################################## - subroutine horiz_interp_conserve_version1 ( Interp, data_in, data_out, verbose, & - mask_in, mask_out) - !----------------------------------------------------------------------- - type (horiz_interp_type), intent(in) :: Interp - real, intent(in), dimension(:,:) :: data_in - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(out), dimension(:,:), optional :: mask_out - !----------local variables---------------------------------------------------- - integer :: m, n, nlon_in, nlat_in, nlon_out, nlat_out, & - miss_in, miss_out, is, ie, js, je, & - np, npass, iverbose - real :: dsum, wsum, avg_in, min_in, max_in, & - avg_out, min_out, max_out, eps, asum, & - dwtsum, wtsum, arsum, fis, fie, fjs, fje - !----------------------------------------------------------------------- - iverbose = 0; if (present(verbose)) iverbose = verbose - - eps = epsilon(wtsum) - - nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src - nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst - - if (present(mask_in)) then - if ( count(mask_in < -.0001 .or. mask_in > 1.0001) > 0 ) & - call mpp_error(FATAL, 'horiz_interp_conserve_mod: input mask not between 0,1') - endif - - !----------------------------------------------------------------------- - !---- loop through output grid boxes ---- - - data_out = 0.0 - do n = 1, nlat_out - ! latitude window - ! setup ascending latitude indices and weights - if (Interp%jlat(n,1) <= Interp%jlat(n,2)) then - js = Interp%jlat(n,1); je = Interp%jlat(n,2) - fjs = Interp%facj(n,1); fje = Interp%facj(n,2) - else - js = Interp%jlat(n,2); je = Interp%jlat(n,1) - fjs = Interp%facj(n,2); fje = Interp%facj(n,1) - endif - - do m = 1, nlon_out - ! longitude window - is = Interp%ilon(m,1); ie = Interp%ilon(m,2) - fis = Interp%faci(m,1); fie = Interp%faci(m,2) - npass = 1 - dwtsum = 0. - wtsum = 0. - arsum = 0. - - ! wrap-around on input grid - ! sum using 2 passes (pass 1: end of input grid) - if ( ie < is ) then - ie = nlon_in - fie = 1.0 - npass = 2 - endif - - do np = 1, npass - ! pass 2: beginning of input grid - if ( np == 2 ) then - is = 1 - fis = 1.0 - ie = Interp%ilon(m,2) - fie = Interp%faci(m,2) - endif - - ! summing data*weight and weight for single grid point - if (present(mask_in)) then - call data_sum ( data_in(is:ie,js:je), Interp%area_src(is:ie,js:je), & - fis, fie, fjs,fje, dwtsum, wtsum, arsum, mask_in(is:ie,js:je) ) - else if( allocated(Interp%mask_in) ) then - call data_sum ( data_in(is:ie,js:je), Interp%area_src(is:ie,js:je), & - fis, fie, fjs,fje, dwtsum, wtsum, arsum, Interp%mask_in(is:ie,js:je) ) - else - call data_sum ( data_in(is:ie,js:je), Interp%area_src(is:ie,js:je), & - fis, fie, fjs,fje, dwtsum, wtsum, arsum ) - endif - enddo - - if (wtsum > eps) then - data_out(m,n) = dwtsum/wtsum - if (present(mask_out)) mask_out(m,n) = wtsum/arsum - else - data_out(m,n) = 0. - if (present(mask_out)) mask_out(m,n) = 0.0 - endif - - enddo - enddo - - !*********************************************************************** - ! compute statistics: minimum, maximum, and mean - !----------------------------------------------------------------------- - - if (iverbose > 0) then - - ! compute statistics of input data - - call stats(data_in, Interp%area_src, asum, dsum, wsum, min_in, max_in, miss_in, mask_in) - ! diagnostic messages - ! on the root_pe, we can calculate the global mean, minimum and maximum. - if(pe == root_pe) then - if (wsum > 0.0) then - avg_in=dsum/wsum - else - print *, 'horiz_interp stats: input area equals zero ' - avg_in=0.0 - endif - if (iverbose > 1) print '(2f16.11)', 'global sum area_in = ', asum, wsum - endif - - ! compute statistics of output data - call stats(data_out, Interp%area_dst, asum, dsum, wsum, min_out, max_out, miss_out, mask_out) - ! diagnostic messages - if(pe == root_pe) then - if (wsum > 0.0) then - avg_out=dsum/wsum - else - print *, 'horiz_interp stats: output area equals zero ' - avg_out=0.0 - endif - if (iverbose > 1) print '(2f16.11)', 'global sum area_out = ', asum, wsum - endif - !---- output statistics ---- - ! the global mean, min and max are calculated on the root pe. - if(pe == root_pe) then - write (*,900) - write (*,901) min_in ,max_in ,avg_in - if (present(mask_in)) write (*,903) miss_in - write (*,902) min_out,max_out,avg_out - if (present(mask_out)) write (*,903) miss_out - endif - -900 format (/,1x,10('-'),' output from horiz_interp ',10('-')) -901 format (' input: min=',f16.9,' max=',f16.9,' avg=',f22.15) -902 format (' output: min=',f16.9,' max=',f16.9,' avg=',f22.15) -903 format (' number of missing points = ',i6) - - endif - - !----------------------------------------------------------------------- - end subroutine horiz_interp_conserve_version1 - - !############################################################################# - subroutine horiz_interp_conserve_version2 ( Interp, data_in, data_out, verbose ) - !----------------------------------------------------------------------- - type (horiz_interp_type), intent(in) :: Interp - real, intent(in), dimension(:,:) :: data_in - real, intent(out), dimension(:,:) :: data_out - integer, intent(in), optional :: verbose - integer :: i, i_src, j_src, i_dst, j_dst - - data_out = 0.0 - do i = 1, Interp%nxgrid - i_src = Interp%i_src(i); j_src = Interp%j_src(i) - i_dst = Interp%i_dst(i); j_dst = Interp%j_dst(i) - data_out(i_dst, j_dst) = data_out(i_dst, j_dst) + data_in(i_src,j_src)*Interp%area_frac_dst(i) - end do - - end subroutine horiz_interp_conserve_version2 - - !####################################################################### - - !> Deallocates memory used by "horiz_interp_type" variables. + !> Deallocates memory used by "HI_KIND_TYPE" variables. !! Must be called before reinitializing with horiz_interp_new. subroutine horiz_interp_conserve_del ( Interp ) @@ -924,134 +165,45 @@ subroutine horiz_interp_conserve_del ( Interp ) select case(Interp%version) case (1) - if(allocated(Interp%area_src)) deallocate(Interp%area_src) - if(allocated(Interp%area_dst)) deallocate(Interp%area_dst) - if(allocated(Interp%facj)) deallocate(Interp%facj) - if(allocated(Interp%jlat)) deallocate(Interp%jlat) - if(allocated(Interp%faci)) deallocate(Interp%faci) - if(allocated(Interp%ilon)) deallocate(Interp%ilon) + if( Interp%horizInterpReals8_type%is_allocated) then + if(allocated(Interp%horizInterpReals8_type%area_src)) deallocate(Interp%horizInterpReals8_type%area_src) + if(allocated(Interp%horizInterpReals8_type%area_dst)) deallocate(Interp%horizInterpReals8_type%area_dst) + if(allocated(Interp%horizInterpReals8_type%facj)) deallocate(Interp%horizInterpReals8_type%facj) + if(allocated(Interp%jlat)) deallocate(Interp%jlat) + if(allocated(Interp%horizInterpReals8_type%faci)) deallocate(Interp%horizInterpReals8_type%faci) + if(allocated(Interp%ilon)) deallocate(Interp%ilon) + else if( Interp%horizInterpReals4_type%is_allocated) then + if(allocated(Interp%horizInterpReals4_type%area_src)) deallocate(Interp%horizInterpReals4_type%area_src) + if(allocated(Interp%horizInterpReals4_type%area_dst)) deallocate(Interp%horizInterpReals4_type%area_dst) + if(allocated(Interp%horizInterpReals4_type%facj)) deallocate(Interp%horizInterpReals4_type%facj) + if(allocated(Interp%jlat)) deallocate(Interp%jlat) + if(allocated(Interp%horizInterpReals4_type%faci)) deallocate(Interp%horizInterpReals4_type%faci) + if(allocated(Interp%ilon)) deallocate(Interp%ilon) + endif case (2) - if(allocated(Interp%i_src)) deallocate(Interp%i_src) - if(allocated(Interp%j_src)) deallocate(Interp%j_src) - if(allocated(Interp%i_dst)) deallocate(Interp%i_dst) - if(allocated(Interp%j_dst)) deallocate(Interp%j_dst) - if(allocated(Interp%area_frac_dst)) deallocate(Interp%area_frac_dst) + if( Interp%horizInterpReals8_type%is_allocated) then + if(allocated(Interp%i_src)) deallocate(Interp%i_src) + if(allocated(Interp%j_src)) deallocate(Interp%j_src) + if(allocated(Interp%i_dst)) deallocate(Interp%i_dst) + if(allocated(Interp%j_dst)) deallocate(Interp%j_dst) + if(allocated(Interp%horizInterpReals8_type%area_frac_dst)) & + deallocate(Interp%horizInterpReals8_type%area_frac_dst) + else if( Interp%horizInterpReals4_type%is_allocated ) then + if(allocated(Interp%i_src)) deallocate(Interp%i_src) + if(allocated(Interp%j_src)) deallocate(Interp%j_src) + if(allocated(Interp%i_dst)) deallocate(Interp%i_dst) + if(allocated(Interp%j_dst)) deallocate(Interp%j_dst) + if(allocated(Interp%horizInterpReals4_type%area_frac_dst)) & + deallocate(Interp%horizInterpReals4_type%area_frac_dst) + endif end select + Interp%horizInterpReals4_type%is_allocated = .false. + Interp%horizInterpReals8_type%is_allocated = .false. end subroutine horiz_interp_conserve_del - !####################################################################### - !> This statistics is for conservative scheme - subroutine stats ( dat, area, asum, dsum, wsum, low, high, miss, mask ) - real, intent(in) :: dat(:,:), area(:,:) - real, intent(out) :: asum, dsum, wsum, low, high - integer, intent(out) :: miss - real, intent(in), optional :: mask(:,:) - - integer :: pe, root_pe, npes, p, buffer_int(1) - real :: buffer_real(5) - - pe = mpp_pe() - root_pe = mpp_root_pe() - npes = mpp_npes() - - ! sum data, data*area; and find min,max on each pe. - - if (present(mask)) then - asum = sum(area(:,:)) - dsum = sum(area(:,:)*dat(:,:)*mask(:,:)) - wsum = sum(area(:,:)*mask(:,:)) - miss = count(mask(:,:) <= 0.5) - low = minval(dat(:,:),mask=mask(:,:) > 0.5) - high = maxval(dat(:,:),mask=mask(:,:) > 0.5) - else - asum = sum(area(:,:)) - dsum = sum(area(:,:)*dat(:,:)) - wsum = sum(area(:,:)) - miss = 0 - low = minval(dat(:,:)) - high = maxval(dat(:,:)) - endif - - ! other pe send local min, max, avg to the root pe and - ! root pe receive these information - - if(pe == root_pe) then - do p = 1, npes - 1 - ! Force use of "scalar", integer pointer mpp interface - call mpp_recv(buffer_real(1),glen=5,from_pe=root_pe+p, tag=COMM_TAG_1) - asum = asum + buffer_real(1) - dsum = dsum + buffer_real(2) - wsum = wsum + buffer_real(3) - low = min(low, buffer_real(4)) - high = max(high, buffer_real(5)) - call mpp_recv(buffer_int(1),glen=1,from_pe=root_pe+p, tag=COMM_TAG_2) - miss = miss + buffer_int(1) - enddo - else - buffer_real(1) = asum - buffer_real(2) = dsum - buffer_real(3) = wsum - buffer_real(4) = low - buffer_real(5) = high - ! Force use of "scalar", integer pointer mpp interface - call mpp_send(buffer_real(1),plen=5,to_pe=root_pe, tag=COMM_TAG_1) - buffer_int(1) = miss - call mpp_send(buffer_int(1),plen=1,to_pe=root_pe, tag=COMM_TAG_2) - endif - - call mpp_sync_self() - - end subroutine stats - - !####################################################################### - - !> sums up the data and weights for a single output grid box - subroutine data_sum( data, area, facis, facie, facjs, facje, & - dwtsum, wtsum, arsum, mask ) - - !----------------------------------------------------------------------- - real, intent(in), dimension(:,:) :: data, area - real, intent(in) :: facis, facie, facjs, facje - real, intent(inout) :: dwtsum, wtsum, arsum - real, intent(in), optional :: mask(:,:) - - ! fac__ = fractional portion of each boundary grid box included - ! in the integral - ! dwtsum = sum(data*area*mask) - ! wtsum = sum(area*mask) - ! arsum = sum(area) - !----------------------------------------------------------------------- - real, dimension(size(area,1),size(area,2)) :: wt - real :: asum - integer :: id, jd - !----------------------------------------------------------------------- - - id=size(area,1); jd=size(area,2) - - wt=area - wt( 1,:)=wt( 1,:)*facis - wt(id,:)=wt(id,:)*facie - wt(:, 1)=wt(:, 1)*facjs - wt(:,jd)=wt(:,jd)*facje - - asum = sum(wt) - arsum = arsum + asum - - if (present(mask)) then - wt = wt * mask - dwtsum = dwtsum + sum(wt*data) - wtsum = wtsum + sum(wt) - else - dwtsum = dwtsum + sum(wt*data) - wtsum = wtsum + asum - endif - !----------------------------------------------------------------------- - - end subroutine data_sum - - - !####################################################################### +#include "horiz_interp_conserve_r4.fh" +#include "horiz_interp_conserve_r8.fh" end module horiz_interp_conserve_mod !> @} diff --git a/horiz_interp/horiz_interp_spherical.F90 b/horiz_interp/horiz_interp_spherical.F90 index 8a00ea9b76..128b7fd47d 100644 --- a/horiz_interp/horiz_interp_spherical.F90 +++ b/horiz_interp/horiz_interp_spherical.F90 @@ -29,6 +29,7 @@ !> @{ module horiz_interp_spherical_mod + use platform_mod, only : r4_kind, r8_kind use mpp_mod, only : mpp_error, FATAL, WARNING, stdout use mpp_mod, only : mpp_root_pe, mpp_pe use mpp_mod, only : input_nml_file @@ -40,15 +41,45 @@ module horiz_interp_spherical_mod implicit none private + interface horiz_interp_spherical + module procedure horiz_interp_spherical_r4 + module procedure horiz_interp_spherical_r8 + end interface + + interface horiz_interp_spherical_new + module procedure horiz_interp_spherical_new_r4 + module procedure horiz_interp_spherical_new_r8 + end interface + + interface horiz_interp_spherical_wght + module procedure horiz_interp_spherical_wght_r4 + module procedure horiz_interp_spherical_wght_r8 + end interface public :: horiz_interp_spherical_new, horiz_interp_spherical, horiz_interp_spherical_del public :: horiz_interp_spherical_init, horiz_interp_spherical_wght + !> private helper routines + interface full_search + module procedure full_search_r4 + module procedure full_search_r8 + end interface + + interface radial_search + module procedure radial_search_r4 + module procedure radial_search_r8 + end interface + + interface spherical_distance + module procedure spherical_distance_r4 + module procedure spherical_distance_r8 + end interface + integer, parameter :: max_neighbors = 400 - real, parameter :: max_dist_default = 0.1 ! radians + real(R8_KIND), parameter :: max_dist_default = 0.1_r8_kind ! radians integer, parameter :: num_nbrs_default = 4 - real, parameter :: large=1.e20 - real, parameter :: epsln=1.e-10 + real(R8_KIND), parameter :: large=1.e20_r8_kind + real(R8_KIND), parameter :: epsln=1.e-10_r8_kind integer :: pe, root_pe @@ -87,414 +118,13 @@ subroutine horiz_interp_spherical_init read (input_nml_file, horiz_interp_spherical_nml, iostat=io) ierr = check_nml_error(io,'horiz_interp_spherical_nml') - module_is_initialized = .true. - - - -end subroutine horiz_interp_spherical_init - - !####################################################################### - - !> Initialization routine. - !! - !> Allocates space and initializes a derived-type variable - !! that contains pre-computed interpolation indices and weights. - subroutine horiz_interp_spherical_new(Interp, lon_in,lat_in,lon_out,lat_out, & - num_nbrs, max_dist, src_modulo) - - type(horiz_interp_type), intent(inout) :: Interp !< A derived type variable containing indices - !! and weights for subsequent interpolations. To - !! reinitialize for different grid-to-grid interpolation - !! @ref horiz_interp_del must be used first. - real, intent(in), dimension(:,:) :: lon_in !< Latitude (radians) for source data grid - real, intent(in), dimension(:,:) :: lat_in !< Longitude (radians) for source data grid - real, intent(in), dimension(:,:) :: lon_out !< Longitude (radians) for output data grid - real, intent(in), dimension(:,:) :: lat_out !< Latitude (radians) for output data grid - logical, intent(in), optional :: src_modulo !< indicates if the boundary condition - !! along zonal boundary is cyclic or not. Cyclic when true - integer, intent(in), optional :: num_nbrs !< Number of nearest neighbors for regridding - !! When number of neighbors within the radius max_dist - !! is less than num_nbrs, All the neighbors will be used - !! to interpolate onto destination grid. when number of - !! neighbors within the radius max_dist is greater than - !! num_nbrs, at least "num_nbrs" - ! neighbors will be used to remap onto destination grid - real, optional, intent(in) :: max_dist !< Maximum region of influence around - !! destination grid points - - !------local variables --------------------------------------- - integer :: i, j, n - integer :: map_dst_xsize, map_dst_ysize, map_src_xsize, map_src_ysize - integer :: map_src_size, num_neighbors - real :: max_src_dist, tpi, hpi - logical :: src_is_modulo - real :: min_theta_dst, max_theta_dst, min_phi_dst, max_phi_dst - real :: min_theta_src, max_theta_src, min_phi_src, max_phi_src - integer :: map_src_add(size(lon_out,1),size(lon_out,2),max_neighbors) - real :: map_src_dist(size(lon_out,1),size(lon_out,2),max_neighbors) - integer :: num_found(size(lon_out,1),size(lon_out,2)) - integer :: ilon(max_neighbors), jlat(max_neighbors) - real, dimension(size(lon_out,1),size(lon_out,2)) :: theta_dst, phi_dst - real, dimension(size(lon_in,1)*size(lon_in,2)) :: theta_src, phi_src - - !-------------------------------------------------------------- - - pe = mpp_pe() - root_pe = mpp_root_pe() - - tpi = 2.0*PI; hpi = 0.5*PI - - num_neighbors = num_nbrs_default - if(present(num_nbrs)) num_neighbors = num_nbrs - if (num_neighbors <= 0) call mpp_error(FATAL,'horiz_interp_spherical_mod: num_neighbors must be > 0') - - max_src_dist = max_dist_default - if (PRESENT(max_dist)) max_src_dist = max_dist - Interp%max_src_dist = max_src_dist - - src_is_modulo = .true. - if (PRESENT(src_modulo)) src_is_modulo = src_modulo - - !--- check the grid size comformable - map_dst_xsize=size(lon_out,1);map_dst_ysize=size(lon_out,2) - map_src_xsize=size(lon_in,1); map_src_ysize=size(lon_in,2) - map_src_size = map_src_xsize*map_src_ysize - - if (map_dst_xsize /= size(lat_out,1) .or. map_dst_ysize /= size(lat_out,2)) & - call mpp_error(FATAL,'horiz_interp_spherical_mod: destination grids not conformable') - if (map_src_xsize /= size(lat_in,1) .or. map_src_ysize /= size(lat_in,2)) & - call mpp_error(FATAL,'horiz_interp_spherical_mod: source grids not conformable') - - theta_src = reshape(lon_in,(/map_src_size/)) - phi_src = reshape(lat_in,(/map_src_size/)) - theta_dst(:,:) = lon_out(:,:) - phi_dst(:,:) = lat_out(:,:) - - min_theta_dst=tpi;max_theta_dst=0.0;min_phi_dst=pi;max_phi_dst=-pi - min_theta_src=tpi;max_theta_src=0.0;min_phi_src=pi;max_phi_src=-pi - - where(theta_dst<0.0) theta_dst = theta_dst+tpi - where(theta_dst>tpi) theta_dst = theta_dst-tpi - where(theta_src<0.0) theta_src = theta_src+tpi - where(theta_src>tpi) theta_src = theta_src-tpi - - where(phi_dst < -hpi) phi_dst = -hpi - where(phi_dst > hpi) phi_dst = hpi - where(phi_src < -hpi) phi_src = -hpi - where(phi_src > hpi) phi_src = hpi - - do j=1,map_dst_ysize - do i=1,map_dst_xsize - min_theta_dst = min(min_theta_dst,theta_dst(i,j)) - max_theta_dst = max(max_theta_dst,theta_dst(i,j)) - min_phi_dst = min(min_phi_dst,phi_dst(i,j)) - max_phi_dst = max(max_phi_dst,phi_dst(i,j)) - enddo - enddo - - do i=1,map_src_size - min_theta_src = min(min_theta_src,theta_src(i)) - max_theta_src = max(max_theta_src,theta_src(i)) - min_phi_src = min(min_phi_src,phi_src(i)) - max_phi_src = max(max_phi_src,phi_src(i)) - enddo - - if (min_phi_dst < min_phi_src) print *, '=> WARNING: latitute of dest grid exceeds src' - if (max_phi_dst > max_phi_src) print *, '=> WARNING: latitute of dest grid exceeds src' - ! when src is cyclic, no need to print out the following warning. - if(.not. src_is_modulo) then - if (min_theta_dst < min_theta_src) print *, '=> WARNING : longitude of dest grid exceeds src' - if (max_theta_dst > max_theta_src) print *, '=> WARNING : longitude of dest grid exceeds src' - endif - - ! allocate memory to data type - if(allocated(Interp%i_lon)) then - if(size(Interp%i_lon,1) .NE. map_dst_xsize .OR. & - size(Interp%i_lon,2) .NE. map_dst_ysize ) call mpp_error(FATAL, & - 'horiz_interp_spherical_mod: size(Interp%i_lon(:),1) .NE. map_dst_xsize .OR. '// & - 'size(Interp%i_lon(:),2) .NE. map_dst_ysize') - else - allocate(Interp%i_lon(map_dst_xsize,map_dst_ysize,max_neighbors), & - Interp%j_lat(map_dst_xsize,map_dst_ysize,max_neighbors), & - Interp%src_dist(map_dst_xsize,map_dst_ysize,max_neighbors), & - Interp%num_found(map_dst_xsize,map_dst_ysize) ) - endif - - map_src_add = 0 - map_src_dist = large - num_found = 0 - - !using radial_search to find the nearest points and corresponding distance. - - select case(trim(search_method)) - case ("radial_search") ! will be efficient, but may be not so accurate for some cases - call radial_search(theta_src, phi_src, theta_dst, phi_dst, map_src_xsize, map_src_ysize, & - map_src_add, map_src_dist, num_found, num_neighbors,max_src_dist,src_is_modulo) - case ("full_search") ! always accurate, but less efficient. - call full_search(theta_src, phi_src, theta_dst, phi_dst, map_src_add, map_src_dist, & - num_found, num_neighbors,max_src_dist ) - case default - call mpp_error(FATAL,"horiz_interp_spherical_new: nml search_method = "// & - trim(search_method)//" is not a valid namelist option") - end select - - do j=1,map_dst_ysize - do i=1,map_dst_xsize - do n=1,num_found(i,j) - if(map_src_add(i,j,n) == 0) then - jlat(n) = 0; ilon(n) = 0 - else - jlat(n) = map_src_add(i,j,n)/map_src_xsize + 1 - ilon(n) = map_src_add(i,j,n) - (jlat(n)-1)*map_src_xsize - if(ilon(n) == 0) then - jlat(n) = jlat(n) - 1 - ilon(n) = map_src_xsize - endif - endif - enddo - Interp%i_lon(i,j,:) = ilon(:) - Interp%j_lat(i,j,:) = jlat(:) - Interp%num_found(i,j) = num_found(i,j) - Interp%src_dist(i,j,:) = map_src_dist(i,j,:) - enddo - enddo - - Interp%nlon_src = map_src_xsize; Interp%nlat_src = map_src_ysize - Interp%nlon_dst = map_dst_xsize; Interp%nlat_dst = map_dst_ysize - - return - - end subroutine horiz_interp_spherical_new - - !####################################################################### - - !> Subroutine for performing the horizontal interpolation between two grids. - !! horiz_interp_spherical_new must be called before calling this routine. - subroutine horiz_interp_spherical( Interp, data_in, data_out, verbose, mask_in, mask_out, missing_value) - type(horiz_interp_type), intent(in) :: Interp !< A derived type variable containing indices - !! and weights for subsequent interpolations. Returned - !! by a previous call to horiz_interp_spherical_new - real, intent(in), dimension(:,:) :: data_in !< Input data on source grid - real, intent(out), dimension(:,:) :: data_out !< Output data on destination grid - integer, intent(in), optional :: verbose !< 0 = no output; 1 = min,max,means; 2 = most output - real, intent(in), dimension(:,:), optional :: mask_in !< Input mask, must be the same size as - !! the input data. The real value of mask_in must be - !! in the range (0.,1.). Set mask_in=0.0 for data points - !! that should not be used or have missing data - real, intent(out), dimension(:,:), optional :: mask_out !< Output mask that specifies whether data was computed. - real, intent(in), optional :: missing_value !< Used to indicate missing data - - !--- some local variables ---------------------------------------- - real, dimension(Interp%nlon_dst, Interp%nlat_dst,size(Interp%src_dist,3)) :: wt - real, dimension(Interp%nlon_src, Interp%nlat_src) :: mask_src - real, dimension(Interp%nlon_dst, Interp%nlat_dst) :: mask_dst - integer :: nlon_in, nlat_in, nlon_out, nlat_out, num_found - integer :: m, n, i, j, k, miss_in, miss_out, i1, i2, j1, j2, iverbose - real :: min_in, max_in, avg_in, min_out, max_out, avg_out, sum - !----------------------------------------------------------------- - - iverbose = 0; if (present(verbose)) iverbose = verbose - - nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src - nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst - - if(size(data_in,1) .ne. nlon_in .or. size(data_in,2) .ne. nlat_in ) & - call mpp_error(FATAL,'horiz_interp_spherical_mod: size of input array incorrect') - - if(size(data_out,1) .ne. nlon_out .or. size(data_out,2) .ne. nlat_out ) & - call mpp_error(FATAL,'horiz_interp_spherical_mod: size of output array incorrect') - - mask_src = 1.0; mask_dst = 1.0 - if(present(mask_in)) mask_src = mask_in - - do n=1,nlat_out - do m=1,nlon_out - ! neighbors are sorted nearest to farthest - ! check nearest to see if it is a land point - num_found = Interp%num_found(m,n) - if(num_found == 0 ) then - mask_dst(m,n) = 0.0 - else - i1 = Interp%i_lon(m,n,1); j1 = Interp%j_lat(m,n,1) - if (mask_src(i1,j1) .lt. 0.5) then - mask_dst(m,n) = 0.0 - endif - - if(num_found .gt. 1 ) then - i2 = Interp%i_lon(m,n,2); j2 = Interp%j_lat(m,n,2) - ! compare first 2 nearest neighbors -- if they are nearly - ! equidistant then use this mask for robustness - if(abs(Interp%src_dist(m,n,2)-Interp%src_dist(m,n,1)) .lt. epsln) then - if((mask_src(i1,j1) .lt. 0.5)) mask_dst(m,n) = 0.0 - endif - endif - - sum=0.0 - do k=1, num_found - if(mask_src(Interp%i_lon(m,n,k),Interp%j_lat(m,n,k)) .lt. 0.5 ) then - wt(m,n,k) = 0.0 - else - if (Interp%src_dist(m,n,k) <= epsln) then - wt(m,n,k) = large - sum = sum + large - else if(Interp%src_dist(m,n,k) <= Interp%max_src_dist ) then - wt(m,n,k) = 1.0/Interp%src_dist(m,n,k) - sum = sum+wt(m,n,k) - else - wt(m,n,k) = 0.0 - endif - endif - enddo - if (sum > epsln) then - do k = 1, num_found - wt(m,n,k) = wt(m,n,k)/sum - enddo - else - mask_dst(m,n) = 0.0 - endif - endif - enddo - enddo - - data_out = 0.0 - do n=1,nlat_out - do m=1,nlon_out - if(mask_dst(m,n) .gt. 0.5) then - do k=1, Interp%num_found(m,n) - i = Interp%i_lon(m,n,k) - j = Interp%j_lat(m,n,k) - data_out(m,n) = data_out(m,n)+data_in(i,j)*wt(m,n,k) - enddo - else - if(present(missing_value)) then - data_out(m,n) = missing_value - else - data_out(m,n) = 0.0 - endif - endif - enddo - enddo - - if(present(mask_out)) mask_out = mask_dst - - !*********************************************************************** - ! compute statistics: minimum, maximum, and mean - !----------------------------------------------------------------------- - - if (iverbose > 0) then - - ! compute statistics of input data - - call stats (data_in, min_in, max_in, avg_in, miss_in, missing_value, mask=mask_src) - - ! compute statistics of output data - call stats (data_out, min_out, max_out, avg_out, miss_out, missing_value, mask=mask_dst) - - !---- output statistics ---- - ! root_pe have the information of global mean, min and max - if(pe == root_pe) then - write (*,900) - write (*,901) min_in ,max_in, avg_in - if (present(mask_in)) write (*,903) miss_in - write (*,902) min_out,max_out,avg_out - if (present(mask_out)) write (*,903) miss_out - endif -900 format (/,1x,10('-'),' output from horiz_interp ',10('-')) -901 format (' input: min=',f16.9,' max=',f16.9,' avg=',f22.15) -902 format (' output: min=',f16.9,' max=',f16.9,' avg=',f22.15) -903 format (' number of missing points = ',i6) - - endif - - return - end subroutine horiz_interp_spherical + module_is_initialized = .true. - !####################################################################### - subroutine horiz_interp_spherical_wght( Interp, wt, verbose, mask_in, mask_out, missing_value) - type (horiz_interp_type), intent(in) :: Interp - real, intent(out), dimension(:,:,:) :: wt - integer, intent(in), optional :: verbose - real, intent(in), dimension(:,:), optional :: mask_in - real, intent(inout), dimension(:,:), optional :: mask_out - real, intent(in), optional :: missing_value - - !--- some local variables ---------------------------------------- - real, dimension(Interp%nlon_src, Interp%nlat_src) :: mask_src - real, dimension(Interp%nlon_dst, Interp%nlat_dst) :: mask_dst - integer :: nlon_in, nlat_in, nlon_out, nlat_out, num_found - integer :: m, n, k, i1, i2, j1, j2, iverbose - real :: sum - !----------------------------------------------------------------- - - iverbose = 0; if (present(verbose)) iverbose = verbose - - nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src - nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst - - mask_src = 1.0; mask_dst = 1.0 - if(present(mask_in)) mask_src = mask_in - - do n=1,nlat_out - do m=1,nlon_out - ! neighbors are sorted nearest to farthest - ! check nearest to see if it is a land point - num_found = Interp%num_found(m,n) - - if (num_found > num_nbrs_default) then - print*,'pe=',mpp_pe(),'num_found=',num_found - num_found = num_nbrs_default - end if - - if(num_found == 0 ) then - mask_dst(m,n) = 0.0 - else - i1 = Interp%i_lon(m,n,1); j1 = Interp%j_lat(m,n,1) - if (mask_src(i1,j1) .lt. 0.5) then - mask_dst(m,n) = 0.0 - endif - - if(num_found .gt. 1 ) then - i2 = Interp%i_lon(m,n,2); j2 = Interp%j_lat(m,n,2) - ! compare first 2 nearest neighbors -- if they are nearly - ! equidistant then use this mask for robustness - if(abs(Interp%src_dist(m,n,2)-Interp%src_dist(m,n,1)) .lt. epsln) then - if((mask_src(i1,j1) .lt. 0.5)) mask_dst(m,n) = 0.0 - endif - endif - - sum=0.0 - do k=1, num_found - if(mask_src(Interp%i_lon(m,n,k),Interp%j_lat(m,n,k)) .lt. 0.5 ) then - wt(m,n,k) = 0.0 - else - if (Interp%src_dist(m,n,k) <= epsln) then - wt(m,n,k) = large - sum = sum + large - else if(Interp%src_dist(m,n,k) <= Interp%max_src_dist ) then - wt(m,n,k) = 1.0/Interp%src_dist(m,n,k) - sum = sum+wt(m,n,k) - else - wt(m,n,k) = 0.0 - endif - endif - enddo - if (sum > epsln) then - do k = 1, num_found - wt(m,n,k) = wt(m,n,k)/sum - enddo - else - mask_dst(m,n) = 0.0 - endif - endif - enddo - enddo - - return - end subroutine horiz_interp_spherical_wght + end subroutine horiz_interp_spherical_init !####################################################################### - !> Deallocates memory used by "horiz_interp_type" variables. + !> Deallocates memory used by "HI_KIND_TYPE" variables. !! Must be called before reinitializing with horiz_interp_spherical_new. subroutine horiz_interp_spherical_del( Interp ) @@ -503,401 +133,24 @@ subroutine horiz_interp_spherical_del( Interp ) !! must have allocated arrays. The returned variable will !! contain deallocated arrays. - if(allocated(Interp%src_dist)) deallocate(Interp%src_dist) + if(Interp%horizInterpReals4_type%is_allocated) then + if(allocated(Interp%horizInterpReals4_type%src_dist)) deallocate(Interp%horizInterpReals4_type%src_dist) + else if (Interp%horizInterpReals8_type%is_allocated) then + if(allocated(Interp%horizInterpReals8_type%src_dist)) deallocate(Interp%horizInterpReals8_type%src_dist) + endif if(allocated(Interp%num_found)) deallocate(Interp%num_found) if(allocated(Interp%i_lon)) deallocate(Interp%i_lon) if(allocated(Interp%j_lat)) deallocate(Interp%j_lat) - end subroutine horiz_interp_spherical_del - - !####################################################################### - - subroutine radial_search(theta_src,phi_src,theta_dst,phi_dst, map_src_xsize, map_src_ysize, & - map_src_add, map_src_dist, num_found, num_neighbors,max_src_dist,src_is_modulo) - real, intent(in), dimension(:) :: theta_src, phi_src - real, intent(in), dimension(:,:) :: theta_dst, phi_dst - integer, intent(in) :: map_src_xsize, map_src_ysize - integer, intent(out), dimension(:,:,:) :: map_src_add - real, intent(out), dimension(:,:,:) :: map_src_dist - integer, intent(inout), dimension(:,:) :: num_found - integer, intent(in) :: num_neighbors - real, intent(in) :: max_src_dist - logical, intent(in) :: src_is_modulo - - !---------- local variables ---------------------------------------- - integer, parameter :: max_nbrs = 50 - integer :: i, j, jj, i0, j0, n, l,i_left, i_right - integer :: map_dst_xsize, map_dst_ysize - integer :: i_left1, i_left2, i_right1, i_right2 - integer :: map_src_size, step, step_size, bound, bound_start, bound_end - logical :: continue_search, result, continue_radial_search - real :: d, res - !------------------------------------------------------------------ - map_dst_xsize=size(theta_dst,1);map_dst_ysize=size(theta_dst,2) - map_src_size = map_src_xsize*map_src_ysize - - do j=1,map_dst_ysize - do i=1,map_dst_xsize - continue_search=.true. - step = 1 - step_size = int( sqrt(real(map_src_size) )) - do while (continue_search .and. step_size > 0) - do while (step <= map_src_size .and. continue_search) - ! count land points as nearest neighbors - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(step),phi_src(step)) - if (d <= max_src_dist) then - result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - step,d, num_found(i,j), num_neighbors ) - if (result) then - n = 0 - i0 = mod(step,map_src_xsize) - - if (i0 == 0) i0 = map_src_xsize - res = float(step)/float(map_src_xsize) - j0 = ceiling(res) - continue_radial_search = .true. - do while (continue_radial_search) - continue_radial_search = .false. - n = n+1 ! radial counter - if(n > max_nbrs) exit - ! ************** left boundary ******************************* - i_left = i0-n - if (i_left <= 0) then - if (src_is_modulo) then - i_left = map_src_xsize + i_left - else - i_left = 1 - endif - endif - - do l = 0, 2*n - jj = j0 - n - 1 + l - if( jj < 0) then - bound = ( 1 - jj )*map_src_xsize - i_left - else if ( jj >= map_src_ysize ) then - bound = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left - else - bound = jj * map_src_xsize + i_left - endif - - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound)) - if(d<=max_src_dist) then - result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - bound,d, num_found(i,j), num_neighbors) - if (result) continue_radial_search = .true. - endif - enddo - - ! ***************************right boundary ******************************* - i_right = i0+n - if (i_right > map_src_xsize) then - if (src_is_modulo) then - i_right = i_right - map_src_xsize - else - i_right = map_src_xsize - endif - endif - - do l = 0, 2*n - jj = j0 - n - 1 + l - if( jj < 0) then - bound = ( 1 - jj )*map_src_xsize - i_right - else if ( jj >= map_src_ysize ) then - bound = ( 2*map_src_ysize - jj) * map_src_xsize - i_right - - else - bound = jj * map_src_xsize + i_right - endif - - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound)) - if(d<=max_src_dist) then - result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - bound,d, num_found(i,j), num_neighbors) - if (result) continue_radial_search = .true. - endif - enddo - - ! ************************* bottom boundary ********************************** - i_left2 = 0 - if( i_left > i_right) then - i_left1 = 1 - i_right1 = i_right - i_left2 = i_left - i_right2 = map_src_xsize - else - i_left1 = i_left - i_right1 = i_right - endif - - jj = j0 - n - 1 - if( jj < 0 ) then - bound_start = ( 1 - jj)*map_src_xsize - i_right1 - bound_end = ( 1 - jj)*map_src_xsize - i_left1 - else - bound_start = jj * map_src_xsize + i_left1 - bound_end = jj * map_src_xsize + i_right1 - endif - - bound = bound_start - do while (bound <= bound_end) - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound)) - if(d<=max_src_dist) then - result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - bound,d, num_found(i,j), num_neighbors) - if (result) continue_radial_search = .true. - endif - bound = bound + 1 - - enddo - - if(i_left2 > 0 ) then - if( jj < 0 ) then - bound_start = ( 1 - jj)*map_src_xsize - i_right2 - bound_end = ( 1 - jj)*map_src_xsize - i_left2 - else - bound_start = jj * map_src_xsize + i_left2 - bound_end = jj * map_src_xsize + i_right2 - endif - - bound = bound_start - do while (bound <= bound_end) - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound)) - if(d<=max_src_dist) then - result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - bound,d, num_found(i,j), num_neighbors) - if (result) continue_radial_search = .true. - endif - bound = bound + 1 - enddo - endif - - ! ************************** top boundary ************************************ - jj = j0 + n - 1 - if( jj >= map_src_ysize) then - bound_start = ( 2*map_src_ysize - jj ) * map_src_xsize - i_right1 - bound_end = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left1 - else - bound_start = jj * map_src_xsize + i_left1 - bound_end = jj * map_src_xsize + i_right1 - endif - - bound = bound_start - do while (bound <= bound_end) - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound)) - if(d<=max_src_dist) then - result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - bound,d, num_found(i,j), num_neighbors) - if (result) continue_radial_search = .true. - endif - bound = bound + 1 - enddo - - if(i_left2 > 0) then - if( jj >= map_src_ysize) then - bound_start = ( 2*map_src_ysize - jj ) * map_src_xsize - i_right2 - bound_end = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left2 - else - bound_start = jj * map_src_xsize + i_left2 - bound_end = jj * map_src_xsize + i_right2 - endif - - bound = bound_start - do while (bound <= bound_end) - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound),phi_src(bound)) - if(d<=max_src_dist) then - result = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - bound,d, num_found(i,j), num_neighbors) - if (result) continue_radial_search = .true. - endif - bound = bound + 1 - enddo - endif - - enddo - continue_search = .false. ! stop looking - endif - endif - step=step+step_size - enddo ! search loop - step = 1 - step_size = step_size/2 - enddo - enddo - enddo - - return - - end subroutine radial_search - - - !##################################################################### - - function update_dest_neighbors(map_src_add, map_src_dist, src_add,d, num_found, min_nbrs) - - integer, intent(inout), dimension(:) :: map_src_add - real, intent(inout), dimension(:) :: map_src_dist - integer, intent(in) :: src_add - real, intent(in) :: d - integer, intent(inout) :: num_found - integer, intent(in) :: min_nbrs - - logical :: update_dest_neighbors, already_exist = .false. - - integer :: n,m - - update_dest_neighbors = .false. - - n = 0 - NLOOP : do while ( n .le. num_found ) - n = n + 1 - DIST_CHK : if (d .le. map_src_dist(n)) then - do m=n,num_found - if (src_add == map_src_add(m)) then - already_exist = .true. - exit NLOOP - endif - enddo - if(num_found < max_neighbors) then - num_found = num_found + 1 - else - call mpp_error(FATAL,'update_dest_neighbors: '// & - 'number of neighbor points found is greated than maxium neighbor points' ) - endif - do m=num_found,n+1,-1 - map_src_add(m) = map_src_add(m-1) - map_src_dist(m) = map_src_dist(m-1) - enddo - map_src_add(n) = src_add - map_src_dist(n) = d - update_dest_neighbors = .true. - if( num_found > min_nbrs ) then - if( map_src_dist(num_found) > map_src_dist(num_found-1) ) then - num_found = num_found - 1 - endif - if( map_src_dist(min_nbrs+1) > map_src_dist(min_nbrs) ) then - num_found = min_nbrs - endif - endif - exit NLOOP ! n loop - endif DIST_CHK - end do NLOOP - if(already_exist) return - - if( .not. update_dest_neighbors ) then - if( num_found < min_nbrs ) then - num_found = num_found + 1 - update_dest_neighbors = .true. - map_src_add(num_found) = src_add - map_src_dist(num_found) = d - endif - endif + Interp%horizInterpReals4_type%is_allocated = .false. + Interp%horizInterpReals8_type%is_allocated = .false. - - return - - end function update_dest_neighbors - - !######################################################################## -! function spherical_distance(theta1,phi1,theta2,phi2) - -! real, intent(in) :: theta1, phi1, theta2, phi2 -! real :: spherical_distance - -! real :: r1(3), r2(3), cross(3), s, dot, ang - - ! this is a simple, enough way to calculate distance on the sphere - ! first, construct cartesian vectors r1 and r2 - ! then calculate the cross-product which is proportional to the area - ! between the 2 vectors. The angular distance is arcsin of the - ! distancealong the sphere - ! - ! theta is longitude and phi is latitude - ! - - -! r1(1) = cos(theta1)*cos(phi1);r1(2)=sin(theta1)*cos(phi1);r1(3)=sin(phi1) -! r2(1) = cos(theta2)*cos(phi2);r2(2)=sin(theta2)*cos(phi2);r2(3)=sin(phi2) - -! cross(1) = r1(2)*r2(3)-r1(3)*r2(2) -! cross(2) = r1(3)*r2(1)-r1(1)*r2(3) -! cross(3) = r1(1)*r2(2)-r1(2)*r2(1) - -! s = sqrt(cross(1)**2.+cross(2)**2.+cross(3)**2.) - -! s = min(s,1.0-epsln) - -! dot = r1(1)*r2(1) + r1(2)*r2(2) + r1(3)*r2(3) - -! if (dot > 0) then -! ang = asin(s) -! else if (dot < 0) then -! ang = pi + asin(s) !? original is pi - asin(s) -! else -! ang = pi/2. -! endif - -! spherical_distance = abs(ang) ! in radians - -! return - -! end function spherical_distance - ! The great cycle distance - function spherical_distance(theta1,phi1,theta2,phi2) - - real, intent(in) :: theta1, phi1, theta2, phi2 - real :: spherical_distance, dot - - if(theta1 == theta2 .and. phi1 == phi2) then - spherical_distance = 0.0 - return - endif - - dot = cos(phi1)*cos(phi2)*cos(theta1-theta2) + sin(phi1)*sin(phi2) - if(dot > 1. ) dot = 1. - if(dot < -1.) dot = -1. - spherical_distance = acos(dot) - - return - - end function spherical_distance - - - !####################################################################### - - subroutine full_search(theta_src,phi_src,theta_dst,phi_dst,map_src_add, map_src_dist,num_found, & - num_neighbors,max_src_dist) - real, intent(in), dimension(:) :: theta_src, phi_src - real, intent(in), dimension(:,:) :: theta_dst, phi_dst - integer, intent(out), dimension(:,:,:) :: map_src_add - real, intent(out), dimension(:,:,:) :: map_src_dist - integer, intent(out), dimension(:,:) :: num_found - integer, intent(in) :: num_neighbors - real, intent(in) :: max_src_dist - - integer :: i,j,map_src_size, step - integer :: map_dst_xsize,map_dst_ysize - real :: d - logical :: found - - map_dst_xsize=size(theta_dst,1);map_dst_ysize=size(theta_dst,2) - map_src_size =size(theta_src(:)) - - do j=1,map_dst_ysize - do i=1,map_dst_xsize - do step = 1, map_src_size - d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(step),phi_src(step)) - if( d <= max_src_dist) then - found = update_dest_neighbors(map_src_add(i,j,:),map_src_dist(i,j,:), & - step,d,num_found(i,j), num_neighbors ) - endif - enddo - enddo - enddo - - end subroutine full_search + end subroutine horiz_interp_spherical_del !####################################################################### +#include "horiz_interp_spherical_r4.fh" +#include "horiz_interp_spherical_r8.fh" end module horiz_interp_spherical_mod !> @} diff --git a/horiz_interp/horiz_interp_type.F90 b/horiz_interp/horiz_interp_type.F90 index 634244a2f5..ec2773f860 100644 --- a/horiz_interp/horiz_interp_type.F90 +++ b/horiz_interp/horiz_interp_type.F90 @@ -29,6 +29,7 @@ module horiz_interp_type_mod use mpp_mod, only : mpp_send, mpp_recv, mpp_sync_self, mpp_error, FATAL use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes use mpp_mod, only : COMM_TAG_1, COMM_TAG_2 +use platform_mod, only: r4_kind, r8_kind implicit none private @@ -50,29 +51,80 @@ module horiz_interp_type_mod module procedure horiz_interp_type_eq end interface -! +!> @ingroup horiz_interp_type_mod +interface stats + module procedure stats_r4 + module procedure stats_r8 +end interface + + +!> real(8) pointers for use in horiz_interp_type +type horizInterpReals8_type + real(kind=r8_kind), dimension(:,:), allocatable :: faci !< weights for conservative scheme + real(kind=r8_kind), dimension(:,:), allocatable :: facj !< weights for conservative scheme + real(kind=r8_kind), dimension(:,:), allocatable :: area_src !< area of the source grid + real(kind=r8_kind), dimension(:,:), allocatable :: area_dst !< area of the destination grid + real(kind=r8_kind), dimension(:,:,:), allocatable :: wti !< weights for bilinear interpolation + !! wti ist used for derivative "weights" in bicubic + real(kind=r8_kind), dimension(:,:,:), allocatable :: wtj !< weights for bilinear interpolation + !! wti ist used for derivative "weights" in bicubic + real(kind=r8_kind), dimension(:,:,:), allocatable :: src_dist !< distance between destination grid and + !! neighbor source grid. + real(kind=r8_kind), dimension(:,:), allocatable :: rat_x !< the ratio of coordinates of the dest grid + !! (x_dest -x_src_r)/(x_src_l -x_src_r) + !! and (y_dest -y_src_r)/(y_src_l -y_src_r) + real(kind=r8_kind), dimension(:,:), allocatable :: rat_y !< the ratio of coordinates of the dest grid + !! (x_dest -x_src_r)/(x_src_l -x_src_r) + !! and (y_dest -y_src_r)/(y_src_l -y_src_r) + real(kind=r8_kind), dimension(:), allocatable :: lon_in !< the coordinates of the source grid + real(kind=r8_kind), dimension(:), allocatable :: lat_in !< the coordinates of the source grid + real(kind=r8_kind), dimension(:), allocatable :: area_frac_dst !< area fraction in destination grid. + real(kind=r8_kind), dimension(:,:), allocatable :: mask_in + real(kind=r8_kind) :: max_src_dist + logical :: is_allocated !< set to true upon field allocation + +end type horizInterpReals8_type + +!> holds real(4) pointers for use in horiz_interp_type +type horizInterpReals4_type + real(kind=r4_kind), dimension(:,:), allocatable :: faci !< weights for conservative scheme + real(kind=r4_kind), dimension(:,:), allocatable :: facj !< weights for conservative scheme + real(kind=r4_kind), dimension(:,:), allocatable :: area_src !< area of the source grid + real(kind=r4_kind), dimension(:,:), allocatable :: area_dst !< area of the destination grid + real(kind=r4_kind), dimension(:,:,:), allocatable :: wti !< weights for bilinear interpolation + !! wti ist used for derivative "weights" in bicubic + real(kind=r4_kind), dimension(:,:,:), allocatable :: wtj !< weights for bilinear interpolation + !! wti ist used for derivative "weights" in bicubic + real(kind=r4_kind), dimension(:,:,:), allocatable :: src_dist !< distance between destination grid and + !! neighbor source grid. + real(kind=r4_kind), dimension(:,:), allocatable :: rat_x !< the ratio of coordinates of the dest grid + !! (x_dest -x_src_r)/(x_src_l -x_src_r) + !! and (y_dest -y_src_r)/(y_src_l -y_src_r) + real(kind=r4_kind), dimension(:,:), allocatable :: rat_y !< the ratio of coordinates of the dest grid + !! (x_dest -x_src_r)/(x_src_l -x_src_r) + !! and (y_dest -y_src_r)/(y_src_l -y_src_r) + real(kind=r4_kind), dimension(:), allocatable :: lon_in !< the coordinates of the source grid + real(kind=r4_kind), dimension(:), allocatable :: lat_in !< the coordinates of the source grid + real(kind=r4_kind), dimension(:), allocatable :: area_frac_dst !< area fraction in destination grid. + real(kind=r4_kind), dimension(:,:), allocatable :: mask_in + real(kind=r4_kind) :: max_src_dist + logical :: is_allocated !< set to true upon field allocation + +end type horizInterpReals4_type + +!> Holds data pointers and metadata for horizontal interpolations, passed between the horiz_interp modules !> @ingroup horiz_interp_type_mod type horiz_interp_type - real, dimension(:,:), allocatable :: faci !< weights for conservative scheme - real, dimension(:,:), allocatable :: facj !< weights for conservative scheme integer, dimension(:,:), allocatable :: ilon !< indices for conservative scheme integer, dimension(:,:), allocatable :: jlat !< indices for conservative scheme - real, dimension(:,:), allocatable :: area_src !< area of the source grid - real, dimension(:,:), allocatable :: area_dst !< area of the destination grid - real, dimension(:,:,:), allocatable :: wti !< weights for bilinear interpolation - !! wti ist used for derivative "weights" in bicubic - real, dimension(:,:,:), allocatable :: wtj !< weights for bilinear interpolation !! wti ist used for derivative "weights" in bicubic integer, dimension(:,:,:), allocatable :: i_lon !< indices for bilinear interpolation !! and spherical regrid integer, dimension(:,:,:), allocatable :: j_lat !< indices for bilinear interpolation !! and spherical regrid - real, dimension(:,:,:), allocatable :: src_dist !< distance between destination grid and - !! neighbor source grid. - logical, dimension(:,:), allocatable :: found_neighbors !< indicate whether destination grid - !! has some source grid around it. - real :: max_src_dist - integer, dimension(:,:), allocatable :: num_found + logical, dimension(:,:), allocatable :: found_neighbors !< indicate whether destination grid + !! has some source grid around it. + integer, dimension(:,:), allocatable :: num_found integer :: nlon_src !< size of source grid integer :: nlat_src !< size of source grid integer :: nlon_dst !< size of destination grid @@ -82,14 +134,6 @@ module horiz_interp_type_mod !! =2, bilinear interpolation !! =3, spherical regrid !! =4, bicubic regrid - real, dimension(:,:), allocatable :: rat_x !< the ratio of coordinates of the dest grid - !! (x_dest -x_src_r)/(x_src_l -x_src_r) - !! and (y_dest -y_src_r)/(y_src_l -y_src_r) - real, dimension(:,:), allocatable :: rat_y !< the ratio of coordinates of the dest grid - !! (x_dest -x_src_r)/(x_src_l -x_src_r) - !! and (y_dest -y_src_r)/(y_src_l -y_src_r) - real, dimension(:), allocatable :: lon_in !< the coordinates of the source grid - real, dimension(:), allocatable :: lat_in !< the coordinates of the source grid logical :: I_am_initialized=.false. integer :: version !< indicate conservative !! interpolation version with value 1 or 2 @@ -100,86 +144,16 @@ module horiz_interp_type_mod integer, dimension(:), allocatable :: j_src !< indices in source grid. integer, dimension(:), allocatable :: i_dst !< indices in destination grid. integer, dimension(:), allocatable :: j_dst !< indices in destination grid. - real, dimension(:), allocatable :: area_frac_dst !< area fraction in destination grid. - real, dimension(:,:), allocatable :: mask_in + type(horizInterpReals8_type) :: horizInterpReals8_type !< derived type holding kind 8 real data pointers + !! if compiled with r8_kind + type(horizInterpReals4_type) :: horizInterpReals4_type !< derived type holding kind 4 real data pointers + !! if compiled with r8_kind end type -! !> @addtogroup horiz_interp_type_mod !> @{ contains -!####################################################################### - !> @brief This statistics is for bilinear interpolation and spherical regrid. - subroutine stats ( dat, low, high, avg, miss, missing_value, mask ) - real, intent(in) :: dat(:,:) - real, intent(out) :: low, high, avg - integer, intent(out) :: miss - real, intent(in), optional :: missing_value - real, intent(in), optional :: mask(:,:) - - real :: dsum, buffer_real(3) - integer :: pe, root_pe, npes, p, buffer_int(2), npts - - pe = mpp_pe() - root_pe = mpp_root_pe() - npes = mpp_npes() - - dsum = 0.0 - miss = 0 - - if (present(missing_value)) then - miss = count(dat(:,:) == missing_value) - low = minval(dat(:,:), dat(:,:) /= missing_value) - high = maxval(dat(:,:), dat(:,:) /= missing_value) - dsum = sum(dat(:,:), dat(:,:) /= missing_value) - else if(present(mask)) then - miss = count(mask(:,:) <= 0.5) - low = minval(dat(:,:),mask=mask(:,:) > 0.5) - high = maxval(dat(:,:),mask=mask(:,:) > 0.5) - dsum = sum(dat(:,:), mask=mask(:,:) > 0.5) - else - miss = 0 - low = minval(dat(:,:)) - high = maxval(dat(:,:)) - dsum = sum(dat(:,:)) - endif - avg = 0.0 - - npts = size(dat(:,:)) - miss - if(pe == root_pe) then - do p = 1, npes - 1 ! root_pe receive data from other pe - ! Force use of "scalar", integer pointer mpp interface - call mpp_recv(buffer_real(1),glen=3, from_pe=p+root_pe, tag=COMM_TAG_1) - dsum = dsum + buffer_real(1) - low = min(low, buffer_real(2)) - high = max(high, buffer_real(3)) - call mpp_recv(buffer_int(1), glen=2, from_pe=p+root_pe, tag=COMM_TAG_2) - miss = miss + buffer_int(1) - npts = npts + buffer_int(2) - enddo - if(npts == 0) then - print*, 'Warning: no points is valid' - else - avg = dsum/real(npts) - endif - else ! other pe send data to the root_pe. - buffer_real(1) = dsum - buffer_real(2) = low - buffer_real(3) = high - ! Force use of "scalar", integer pointer mpp interface - call mpp_send(buffer_real(1),plen=3,to_pe=root_pe, tag=COMM_TAG_1) - buffer_int(1) = miss - buffer_int(2) = npts - call mpp_send(buffer_int(1), plen=2, to_pe=root_pe, tag=COMM_TAG_2) - endif - - call mpp_sync_self() - - return - - end subroutine stats - !###################################################################################################################### !> @brief horiz_interp_type_eq creates a copy of the horiz_interp_type object subroutine horiz_interp_type_eq(horiz_interp_out, horiz_interp_in) @@ -190,43 +164,74 @@ subroutine horiz_interp_type_eq(horiz_interp_out, horiz_interp_in) call mpp_error(FATAL,'horiz_interp_type_eq: horiz_interp_type variable on right hand side is unassigned') endif - horiz_interp_out%faci = horiz_interp_in%faci - horiz_interp_out%facj = horiz_interp_in%facj - horiz_interp_out%ilon = horiz_interp_in%ilon - horiz_interp_out%jlat = horiz_interp_in%jlat - horiz_interp_out%area_src = horiz_interp_in%area_src - horiz_interp_out%area_dst = horiz_interp_in%area_dst - horiz_interp_out%wti = horiz_interp_in%wti - horiz_interp_out%wtj = horiz_interp_in%wtj - horiz_interp_out%i_lon = horiz_interp_in%i_lon - horiz_interp_out%j_lat = horiz_interp_in%j_lat - horiz_interp_out%src_dist = horiz_interp_in%src_dist - if (allocated(horiz_interp_in%found_neighbors)) horiz_interp_out%found_neighbors = horiz_interp_in%found_neighbors - horiz_interp_out%max_src_dist = horiz_interp_in%max_src_dist - horiz_interp_out%num_found = horiz_interp_in%num_found + horiz_interp_out%ilon = horiz_interp_in%ilon + horiz_interp_out%jlat = horiz_interp_in%jlat + horiz_interp_out%i_lon = horiz_interp_in%i_lon + horiz_interp_out%j_lat = horiz_interp_in%j_lat + horiz_interp_out%found_neighbors = horiz_interp_in%found_neighbors + horiz_interp_out%num_found = horiz_interp_in%num_found horiz_interp_out%nlon_src = horiz_interp_in%nlon_src horiz_interp_out%nlat_src = horiz_interp_in%nlat_src horiz_interp_out%nlon_dst = horiz_interp_in%nlon_dst horiz_interp_out%nlat_dst = horiz_interp_in%nlat_dst horiz_interp_out%interp_method = horiz_interp_in%interp_method - horiz_interp_out%rat_x = horiz_interp_in%rat_x - horiz_interp_out%rat_y = horiz_interp_in%rat_y - horiz_interp_out%lon_in = horiz_interp_in%lon_in - horiz_interp_out%lat_in = horiz_interp_in%lat_in horiz_interp_out%I_am_initialized = .true. - horiz_interp_out%i_src = horiz_interp_in%i_src - horiz_interp_out%j_src = horiz_interp_in%j_src - horiz_interp_out%i_dst = horiz_interp_in%i_dst - horiz_interp_out%j_dst = horiz_interp_in%j_dst - horiz_interp_out%area_frac_dst = horiz_interp_in%area_frac_dst + horiz_interp_out%i_src = horiz_interp_in%i_src + horiz_interp_out%j_src = horiz_interp_in%j_src + horiz_interp_out%i_dst = horiz_interp_in%i_dst + horiz_interp_out%j_dst = horiz_interp_in%j_dst + + if(horiz_interp_in%horizInterpReals8_type%is_allocated) then + horiz_interp_out%horizInterpReals8_type%faci = horiz_interp_in%horizInterpReals8_type%faci + horiz_interp_out%horizInterpReals8_type%facj = horiz_interp_in%horizInterpReals8_type%facj + horiz_interp_out%horizInterpReals8_type%area_src = horiz_interp_in%horizInterpReals8_type%area_src + horiz_interp_out%horizInterpReals8_type%area_dst = horiz_interp_in%horizInterpReals8_type%area_dst + horiz_interp_out%horizInterpReals8_type%wti = horiz_interp_in%horizInterpReals8_type%wti + horiz_interp_out%horizInterpReals8_type%wtj = horiz_interp_in%horizInterpReals8_type%wtj + horiz_interp_out%horizInterpReals8_type%src_dist = horiz_interp_in%horizInterpReals8_type%src_dist + horiz_interp_out%horizInterpReals8_type%rat_x = horiz_interp_in%horizInterpReals8_type%rat_x + horiz_interp_out%horizInterpReals8_type%rat_y = horiz_interp_in%horizInterpReals8_type%rat_y + horiz_interp_out%horizInterpReals8_type%lon_in = horiz_interp_in%horizInterpReals8_type%lon_in + horiz_interp_out%horizInterpReals8_type%lat_in = horiz_interp_in%horizInterpReals8_type%lat_in + horiz_interp_out%horizInterpReals8_type%area_frac_dst = horiz_interp_in%horizInterpReals8_type%area_frac_dst + horiz_interp_out%horizInterpReals8_type%max_src_dist = horiz_interp_in%horizInterpReals8_type%max_src_dist + horiz_interp_out%horizInterpReals8_type%is_allocated = .true. + ! this was left out previous to mixed mode + horiz_interp_out%horizInterpReals8_type%mask_in = horiz_interp_in%horizInterpReals8_type%mask_in + + else if (horiz_interp_in%horizInterpReals4_type%is_allocated) then + horiz_interp_out%horizInterpReals4_type%faci = horiz_interp_in%horizInterpReals4_type%faci + horiz_interp_out%horizInterpReals4_type%facj = horiz_interp_in%horizInterpReals4_type%facj + horiz_interp_out%horizInterpReals4_type%area_src = horiz_interp_in%horizInterpReals4_type%area_src + horiz_interp_out%horizInterpReals4_type%area_dst = horiz_interp_in%horizInterpReals4_type%area_dst + horiz_interp_out%horizInterpReals4_type%wti = horiz_interp_in%horizInterpReals4_type%wti + horiz_interp_out%horizInterpReals4_type%wtj = horiz_interp_in%horizInterpReals4_type%wtj + horiz_interp_out%horizInterpReals4_type%src_dist = horiz_interp_in%horizInterpReals4_type%src_dist + horiz_interp_out%horizInterpReals4_type%rat_x = horiz_interp_in%horizInterpReals4_type%rat_x + horiz_interp_out%horizInterpReals4_type%rat_y = horiz_interp_in%horizInterpReals4_type%rat_y + horiz_interp_out%horizInterpReals4_type%lon_in = horiz_interp_in%horizInterpReals4_type%lon_in + horiz_interp_out%horizInterpReals4_type%lat_in = horiz_interp_in%horizInterpReals4_type%lat_in + horiz_interp_out%horizInterpReals4_type%area_frac_dst = horiz_interp_in%horizInterpReals4_type%area_frac_dst + horiz_interp_out%horizInterpReals4_type%max_src_dist = horiz_interp_in%horizInterpReals4_type%max_src_dist + horiz_interp_out%horizInterpReals4_type%is_allocated = .true. + ! this was left out previous to mixed mode + horiz_interp_out%horizInterpReals4_type%mask_in = horiz_interp_in%horizInterpReals4_type%mask_in + + else + call mpp_error(FATAL, "horiz_interp_type_eq: cannot assign unallocated real values from horiz_interp_in") + endif + if(horiz_interp_in%interp_method == CONSERVE) then - horiz_interp_out%version = horiz_interp_in%version - if(horiz_interp_in%version==2) horiz_interp_out%nxgrid = horiz_interp_in%nxgrid + horiz_interp_out%version = horiz_interp_in%version + if(horiz_interp_in%version==2) horiz_interp_out%nxgrid = horiz_interp_in%nxgrid end if end subroutine horiz_interp_type_eq !###################################################################################################################### +#include "horiz_interp_type_r4.fh" +#include "horiz_interp_type_r8.fh" + end module horiz_interp_type_mod !> @} ! close documentation grouping diff --git a/horiz_interp/include/horiz_interp.inc b/horiz_interp/include/horiz_interp.inc new file mode 100644 index 0000000000..ec0540b442 --- /dev/null +++ b/horiz_interp/include/horiz_interp.inc @@ -0,0 +1,843 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_mod +!> @{ + !> @brief Creates a 1D @ref horiz_interp_type with the given parameters + subroutine HORIZ_INTERP_NEW_1D_ (Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, & + grid_at_center, mask_in, mask_out) + + !----------------------------------------------------------------------- + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out, lat_out + integer, intent(in), optional :: verbose + character(len=*), intent(in), optional :: interp_method + integer, intent(in), optional :: num_nbrs + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo + logical, intent(in), optional :: grid_at_center + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in !< dummy variable + real(FMS_HI_KIND_), intent(inout),dimension(:,:), optional :: mask_out !< dummy variable + !----------------------------------------------------------------------- + real(FMS_HI_KIND_), dimension(:,:), allocatable :: lon_src, lat_src, lon_dst, lat_dst + real(FMS_HI_KIND_), dimension(:), allocatable :: lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d + integer :: i, j, nlon_in, nlat_in, nlon_out, nlat_out + logical :: center + character(len=40) :: method + integer, parameter :: kindl = FMS_HI_KIND_ !> real kind size currently compiling + !----------------------------------------------------------------------- + call horiz_interp_init + + method = 'conservative' + if(present(interp_method)) method = interp_method + + select case (trim(method)) + case ("conservative") + Interp%interp_method = CONSERVE + call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose) + case ("bilinear") + Interp%interp_method = BILINEAR + center = .false. + if(present(grid_at_center) ) center = grid_at_center + if(center) then + nlon_out = size(lon_out(:)); nlat_out = size(lat_out(:)) + allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) + do i = 1, nlon_out + lon_dst(i,:) = lon_out(i) + enddo + do j = 1, nlat_out + lat_dst(:,j) = lat_out(j) + enddo + + call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, & + verbose, src_modulo) + deallocate(lon_dst, lat_dst) + else + nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 + nlon_out = size(lon_out(:))-1; nlat_out = size(lat_out(:))-1 + allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) + allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) + do i = 1, nlon_in + lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5_kindl + enddo + do j = 1, nlat_in + lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5_kindl + enddo + do i = 1, nlon_out + lon_dst(i,:) = (lon_out(i) + lon_out(i+1)) * 0.5_kindl + enddo + do j = 1, nlat_out + lat_dst(:,j) = (lat_out(j) + lat_out(j+1)) * 0.5_kindl + enddo + call horiz_interp_bilinear_new ( Interp, lon_src_1d, lat_src_1d, lon_dst, lat_dst, & + verbose, src_modulo) + deallocate(lon_src_1d, lat_src_1d, lon_dst, lat_dst) + endif + case ("bicubic") + Interp%interp_method = BICUBIC + center = .false. + if(present(grid_at_center) ) center = grid_at_center + !No need to expand to 2d, horiz_interp_bicubic_new does 1d-1d + if(center) then + call horiz_interp_bicubic_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo) + else + nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 + nlon_out = size(lon_out(:))-1; nlat_out = size(lat_out(:))-1 + allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) + allocate(lon_dst_1d(nlon_out), lat_dst_1d(nlat_out)) + do i = 1, nlon_in + lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5_kindl + enddo + do j = 1, nlat_in + lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5_kindl + enddo + do i = 1, nlon_out + lon_dst_1d(i) = (lon_out(i) + lon_out(i+1)) * 0.5_kindl + enddo + do j = 1, nlat_out + lat_dst_1d(j) = (lat_out(j) + lat_out(j+1)) * 0.5_kindl + enddo + call horiz_interp_bicubic_new ( Interp, lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d, & + verbose, src_modulo) + deallocate(lon_src_1d, lat_src_1d, lon_dst_1d, lat_dst_1d) + endif + case ("spherical") + Interp%interp_method = SPHERICA + nlon_in = size(lon_in(:)); nlat_in = size(lat_in(:)) + nlon_out = size(lon_out(:)); nlat_out = size(lat_out(:)) + allocate(lon_src(nlon_in,nlat_in), lat_src(nlon_in,nlat_in)) + allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) + do i = 1, nlon_in + lon_src(i,:) = lon_in(i) + enddo + do j = 1, nlat_in + lat_src(:,j) = lat_in(j) + enddo + do i = 1, nlon_out + lon_dst(i,:) = lon_out(i) + enddo + do j = 1, nlat_out + lat_dst(:,j) = lat_out(j) + enddo + call horiz_interp_spherical_new ( Interp, lon_src, lat_src, lon_dst, lat_dst, & + num_nbrs, max_dist, src_modulo) + deallocate(lon_src, lat_src, lon_dst, lat_dst) + case default + call mpp_error(FATAL,'horiz_interp_mod: interp_method should be conservative, bilinear, bicubic, spherical') + end select + + !----------------------------------------------------------------------- + Interp% HI_KIND_TYPE_ % is_allocated = .true. + Interp%I_am_initialized = .true. + + end subroutine HORIZ_INTERP_NEW_1D_ + +!####################################################################### + + subroutine HORIZ_INTERP_NEW_1D_SRC_ (Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, & + src_modulo, grid_at_center, mask_in, mask_out, is_latlon_out ) + + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + integer, intent(in), optional :: verbose + character(len=*), intent(in), optional :: interp_method + integer, intent(in), optional :: num_nbrs !< minimum number of neighbors + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo + logical, intent(in), optional :: grid_at_center + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out),dimension(:,:), optional :: mask_out + logical, intent(in), optional :: is_latlon_out + + real(FMS_HI_KIND_), dimension(:,:), allocatable :: lon_src, lat_src + real(FMS_HI_KIND_), dimension(:), allocatable :: lon_src_1d, lat_src_1d + integer :: i, j, nlon_in, nlat_in + character(len=40) :: method + logical :: center + logical :: dst_is_latlon + integer, parameter :: kindl = FMS_HI_KIND_ !< real kind size currently compiling + !----------------------------------------------------------------------- + call horiz_interp_init + + method = 'conservative' + if(present(interp_method)) method = interp_method + + select case (trim(method)) + case ("conservative") + Interp%interp_method = CONSERVE + !--- check to see if the source grid is regular lat-lon grid or not. + if(PRESENT(is_latlon_out)) then + dst_is_latlon = is_latlon_out + else + dst_is_latlon = is_lat_lon(lon_out, lat_out) + end if + if(dst_is_latlon ) then + if(present(mask_in)) then + if ( ANY(mask_in < -.0001_kindl) .or. ANY(mask_in > 1.0001_kindl)) & + call mpp_error(FATAL, & + 'horiz_interp_conserve_new_1d_src(horiz_interp_conserve_mod): input mask not between 0,1') + allocate(Interp%HI_KIND_TYPE_%mask_in(size(mask_in,1), size(mask_in,2)) ) + Interp%HI_KIND_TYPE_%mask_in = mask_in + end if + call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out(:,1), lat_out(1,:), & + verbose=verbose ) + else + call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose=verbose, mask_in=mask_in, mask_out=mask_out ) + end if + case ("bilinear") + Interp%interp_method = BILINEAR + center = .false. + if(present(grid_at_center) ) center = grid_at_center + if(center) then + call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo ) + else + nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 + allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) + do i = 1, nlon_in + lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5_kindl + enddo + do j = 1, nlat_in + lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5_kindl + enddo + call horiz_interp_bilinear_new ( Interp, lon_src_1d, lat_src_1d, lon_out, lat_out, & + verbose, src_modulo ) + deallocate(lon_src_1d,lat_src_1d) + endif + case ("bicubic") + Interp%interp_method = BICUBIC + center = .false. + if(present(grid_at_center) ) center = grid_at_center + if(center) then + call horiz_interp_bicubic_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo ) + else + nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 + allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) + do i = 1, nlon_in + lon_src_1d(i) = (lon_in(i) + lon_in(i+1)) * 0.5_kindl + enddo + do j = 1, nlat_in + lat_src_1d(j) = (lat_in(j) + lat_in(j+1)) * 0.5_kindl + enddo + call horiz_interp_bicubic_new ( Interp, lon_src_1d, lat_src_1d, lon_out, lat_out, & + verbose, src_modulo ) + deallocate(lon_src_1d,lat_src_1d) + endif + case ("spherical") + Interp%interp_method = SPHERICA + nlon_in = size(lon_in(:)); nlat_in = size(lat_in(:)) + allocate(lon_src(nlon_in,nlat_in), lat_src(nlon_in,nlat_in)) + do i = 1, nlon_in + lon_src(i,:) = lon_in(i) + enddo + do j = 1, nlat_in + lat_src(:,j) = lat_in(j) + enddo + call horiz_interp_spherical_new ( Interp, lon_src, lat_src, lon_out, lat_out, & + num_nbrs, max_dist, src_modulo) + deallocate(lon_src, lat_src) + case default + call mpp_error(FATAL,'interp_method should be conservative, bilinear, bicubic, spherical') + end select + + !----------------------------------------------------------------------- + Interp% HI_KIND_TYPE_ % is_allocated = .true. + Interp%I_am_initialized = .true. + + end subroutine HORIZ_INTERP_NEW_1D_SRC_ + +!####################################################################### + + subroutine HORIZ_INTERP_NEW_2D_ (Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, & + src_modulo, mask_in, mask_out, is_latlon_in, is_latlon_out ) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + integer, intent(in), optional :: verbose + character(len=*), intent(in), optional :: interp_method + integer, intent(in), optional :: num_nbrs + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out),dimension(:,:), optional :: mask_out + logical, intent(in), optional :: is_latlon_in, is_latlon_out + logical :: src_is_latlon, dst_is_latlon + character(len=40) :: method + integer, parameter :: kindl = FMS_HI_KIND_ !< real kind size currently compiling +!----------------------------------------------------------------------- + call horiz_interp_init + + method = 'bilinear' + if(present(interp_method)) method = interp_method + + select case (trim(method)) + case ("conservative") + Interp%interp_method = CONSERVE + if(PRESENT(is_latlon_in)) then + src_is_latlon = is_latlon_in + else + src_is_latlon = is_lat_lon(lon_in, lat_in) + end if + if(PRESENT(is_latlon_out)) then + dst_is_latlon = is_latlon_out + else + dst_is_latlon = is_lat_lon(lon_out, lat_out) + end if + if(src_is_latlon .AND. dst_is_latlon) then + if(present(mask_in)) then + if ( ANY(mask_in < -0.0001_kindl) .or. ANY(mask_in > 1.0001_kindl)) then + call mpp_error(FATAL, 'horiz_interp_conserve_new_2d(horiz_interp_conserve_mod):' // & + ' input mask not between 0,1') + endif + allocate(Interp%HI_KIND_TYPE_%mask_in(size(mask_in,1), size(mask_in,2)) ) + Interp%HI_KIND_TYPE_%mask_in = mask_in + end if + call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out(:,1), lat_out(1,:), & + verbose=verbose ) + else if(src_is_latlon) then + call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out, lat_out, & + verbose=verbose, mask_in=mask_in, mask_out=mask_out ) + else if(dst_is_latlon) then + call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out(:,1), lat_out(1,:), & + verbose=verbose, mask_in=mask_in, mask_out=mask_out ) + else + call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose=verbose, mask_in=mask_in, mask_out=mask_out ) + end if + + case ("spherical") + Interp%interp_method = SPHERICA + call horiz_interp_spherical_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + num_nbrs, max_dist, src_modulo ) + case ("bilinear") + Interp%interp_method = BILINEAR + call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo ) + case default + call mpp_error(FATAL,'when source grid are 2d, interp_method should be spherical or bilinear') + end select + + Interp% HI_KIND_TYPE_ % is_allocated = .true. + Interp%I_am_initialized = .true. + + end subroutine HORIZ_INTERP_NEW_2D_ + +!####################################################################### + subroutine HORIZ_INTERP_NEW_1D_DST_ (Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, interp_method, num_nbrs, max_dist, src_modulo, mask_in, mask_out, is_latlon_in ) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out, lat_out + integer, intent(in), optional :: verbose + character(len=*), intent(in), optional :: interp_method + integer, intent(in), optional :: num_nbrs + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out),dimension(:,:), optional :: mask_out + logical, intent(in), optional :: is_latlon_in + + character(len=40) :: method + integer, parameter :: kindl = FMS_HI_KIND_ !< real kind size currently compiling + !-------------some local variables----------------------------------------------- + integer :: i, j, nlon_out, nlat_out + real(FMS_HI_KIND_), dimension(:,:), allocatable :: lon_dst, lat_dst + logical :: src_is_latlon + !----------------------------------------------------------------------- + call horiz_interp_init + + method = 'bilinear' + if(present(interp_method)) method = interp_method + + nlon_out = size(lon_out(:)); nlat_out = size(lat_out(:)) + allocate(lon_dst(nlon_out,nlat_out), lat_dst(nlon_out,nlat_out)) + do i = 1, nlon_out + lon_dst(i,:) = lon_out(i) + enddo + do j = 1, nlat_out + lat_dst(:,j) = lat_out(j) + enddo + + select case (trim(method)) + case ("conservative") + Interp%interp_method = CONSERVE + if(PRESENT(is_latlon_in)) then + src_is_latlon = is_latlon_in + else + src_is_latlon = is_lat_lon(lon_in, lat_in) + end if + + if(src_is_latlon) then + if(present(mask_in)) then + if ( ANY(mask_in < -0.0001_kindl) .or. ANY(mask_in > 1.0001_kindl)) & + call mpp_error(FATAL, & + 'horiz_interp_conserve_new_1d_dst(horiz_interp_conserve_mod): input mask not between 0,1') + allocate(Interp%HI_KIND_TYPE_%mask_in(size(mask_in,1), size(mask_in,2)) ) + Interp%HI_KIND_TYPE_%mask_in = mask_in + end if + call horiz_interp_conserve_new ( Interp, lon_in(:,1), lat_in(1,:), lon_out, lat_out, & + verbose=verbose) + else + call horiz_interp_conserve_new ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose=verbose, mask_in=mask_in, mask_out=mask_out ) + end if + case ("bilinear") + Interp%interp_method = BILINEAR + call horiz_interp_bilinear_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, & + verbose, src_modulo ) + case ("spherical") + Interp%interp_method = SPHERICA + call horiz_interp_spherical_new ( Interp, lon_in, lat_in, lon_dst, lat_dst, & + num_nbrs, max_dist, src_modulo) + case default + call mpp_error(FATAL,'when source grid are 2d, interp_method should be spherical or bilinear') + end select + + deallocate(lon_dst,lat_dst) + + Interp% HI_KIND_TYPE_ % is_allocated = .true. + Interp%I_am_initialized = .true. + + end subroutine HORIZ_INTERP_NEW_1D_DST_ + +!####################################################################### + + subroutine HORIZ_INTERP_BASE_2D_ ( Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit, & + err_msg, new_missing_handle ) +!----------------------------------------------------------------------- + type (horiz_interp_type), intent(in) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + character(len=*), intent(out), optional :: err_msg + logical, intent(in), optional :: new_missing_handle +!----------------------------------------------------------------------- + if(present(err_msg)) err_msg = '' + if(.not.Interp%I_am_initialized) then + if(fms_error_handler('horiz_interp','The horiz_interp_type variable is not initialized',err_msg)) return + endif + + select case(Interp%interp_method) + case(CONSERVE) + call horiz_interp_conserve(Interp,data_in, data_out, verbose, mask_in, mask_out) + case(BILINEAR) + call horiz_interp_bilinear(Interp,data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, new_missing_handle ) + case(BICUBIC) + call horiz_interp_bicubic(Interp,data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit ) + case(SPHERICA) + call horiz_interp_spherical(Interp,data_in, data_out, verbose, mask_in, mask_out, & + missing_value ) + case default + call mpp_error(FATAL,'interp_method should be conservative, bilinear, bicubic, spherical') + end select + + return + + end subroutine HORIZ_INTERP_BASE_2D_ + +!####################################################################### + + !> Overload of interface HORIZ_INTERP_BASE_2D_ + !! uses 3d arrays for data and mask + !! this allows for multiple interpolations with one call + subroutine HORIZ_INTERP_BASE_3D_ ( Interp, data_in, data_out, verbose, mask_in, mask_out, & + missing_value, missing_permit, err_msg ) + !----------------------------------------------------------------------- + ! overload of interface HORIZ_INTERP_BASE_2D_ + ! uses 3d arrays for data and mask + ! this allows for multiple interpolations with one call + !----------------------------------------------------------------------- + type (horiz_interp_type), intent(in) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:,:) :: data_in + real(FMS_HI_KIND_), intent(out), dimension(:,:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:,:), optional :: mask_out + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + character(len=*), intent(out), optional :: err_msg + !----------------------------------------------------------------------- + integer :: n + + if(present(err_msg)) err_msg = '' + if(.not.Interp%I_am_initialized) then + if(fms_error_handler('horiz_interp','The horiz_interp_type variable is not initialized',err_msg)) return + endif + + do n = 1, size(data_in,3) + if (present(mask_in))then + if(present(mask_out)) then + call horiz_interp( Interp, data_in(:,:,n), data_out(:,:,n), & + verbose, mask_in(:,:,n), mask_out(:,:,n), & + missing_value, missing_permit ) + else + call horiz_interp( Interp, data_in(:,:,n), data_out(:,:,n), & + verbose, mask_in(:,:,n), missing_value = missing_value, & + missing_permit = missing_permit ) + endif + else + if(present(mask_out)) then + call horiz_interp( Interp, data_in(:,:,n), data_out(:,:,n), & + verbose, mask_out=mask_out(:,:,n), missing_value = missing_value, & + missing_permit = missing_permit ) + else + call horiz_interp( Interp, data_in(:,:,n), data_out(:,:,n), & + verbose, missing_value = missing_value, & + missing_permit = missing_permit ) + endif + endif + enddo + + return +!----------------------------------------------------------------------- + end subroutine HORIZ_INTERP_BASE_3D_ + +!####################################################################### + +!> Interpolates from a rectangular grid to rectangular grid. +!! interp_method can be the value conservative, bilinear or spherical. +!! horiz_interp_new don't need to be called before calling this routine. + subroutine HORIZ_INTERP_SOLO_1D_ ( data_in, lon_in, lat_in, lon_out, lat_out, & + data_out, verbose, mask_in, mask_out, & + interp_method, missing_value, missing_permit, & + num_nbrs, max_dist,src_modulo, grid_at_center ) +!----------------------------------------------------------------------- + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out, lat_out + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out + character(len=*), intent(in), optional :: interp_method + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + integer, intent(in), optional :: num_nbrs + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo + logical, intent(in), optional :: grid_at_center +!----------------------------------------------------------------------- + type (horiz_interp_type) :: Interp +!----------------------------------------------------------------------- + call horiz_interp_init + + call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, grid_at_center ) + + call horiz_interp ( Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit ) + + call horiz_interp_del ( Interp ) +!----------------------------------------------------------------------- + + end subroutine HORIZ_INTERP_SOLO_1D_ + +!####################################################################### + +!> Interpolates from a uniformly spaced grid to any output grid. +!! interp_method can be the value "onservative","bilinear" or "spherical". +!! horiz_interp_new don't need to be called before calling this routine. + subroutine HORIZ_INTERP_SOLO_1D_SRC_ ( data_in, lon_in, lat_in, lon_out, lat_out, & + data_out, verbose, mask_in, mask_out, & + interp_method, missing_value, missing_permit, & + num_nbrs, max_dist, src_modulo, grid_at_center ) +!----------------------------------------------------------------------- + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out + character(len=*), intent(in), optional :: interp_method + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + integer, intent(in), optional :: num_nbrs + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo + logical, intent(in), optional :: grid_at_center + +!----------------------------------------------------------------------- + type (horiz_interp_type) :: Interp + logical :: dst_is_latlon + character(len=128) :: method +!----------------------------------------------------------------------- + call horiz_interp_init + method = 'conservative' + if(present(interp_method)) method = interp_method + dst_is_latlon = .true. + if(trim(method) == 'conservative') dst_is_latlon = is_lat_lon(lon_out, lat_out) + + if(dst_is_latlon) then + call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, & + grid_at_center, is_latlon_out = dst_is_latlon ) + call horiz_interp ( Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit ) + else + call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, & + grid_at_center, mask_in, mask_out, is_latlon_out = dst_is_latlon) + + call horiz_interp ( Interp, data_in, data_out, verbose, & + missing_value=missing_value, missing_permit=missing_permit ) + end if + + call horiz_interp_del ( Interp ) + +!----------------------------------------------------------------------- + + end subroutine HORIZ_INTERP_SOLO_1D_SRC_ + + +!####################################################################### + +!> Interpolates from any grid to any grid. interp_method should be "spherical" +!! horiz_interp_new don't need to be called before calling this routine. + subroutine HORIZ_INTERP_SOLO_2D_ ( data_in, lon_in, lat_in, lon_out, lat_out, data_out, & + verbose, mask_in, mask_out, interp_method, missing_value,& + missing_permit, num_nbrs, max_dist, src_modulo ) +!----------------------------------------------------------------------- + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out + character(len=*), intent(in), optional :: interp_method + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + integer, intent(in), optional :: num_nbrs + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo +!----------------------------------------------------------------------- + type (horiz_interp_type) :: Interp + logical :: dst_is_latlon, src_is_latlon + character(len=128) :: method +!----------------------------------------------------------------------- + call horiz_interp_init + + method = 'conservative' + if(present(interp_method)) method = interp_method + dst_is_latlon = .true. + src_is_latlon = .true. + if(trim(method) == 'conservative') then + dst_is_latlon = is_lat_lon(lon_out, lat_out) + src_is_latlon = is_lat_lon(lon_in, lat_in) + end if + + if(dst_is_latlon .and. src_is_latlon) then + call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, & + is_latlon_in=dst_is_latlon, is_latlon_out = dst_is_latlon ) + call horiz_interp ( Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit ) + else + call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, & + mask_in, mask_out, & + is_latlon_in=dst_is_latlon, is_latlon_out = dst_is_latlon) + call horiz_interp ( Interp, data_in, data_out, verbose, & + missing_value=missing_value, missing_permit=missing_permit ) + end if + + call horiz_interp_del ( Interp ) + +!----------------------------------------------------------------------- + + end subroutine HORIZ_INTERP_SOLO_2D_ + +!####################################################################### + +!> interpolates from any grid to rectangular longitude/latitude grid. +!! interp_method should be "spherical". +!! horiz_interp_new don't need to be called before calling this routine. + subroutine HORIZ_INTERP_SOLO_1D_DST_ ( data_in, lon_in, lat_in, lon_out, lat_out, data_out, & + verbose, mask_in, mask_out,interp_method,missing_value, & + missing_permit, num_nbrs, max_dist, src_modulo) +!----------------------------------------------------------------------- + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out, lat_out + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out + character(len=*), intent(in), optional :: interp_method + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + integer, intent(in), optional :: num_nbrs + real(FMS_HI_KIND_), intent(in), optional :: max_dist + logical, intent(in), optional :: src_modulo +!----------------------------------------------------------------------- + type (horiz_interp_type) :: Interp + logical :: src_is_latlon + character(len=128) :: method +!----------------------------------------------------------------------- + call horiz_interp_init + + method = 'conservative' + if(present(interp_method)) method = interp_method + src_is_latlon = .true. + if(trim(method) == 'conservative') src_is_latlon = is_lat_lon(lon_in, lat_in) + + if(src_is_latlon) then + call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, & + is_latlon_in = src_is_latlon ) + call horiz_interp ( Interp, data_in, data_out, verbose, & + mask_in, mask_out, missing_value, missing_permit ) + else + call horiz_interp_new ( Interp, lon_in, lat_in, lon_out, lat_out, verbose, & + interp_method, num_nbrs, max_dist, src_modulo, & + mask_in, mask_out, is_latlon_in = src_is_latlon) + + call horiz_interp ( Interp, data_in, data_out, verbose, & + missing_value=missing_value, missing_permit=missing_permit ) + end if + + call horiz_interp_del ( Interp ) + +!----------------------------------------------------------------------- + + end subroutine HORIZ_INTERP_SOLO_1D_DST_ + +!####################################################################### + +!> Overloaded version of interface horiz_interp_solo_2 + subroutine HORIZ_INTERP_SOLO_OLD_ (data_in, wb, sb, dx, dy, & + lon_out, lat_out, data_out, & + verbose, mask_in, mask_out) + +!----------------------------------------------------------------------- + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in !< Global input data stored from west to east + !! (1st dimension), south to north (2nd dimension) + real(FMS_HI_KIND_), intent(in) :: wb !< Longitude (radians) that correspond to western-most + !! boundary of grid box j=1 in array data_in + real(FMS_HI_KIND_), intent(in) :: sb !< Latitude (radians) that correspond to western-most + !! boundary of grid box j=1 in array data_in + real(FMS_HI_KIND_), intent(in) :: dx !< Grid spacing (in radians) for the longitude axis + !! (first dimension) for the input data + real(FMS_HI_KIND_), intent(in) :: dy !< Grid spacing (in radians) for the latitude axis + !! (first dimension) for the input data + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out !< The longitude edges (in radians) for output + !! data grid boxes. The values are for adjacent grid boxes + !! and must increase in value. If there are MLON grid boxes + !! there must be MLON+1 edge values + real(FMS_HI_KIND_), intent(in), dimension(:) :: lat_out !< The latitude edges (in radians) for output + !! data grid boxes. The values are for adjacent grid boxes + !! and may increase or decrease in value. If there are NLAT + !! grid boxes there must be NLAT+1 edge values + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out !< Output data on the output grid defined by grid box + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out +!----------------------------------------------------------------------- + real(FMS_HI_KIND_), dimension(size(data_in,1)+1) :: blon_in + real(FMS_HI_KIND_), dimension(size(data_in,2)+1) :: blat_in + integer :: i, j, nlon_in, nlat_in + real(FMS_HI_KIND_) :: tpi + integer, parameter :: kindl = FMS_HI_KIND_ !< real size at compile time +!----------------------------------------------------------------------- + call horiz_interp_init + + tpi = 2.0_kindl * real(pi, FMS_HI_KIND_) + nlon_in = size(data_in,1) + nlat_in = size(data_in,2) + + do i = 1, nlon_in+1 + blon_in(i) = wb + real(i-1, FMS_HI_KIND_)*dx + enddo + if (abs(blon_in(nlon_in+1)-blon_in(1)-tpi) < epsilon(blon_in)) & + blon_in(nlon_in+1)=blon_in(1)+tpi + + do j = 2, nlat_in + blat_in(j) = sb + real(j-1, FMS_HI_KIND_)*dy + enddo + blat_in(1) = -0.5_kindl * real(pi, FMS_HI_KIND_) + blat_in(nlat_in+1) = 0.5_kindl * real(pi, FMS_HI_KIND_) + + + call horiz_interp_solo_1d (data_in, blon_in, blat_in, & + lon_out, lat_out, data_out, & + verbose, mask_in, mask_out ) + +!----------------------------------------------------------------------- + + end subroutine HORIZ_INTERP_SOLO_OLD_ + +!####################################################################### + + + !#################################################################### + function IS_LAT_LON_(lon, lat) + real(FMS_HI_KIND_), dimension(:,:), intent(in) :: lon, lat + logical :: IS_LAT_LON_ + integer :: i, j, nlon, nlat, num + + IS_LAT_LON_ = .true. + nlon = size(lon,1) + nlat = size(lon,2) + LOOP_LAT: do j = 1, nlat + do i = 2, nlon + if(lat(i,j) .NE. lat(1,j)) then + IS_LAT_LON_ = .false. + exit LOOP_LAT + end if + end do + end do LOOP_LAT + + if(IS_LAT_LON_) then + LOOP_LON: do i = 1, nlon + do j = 2, nlat + if(lon(i,j) .NE. lon(i,1)) then + IS_LAT_LON_ = .false. + exit LOOP_LON + end if + end do + end do LOOP_LON + end if + + num = 0 + if(IS_LAT_LON_) num = 1 + call mpp_min(num) + if(num == 1) then + IS_LAT_LON_ = .true. + else + IS_LAT_LON_ = .false. + end if + + return + end function IS_LAT_LON_ +!> @} diff --git a/horiz_interp/include/horiz_interp_bicubic.inc b/horiz_interp/include/horiz_interp_bicubic.inc new file mode 100644 index 0000000000..1c2f744f2b --- /dev/null +++ b/horiz_interp/include/horiz_interp_bicubic.inc @@ -0,0 +1,663 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_bicubic_mod +!> @{ + + !> @brief Creates a new @ref horiz_interp_type + !! + !> Allocates space and initializes a derived-type variable + !! that contains pre-computed interpolation indices and weights. + subroutine HORIZ_INTERP_BICUBIC_NEW_1D_S_ ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo ) + + !----------------------------------------------------------------------- + type(horiz_interp_type), intent(inout) :: Interp !< A derived-type variable containing indices + !! and weights used for subsequent interpolations. To + !! reinitialize this variable for a different grid-to-grid + !! interpolation you must first use the + !! @ref HORIZ_INTERP_BICUBIC_NEW__del interface. + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in !< Longitude (radians) for source data grid + real(FMS_HI_KIND_), intent(in), dimension(:) :: lat_in !< Latitude (radians) for source data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out !< Longitude (radians) for output data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lat_out !< Latitude (radians) for output data grid + integer, intent(in), optional :: verbose !< flag for print output amount + logical, intent(in), optional :: src_modulo !< indicates if the boundary condition along + !! zonal boundary is cyclic or not. Zonal boundary condition + !!is cyclic when true + integer :: i, j, ip1, im1, jp1, jm1 + logical :: src_is_modulo + integer :: nlon_in, nlat_in, nlon_out, nlat_out + integer :: jcl, jcu, icl, icu, jj + real(FMS_HI_KIND_) :: xz, yz + integer :: unit + integer, parameter :: kindl = FMS_HI_KIND_ !< real size at compile time + + if(present(verbose)) verbose_bicubic = verbose + src_is_modulo = .false. + if (present(src_modulo)) src_is_modulo = src_modulo + + if(size(lon_out,1) /= size(lat_out,1) .or. size(lon_out,2) /= size(lat_out,2) ) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear ' // & + 'interplation, the output grids should be geographical grids') + + !--- get the grid size + nlon_in = size(lon_in) ; nlat_in = size(lat_in) + nlon_out = size(lon_out,1); nlat_out = size(lat_out,2) + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out +! use wti(:,:,1) for x-derivative, wti(:,:,2) for y-derivative, wti(:,:,3) for xy-derivative + allocate ( Interp%HI_KIND_TYPE_%wti (nlon_in, nlat_in, 3) ) + allocate ( Interp%HI_KIND_TYPE_%lon_in (nlon_in) ) + allocate ( Interp%HI_KIND_TYPE_%lat_in (nlat_in) ) + allocate ( Interp%HI_KIND_TYPE_%rat_x (nlon_out, nlat_out) ) + allocate ( Interp%HI_KIND_TYPE_%rat_y (nlon_out, nlat_out) ) + allocate ( Interp%i_lon (nlon_out, nlat_out, 2) ) + allocate ( Interp%j_lat (nlon_out, nlat_out, 2) ) + + Interp%HI_KIND_TYPE_%lon_in = lon_in + Interp%HI_KIND_TYPE_%lat_in = lat_in + + if ( verbose_bicubic > 0 ) then + unit = stdout() + write (unit,'(/,"Initialising bicubic interpolation, interface horiz_interp_bicubic_new_1d_s")') + write (unit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src + write (unit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lon_in(jj),jj=1,Interp%nlon_src) + write (unit,'(/," Latitude of coarse grid points (radian): yc(j) j=1, ",i4)') Interp%nlat_src + write (unit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lat_in(jj),jj=1,Interp%nlat_src) + do i=1, Interp%nlat_dst + write (unit,*) + write (unit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst + write (unit,'(1x,10f10.4)') (lon_out(jj,i),jj=1,Interp%nlon_dst) + enddo + do i=1, Interp%nlon_dst + write (unit,*) + write (unit,'(/," Latitude of fine grid points (radian): yf(j) j=1, ",i4)') Interp%nlon_dst + write (unit,'(1x,10f10.4)') (lat_out(i,jj),jj=1,Interp%nlat_dst) + enddo + endif + + +!--------------------------------------------------------------------------- +! Find the x-derivative. Use central differences and forward or +! backward steps at the boundaries + + do j=1,nlat_in + do i=1,nlon_in + ip1=min(i+1,nlon_in) + im1=max(i-1,1) + Interp%HI_KIND_TYPE_%wti(i,j,1) = 1.0_kindl/(Interp%HI_KIND_TYPE_%lon_in(ip1)-Interp%HI_KIND_TYPE_%lon_in(im1)) + enddo + enddo + + +!--------------------------------------------------------------------------- + +! Find the y-derivative. Use central differences and forward or +! backward steps at the boundaries + do j=1,nlat_in + jp1=min(j+1,nlat_in) + jm1=max(j-1,1) + do i=1,nlon_in + Interp%HI_KIND_TYPE_%wti(i,j,2) =1.0_kindl/(Interp%HI_KIND_TYPE_%lat_in(jp1)-Interp%HI_KIND_TYPE_%lat_in(jm1)) + enddo + enddo + +!--------------------------------------------------------------------------- + +! Find the xy-derivative. Use central differences and forward or +! backward steps at the boundaries + do j=1,nlat_in + jp1=min(j+1,nlat_in) + jm1=max(j-1,1) + do i=1,nlon_in + ip1=min(i+1,nlon_in) + im1=max(i-1,1) + Interp%HI_KIND_TYPE_%wti(i,j,3) = 1.0_kindl / & + ((Interp%HI_KIND_TYPE_%lon_in(ip1)-Interp%HI_KIND_TYPE_%lon_in(im1)) * & + (Interp%HI_KIND_TYPE_%lat_in(jp1)-Interp%HI_KIND_TYPE_%lat_in(jm1))) + enddo + enddo +!--------------------------------------------------------------------------- +! Now for each point at the dest-grid find the boundary points of +! the source grid + do j=1, nlat_out + do i=1,nlon_out + yz = lat_out(i,j) + xz = lon_out(i,j) + + jcl = 0 + jcu = 0 + if( yz .le. Interp%HI_KIND_TYPE_%lat_in(1) ) then + jcl = 1 + jcu = 1 + else if( yz .ge. Interp%HI_KIND_TYPE_%lat_in(nlat_in) ) then + jcl = nlat_in + jcu = nlat_in + else + jcl = indl(Interp%HI_KIND_TYPE_%lat_in, yz) + jcu = indu(Interp%HI_KIND_TYPE_%lat_in, yz) + endif + + icl = 0 + icu = 0 + !--- cyclic condition, do we need to use do while + if( xz .gt. Interp%HI_KIND_TYPE_%lon_in(nlon_in) ) xz = xz - real(tpi,FMS_HI_KIND_) + if( xz .le. Interp%HI_KIND_TYPE_%lon_in(1) ) xz = xz + real(tpi,FMS_HI_KIND_) + if( xz .ge. Interp%HI_KIND_TYPE_%lon_in(nlon_in) ) then + icl = nlon_in + icu = 1 + Interp%HI_KIND_TYPE_%rat_x(i,j) = (xz - Interp%HI_KIND_TYPE_%lon_in(icl))/(Interp%HI_KIND_TYPE_%lon_in(icu)& + & - Interp%HI_KIND_TYPE_%lon_in(icl) + real(tpi,FMS_HI_KIND_)) + else + icl = indl(Interp%HI_KIND_TYPE_%lon_in, xz) + icu = indu(Interp%HI_KIND_TYPE_%lon_in, xz) + Interp%HI_KIND_TYPE_%rat_x(i,j) = (xz - Interp%HI_KIND_TYPE_%lon_in(icl))/(Interp%HI_KIND_TYPE_%lon_in(icu)& + & - Interp%HI_KIND_TYPE_%lon_in(icl)) + endif + Interp%j_lat(i,j,1) = jcl + Interp%j_lat(i,j,2) = jcu + Interp%i_lon(i,j,1) = icl + Interp%i_lon(i,j,2) = icu + if(jcl == jcu) then + Interp%HI_KIND_TYPE_%rat_y(i,j) = 0.0_kindl + else + Interp%HI_KIND_TYPE_%rat_y(i,j) = (yz-Interp%HI_KIND_TYPE_%lat_in(jcl))/(Interp%HI_KIND_TYPE_%lat_in(jcu)& + & - Interp%HI_KIND_TYPE_%lat_in(jcl)) + endif +! if(yz.gt.Interp%HI_KIND_TYPE_%lat_in(jcu)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_S_: +! yf < ycl, no valid boundary point') +! if(yz.lt.Interp%HI_KIND_TYPE_%lat_in(jcl)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_S_: +! yf > ycu, no valid boundary point') +! if(xz.gt.Interp%HI_KIND_TYPE_%lon_in(icu)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_S_: +! xf < xcl, no valid boundary point') +! if(xz.lt.Interp%HI_KIND_TYPE_%lon_in(icl)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_S_: +! xf > xcu, no valid boundary point') + enddo + enddo + end subroutine HORIZ_INTERP_BICUBIC_NEW_1D_S_ + + !> @brief Creates a new @ref horiz_interp_type + !! + !> Allocates space and initializes a derived-type variable + !! that contains pre-computed interpolation indices and weights. + subroutine HORIZ_INTERP_BICUBIC_NEW_1D_ ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo ) + + !----------------------------------------------------------------------- + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out, lat_out + integer, intent(in), optional :: verbose + logical, intent(in), optional :: src_modulo + integer :: i, j, ip1, im1, jp1, jm1 + logical :: src_is_modulo + integer :: nlon_in, nlat_in, nlon_out, nlat_out + integer :: jcl, jcu, icl, icu, jj + real(FMS_HI_KIND_) :: xz, yz + integer :: unit + integer, parameter :: kindl = FMS_HI_KIND_ !< real size at compile time + + if(present(verbose)) verbose_bicubic = verbose + src_is_modulo = .false. + if (present(src_modulo)) src_is_modulo = src_modulo + + !--- get the grid size + nlon_in = size(lon_in) ; nlat_in = size(lat_in) + nlon_out = size(lon_out); nlat_out = size(lat_out) + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out + allocate ( Interp%HI_KIND_TYPE_%wti (nlon_in, nlat_in, 3) ) + allocate ( Interp%HI_KIND_TYPE_%lon_in (nlon_in) ) + allocate ( Interp%HI_KIND_TYPE_%lat_in (nlat_in) ) + allocate ( Interp%HI_KIND_TYPE_%rat_x (nlon_out, nlat_out) ) + allocate ( Interp%HI_KIND_TYPE_%rat_y (nlon_out, nlat_out) ) + allocate ( Interp%i_lon (nlon_out, nlat_out, 2) ) + allocate ( Interp%j_lat (nlon_out, nlat_out, 2) ) + + Interp%HI_KIND_TYPE_%lon_in = lon_in + Interp%HI_KIND_TYPE_%lat_in = lat_in + + if ( verbose_bicubic > 0 ) then + unit = stdout() + write (unit,'(/,"Initialising bicubic interpolation, interface HORIZ_INTERP_BICUBIC_NEW_1D_")') + write (unit,'(/," Longitude of coarse grid points (radian): xc(i) i=1, ",i4)') Interp%nlon_src + write (unit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lon_in(jj),jj=1,Interp%nlon_src) + write (unit,'(/," Latitude of coarse grid points (radian): yc(j) j=1, ",i4)') Interp%nlat_src + write (unit,'(1x,10f10.4)') (Interp%HI_KIND_TYPE_%lat_in(jj),jj=1,Interp%nlat_src) + write (unit,*) + write (unit,'(/," Longitude of fine grid points (radian): xf(i) i=1, ",i4)') Interp%nlat_dst + write (unit,'(1x,10f10.4)') (lon_out(jj),jj=1,Interp%nlon_dst) + write (unit,'(/," Latitude of fine grid points (radian): yf(j) j=1, ",i4)') Interp%nlon_dst + write (unit,'(1x,10f10.4)') (lat_out(jj),jj=1,Interp%nlat_dst) + endif + + +!--------------------------------------------------------------------------- +! Find the x-derivative. Use central differences and forward or +! backward steps at the boundaries + + do j=1,nlat_in + do i=1,nlon_in + ip1=min(i+1,nlon_in) + im1=max(i-1,1) + Interp%HI_KIND_TYPE_%wti(i,j,1) = 1.0_kindl /(lon_in(ip1)-lon_in(im1)) + enddo + enddo + + +!--------------------------------------------------------------------------- + +! Find the y-derivative. Use central differences and forward or +! backward steps at the boundaries + do j=1,nlat_in + jp1=min(j+1,nlat_in) + jm1=max(j-1,1) + do i=1,nlon_in + Interp%HI_KIND_TYPE_%wti(i,j,2) = 1.0_kindl /(lat_in(jp1)-lat_in(jm1)) + enddo + enddo + +!--------------------------------------------------------------------------- + +! Find the xy-derivative. Use central differences and forward or +! backward steps at the boundaries + do j=1,nlat_in + jp1=min(j+1,nlat_in) + jm1=max(j-1,1) + do i=1,nlon_in + ip1=min(i+1,nlon_in) + im1=max(i-1,1) + Interp%HI_KIND_TYPE_%wti(i,j,3) = 1.0_kindl /((lon_in(ip1)-lon_in(im1))*(lat_in(jp1)-lat_in(jm1))) + enddo + enddo +!--------------------------------------------------------------------------- +! Now for each point at the dest-grid find the boundary points of +! the source grid + do j=1, nlat_out + yz = lat_out(j) + jcl = 0 + jcu = 0 + if( yz .le. lat_in(1) ) then + jcl = 1 + jcu = 1 + else if( yz .ge. lat_in(nlat_in) ) then + jcl = nlat_in + jcu = nlat_in + else + jcl = indl(lat_in, yz) + jcu = indu(lat_in, yz) + endif + do i=1,nlon_out + xz = lon_out(i) + icl = 0 + icu = 0 + !--- cyclic condition, do we need to use do while + if( xz .gt. lon_in(nlon_in) ) xz = xz - real(tpi,FMS_HI_KIND_) + if( xz .le. lon_in(1) ) xz = xz + real(tpi, FMS_HI_KIND_) + if( xz .ge. lon_in(nlon_in) ) then + icl = nlon_in + icu = 1 + Interp%HI_KIND_TYPE_%rat_x(i,j) = (xz - Interp%HI_KIND_TYPE_%lon_in(icl))/(Interp%HI_KIND_TYPE_%lon_in(icu)& + & - Interp%HI_KIND_TYPE_%lon_in(icl) + real(tpi,FMS_HI_KIND_)) + else + icl = indl(lon_in, xz) + icu = indu(lon_in, xz) + Interp%HI_KIND_TYPE_%rat_x(i,j) = (xz - Interp%HI_KIND_TYPE_%lon_in(icl))/(Interp%HI_KIND_TYPE_%lon_in(icu)& + & - Interp%HI_KIND_TYPE_%lon_in(icl)) + endif + icl = indl(lon_in, xz) + icu = indu(lon_in, xz) + Interp%j_lat(i,j,1) = jcl + Interp%j_lat(i,j,2) = jcu + Interp%i_lon(i,j,1) = icl + Interp%i_lon(i,j,2) = icu + if(jcl == jcu) then + Interp%HI_KIND_TYPE_%rat_y(i,j) = 0.0_kindl + else + Interp%HI_KIND_TYPE_%rat_y(i,j) = (yz- Interp%HI_KIND_TYPE_%lat_in(jcl))/(Interp%HI_KIND_TYPE_%lat_in(jcu)& + & - Interp%HI_KIND_TYPE_%lat_in(jcl)) + endif +! if(yz.gt.lat_in(jcu)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_: yf < +! ycl, no valid boundary point') +! if(yz.lt.lat_in(jcl)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_: yf > +! ycu, no valid boundary point') +! if(xz.gt.lon_in(icu)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_: xf < +! xcl, no valid boundary point') +! if(xz.lt.lon_in(icl)) call mpp_error(FATAL, ' HORIZ_INTERP_BICUBIC_NEW_1D_: xf > +! xcu, no valid boundary point') + enddo + enddo + + end subroutine HORIZ_INTERP_BICUBIC_NEW_1D_ + + !> @brief Perform bicubic horizontal interpolation + subroutine HORIZ_INTERP_BICUBIC_NEW_( Interp, data_in, data_out, verbose, mask_in, mask_out, missing_value, & + & missing_permit) + type (horiz_interp_type), intent(in) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + real(FMS_HI_KIND_) :: yz, ycu, ycl + real(FMS_HI_KIND_) :: xz, xcu, xcl + real(FMS_HI_KIND_) :: val, val1, val2 + real(FMS_HI_KIND_), dimension(4) :: y, y1, y2, y12 + integer :: icl, icu, jcl, jcu + integer :: iclp1, icup1, jclp1, jcup1 + integer :: iclm1, icum1, jclm1, jcum1 + integer :: i,j + integer, parameter :: kindl = FMS_HI_KIND_ !< set kind size at compile time + + if ( present(verbose) ) verbose_bicubic = verbose + + do j=1, Interp%nlat_dst + do i=1, Interp%nlon_dst + yz = Interp%HI_KIND_TYPE_%rat_y(i,j) + xz = Interp%HI_KIND_TYPE_%rat_x(i,j) + jcl = Interp%j_lat(i,j,1) + jcu = Interp%j_lat(i,j,2) + icl = Interp%i_lon(i,j,1) + icu = Interp%i_lon(i,j,2) + if( icl > icu ) then + iclp1 = icu + icum1 = icl + xcl = Interp%HI_KIND_TYPE_%lon_in(icl) + xcu = Interp%HI_KIND_TYPE_%lon_in(icu)+real(tpi, FMS_HI_KIND_) + else + iclp1 = min(icl+1,Interp%nlon_src) + icum1 = max(icu-1,1) + xcl = Interp%HI_KIND_TYPE_%lon_in(icl) + xcu = Interp%HI_KIND_TYPE_%lon_in(icu) + endif + iclm1 = max(icl-1,1) + icup1 = min(icu+1,Interp%nlon_src) + jclp1 = min(jcl+1,Interp%nlat_src) + jclm1 = max(jcl-1,1) + jcup1 = min(jcu+1,Interp%nlat_src) + jcum1 = max(jcu-1,1) + ycl = Interp%HI_KIND_TYPE_%lat_in(jcl) + ycu = Interp%HI_KIND_TYPE_%lat_in(jcu) +! xcl = Interp%HI_KIND_TYPE_%lon_in(icl) +! xcu = Interp%HI_KIND_TYPE_%lon_in(icu) + y(1) = data_in(icl,jcl) + y(2) = data_in(icu,jcl) + y(3) = data_in(icu,jcu) + y(4) = data_in(icl,jcu) + y1(1) = ( data_in(iclp1,jcl) - data_in(iclm1,jcl) ) * Interp%HI_KIND_TYPE_%wti(icl,jcl,1) + y1(2) = ( data_in(icup1,jcl) - data_in(icum1,jcl) ) * Interp%HI_KIND_TYPE_%wti(icu,jcl,1) + y1(3) = ( data_in(icup1,jcu) - data_in(icum1,jcu) ) * Interp%HI_KIND_TYPE_%wti(icu,jcu,1) + y1(4) = ( data_in(iclp1,jcu) - data_in(iclm1,jcu) ) * Interp%HI_KIND_TYPE_%wti(icl,jcu,1) + y2(1) = ( data_in(icl,jclp1) - data_in(icl,jclm1) ) * Interp%HI_KIND_TYPE_%wti(icl,jcl,2) + y2(2) = ( data_in(icu,jclp1) - data_in(icu,jclm1) ) * Interp%HI_KIND_TYPE_%wti(icu,jcl,2) + y2(3) = ( data_in(icu,jcup1) - data_in(icu,jcum1) ) * Interp%HI_KIND_TYPE_%wti(icu,jcu,2) + y2(4) = ( data_in(icl,jcup1) - data_in(icl,jcum1) ) * Interp%HI_KIND_TYPE_%wti(icl,jcu,2) + y12(1)= ( data_in(iclp1,jclp1) + data_in(iclm1,jclm1) - data_in(iclm1,jclp1) & + - data_in(iclp1,jclm1) ) * Interp%HI_KIND_TYPE_%wti(icl,jcl,3) + y12(2)= ( data_in(icup1,jclp1) + data_in(icum1,jclm1) - data_in(icum1,jclp1) & + - data_in(icup1,jclm1) ) * Interp%HI_KIND_TYPE_%wti(icu,jcl,3) + y12(3)= ( data_in(icup1,jcup1) + data_in(icum1,jcum1) - data_in(icum1,jcup1) & + - data_in(icup1,jcum1) ) * Interp%HI_KIND_TYPE_%wti(icu,jcu,3) + y12(4)= ( data_in(iclp1,jcup1) + data_in(iclm1,jcum1) - data_in(iclm1,jcup1) & + - data_in(iclp1,jcum1) ) * Interp%HI_KIND_TYPE_%wti(icl,jcu,3) + + call bcuint(y,y1,y2,y12,xcl,xcu,ycl,ycu,xz,yz,val,val1,val2) + data_out (i,j) = val + if(present(mask_out)) mask_out(i,j) = 1.0_kindl +!! dff_x(i,j) = val1 +!! dff_y(i,j) = val2 + enddo + enddo + return + end subroutine HORIZ_INTERP_BICUBIC_NEW_ + +!--------------------------------------------------------------------------- + + subroutine BCUINT_(y,y1,y2,y12,x1l,x1u,x2l,x2u,t,u,ansy,ansy1,ansy2) + real(FMS_HI_KIND_) ansy,ansy1,ansy2,x1l,x1u,x2l,x2u,y(4),y1(4),y12(4),y2(4) +! uses BCUCOF_ + integer i + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + real(FMS_HI_KIND_) t,u,c(4,4) + call bcucof(y,y1,y2,y12,x1u-x1l,x2u-x2l,c) + ansy=0.0_kindl + ansy2=0.0_kindl + ansy1=0.0_kindl + do i=4,1,-1 + ansy=t*ansy+((c(i,4)*u+c(i,3))*u+c(i,2))*u+c(i,1) +! ansy2=t*ansy2+(3.*c(i,4)*u+2.*c(i,3))*u+c(i,2) +! ansy1=u*ansy1+(3.*c(4,i)*t+2.*c(3,i))*t+c(2,i) + enddo +! ansy1=ansy1/(x1u-x1l) ! could be used for accuracy checks +! ansy2=ansy2/(x2u-x2l) ! could be used for accuracy checks + return +! (c) copr. 1986-92 numerical recipes software -3#(-)f. + end subroutine BCUINT_ +!--------------------------------------------------------------------------- + + subroutine BCUCOF_(y,y1,y2,y12,d1,d2,c) + real(FMS_HI_KIND_) d1,d2,c(4,4),y(4),y1(4),y12(4),y2(4) + integer i,j,k,l + real(FMS_HI_KIND_) d1d2,xx,cl(16),x(16) + integer, parameter :: kindl = FMS_HI_KIND_!< compiled kind type + !! n*0.0 represents n consecutive 0.0's + real(FMS_HI_KIND_), save, dimension(16,16) :: wt !< weights use + data wt/1.0_kindl, 0.0_kindl, -3.0_kindl, 2.0_kindl, 4*0.0_kindl, -3.0_kindl, 0.0_kindl, 9.0_kindl, -6.0_kindl, & + 2.0_kindl, 0.0_kindl, -6.0_kindl, 4.0_kindl, 8*0.0_kindl, 3.0_kindl, 0.0_kindl, -9.0_kindl, 6.0_kindl, & + -2.0_kindl, 0.0_kindl, 6.0_kindl, -4.0_kindl, 10*0.0_kindl, 9.0_kindl, -6.0_kindl, 2*0.0_kindl, & + -6.0_kindl, 4.0_kindl, 2*0.0_kindl, 3.0_kindl, -2.0_kindl, 6*0.0_kindl, -9.0_kindl, 6.0_kindl, & + 2*0.0_kindl, 6.0_kindl, -4.0_kindl, 4*0.0_kindl, 1.0_kindl, 0.0_kindl, -3.0_kindl, 2.0_kindl,-2.0_kindl,& + 0.0_kindl, 6.0_kindl, -4.0_kindl, 1.0_kindl, 0.0_kindl, -3.0_kindl, 2.0_kindl, 8*0.0_kindl, -1.0_kindl, & + 0.0_kindl, 3.0_kindl, -2.0_kindl, 1.0_kindl, 0.0_kindl, -3.0_kindl, 2.0_kindl, 10*0.0_kindl, -3.0_kindl,& + 2.0_kindl, 2*0.0_kindl, 3.0_kindl, -2.0_kindl, 6*0.0_kindl, 3.0_kindl, -2.0_kindl, 2*0.0_kindl, & + -6.0_kindl, 4.0_kindl, 2*0.0_kindl, 3.0_kindl, -2.0_kindl, 0.0_kindl, 1.0_kindl, -2.0_kindl, 1.0_kindl, & + 5*0.0_kindl, -3.0_kindl, 6.0_kindl, -3.0_kindl, 0.0_kindl, 2.0_kindl, -4.0_kindl, 2.0_kindl,9*0.0_kindl,& + 3.0_kindl, -6.0_kindl, 3.0_kindl, 0.0_kindl, -2.0_kindl, 4.0_kindl, -2.0_kindl, 10*0.0_kindl,-3.0_kindl,& + 3.0_kindl, 2*0.0_kindl, 2.0_kindl, -2.0_kindl, 2*0.0_kindl, -1.0_kindl, 1.0_kindl,6*0.0_kindl,3.0_kindl,& + -3.0_kindl, 2*0.0_kindl, -2.0_kindl, 2.0_kindl, 5*0.0_kindl, 1.0_kindl, -2.0_kindl, 1.0_kindl,0.0_kindl,& + -2.0_kindl, 4.0_kindl, -2.0_kindl, 0.0_kindl, 1.0_kindl, -2.0_kindl, 1.0_kindl, 9*0.0_kindl, -1.0_kindl,& + 2.0_kindl, -1.0_kindl, 0.0_kindl, 1.0_kindl, -2.0_kindl, 1.0_kindl, 10*0.0_kindl, 1.0_kindl, -1.0_kindl,& + 2*0.0_kindl, -1.0_kindl, 1.0_kindl, 6*0.0_kindl, -1.0_kindl, 1.0_kindl, 2*0.0_kindl, 2.0_kindl, & + -2.0_kindl, 2*0.0_kindl, -1.0_kindl, 1.0_kindl/ + + + + d1d2=d1*d2 + do i=1,4 + x(i)=y(i) + x(i+4)=y1(i)*d1 + x(i+8)=y2(i)*d2 + x(i+12)=y12(i)*d1d2 + enddo + do i=1,16 + xx=0.0_kindl + do k=1,16 + xx=xx+wt(i,k)*x(k) + enddo + cl(i)=xx + enddo + l=0 + do i=1,4 + do j=1,4 + l=l+1 + c(i,j)=cl(l) + enddo + enddo + return +! (c) copr. 1986-92 numerical recipes software -3#(-)f. + end subroutine BCUCOF_ + +!----------------------------------------------------------------------- + +!! TODO These routines are redundant, we can find the lower neighbor and add 1 +!> find the lower neighbour of xf in field xc, return is the index + function INDL_(xc, xf) + real(FMS_HI_KIND_), intent(in) :: xc(1:) + real(FMS_HI_KIND_), intent(in) :: xf + integer :: INDL_ + integer :: ii + INDL_ = 1 + do ii=1, size(xc) + if(xc(ii).gt.xf) return + INDL_ = ii + enddo + call mpp_error(FATAL,'Error in INDL_') + return + end function INDL_ + +!----------------------------------------------------------------------- + +!> find the upper neighbour of xf in field xc, return is the index + function INDU_(xc, xf) + real(FMS_HI_KIND_), intent(in) :: xc(1:) + real(FMS_HI_KIND_), intent(in) :: xf + integer :: INDU_ + integer :: ii + do ii=1, size(xc) + INDU_ = ii + if(xc(ii).gt.xf) return + enddo + call mpp_error(FATAL,'Error in INDU_') + return + end function INDU_ + +!----------------------------------------------------------------------- + + subroutine FILL_XY_(fi, ics, ice, jcs, jce, mask, maxpass) + integer, intent(in) :: ics,ice,jcs,jce + real(FMS_HI_KIND_), intent(inout) :: fi(ics:ice,jcs:jce) + real(FMS_HI_KIND_), intent(in), optional :: mask(ics:ice,jcs:jce) + integer, intent(in) :: maxpass + real(FMS_HI_KIND_) :: work_old(ics:ice,jcs:jce) + real(FMS_HI_KIND_) :: work_new(ics:ice,jcs:jce) + logical :: ready + integer, parameter :: kindl = FMS_HI_KIND_ + real(FMS_HI_KIND_), parameter :: blank = real(-1.e30, FMS_HI_KIND_) + real(FMS_HI_KIND_) :: tavr + integer :: ipass + integer :: inl, inr, jnl, jnu, i, j, is, js, iavr + + + ready = .false. + + work_new(:,:) = fi(:,:) + work_old(:,:) = work_new(:,:) + ipass = 0 + if ( present(mask) ) then + do while (.not.ready) + ipass = ipass+1 + ready = .true. + do j=jcs, jce + do i=ics, ice + if (work_old(i,j).le.blank) then + tavr=0.0_kindl + iavr=0 + inl = max(i-1,ics) + inr = min(i+1,ice) + jnl = max(j-1,jcs) + jnu = min(j+1,jce) + do js=jnl,jnu + do is=inl,inr + if (work_old(is,js) .ne. blank .and. mask(is,js).ne.0.0_kindl) then + tavr = tavr + work_old(is,js) + iavr = iavr+1 + endif + enddo + enddo + if (iavr.gt.0) then + if (iavr.eq.1) then +! spreading is not allowed if the only valid neighbor is a corner point +! otherwise an ill posed cellular automaton is established leading to +! a spreading of constant values in diagonal direction +! if all corner points are blanked the valid neighbor must be a direct one +! and spreading is allowed + if (work_old(inl,jnu).eq.blank.and.& + work_old(inr,jnu).eq.blank.and.& + work_old(inr,jnl).eq.blank.and.& + work_old(inl,jnl).eq.blank) then + work_new(i,j)=tavr/real(iavr,FMS_HI_KIND_) + ready = .false. + endif + else + work_new(i,j)=tavr/real(iavr,FMS_HI_KIND_) + ready = .false. + endif + endif + endif + enddo ! j + enddo ! i +! save changes made during this pass to work_old + work_old(:,:)=work_new(:,:) + if(ipass.eq.maxpass) ready=.true. + enddo !while (.not.ready) + fi(:,:) = work_new(:,:) + else + do while (.not.ready) + ipass = ipass+1 + ready = .true. + do j=jcs, jce + do i=ics, ice + if (work_old(i,j).le.blank) then + tavr=0.0_kindl + iavr=0 + inl = max(i-1,ics) + inr = min(i+1,ice) + jnl = max(j-1,jcs) + jnu = min(j+1,jce) + do is=inl,inr + do js=jnl,jnu + if (work_old(is,js).gt.blank) then + tavr = tavr + work_old(is,js) + iavr = iavr+1 + endif + enddo + enddo + if (iavr.gt.0) then + if (iavr.eq.1) then +! spreading is not allowed if the only valid neighbor is a corner point +! otherwise an ill posed cellular automaton is established leading to +! a spreading of constant values in diagonal direction +! if all corner points are blanked the valid neighbor must be a direct one +! and spreading is allowed + if (work_old(inl,jnu).le.blank.and. & + work_old(inr,jnu).le.blank.and. & + work_old(inr,jnl).le.blank.and. & + work_old(inl,jnl).le.blank) then + work_new(i,j)=tavr/real(iavr,FMS_HI_KIND_) + ready = .false. + endif + else + work_new(i,j)=tavr/real(iavr,FMS_HI_KIND_) + ready = .false. + endif + endif + endif + enddo ! j + enddo ! i +! save changes made during this pass to work_old + work_old(:,:)=work_new(:,:) + if(ipass.eq.maxpass) ready=.true. + enddo !while (.not.ready) + fi(:,:) = work_new(:,:) + endif + return + end subroutine FILL_XY_ +!> @} diff --git a/horiz_interp/include/horiz_interp_bicubic_r4.fh b/horiz_interp/include/horiz_interp_bicubic_r4.fh new file mode 100644 index 0000000000..a76afa5758 --- /dev/null +++ b/horiz_interp/include/horiz_interp_bicubic_r4.fh @@ -0,0 +1,52 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_bicubic +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r4_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals4_type + +#undef HORIZ_INTERP_BICUBIC_NEW_1D_S_ +#define HORIZ_INTERP_BICUBIC_NEW_1D_S_ horiz_interp_bicubic_new_1d_s_r4 + +#undef HORIZ_INTERP_BICUBIC_NEW_1D_ +#define HORIZ_INTERP_BICUBIC_NEW_1D_ horiz_interp_bicubic_new_1d_r4 + +#undef HORIZ_INTERP_BICUBIC_NEW_ +#define HORIZ_INTERP_BICUBIC_NEW_ horiz_interp_bicubic_r4 + +#undef BCUINT_ +#define BCUINT_ bcuint_r4 + +#undef BCUCOF_ +#define BCUCOF_ bcucof_r4 + +#undef INDL_ +#define INDL_ indl_r4 + +#undef INDU_ +#define INDU_ indu_r4 + +#undef FILL_XY_ +#define FILL_XY_ fill_xy_r4 + +#include "horiz_interp_bicubic.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_bicubic_r8.fh b/horiz_interp/include/horiz_interp_bicubic_r8.fh new file mode 100644 index 0000000000..4d0bac58db --- /dev/null +++ b/horiz_interp/include/horiz_interp_bicubic_r8.fh @@ -0,0 +1,52 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_bicubic +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r8_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals8_type + +#undef HORIZ_INTERP_BICUBIC_NEW_1D_S_ +#define HORIZ_INTERP_BICUBIC_NEW_1D_S_ horiz_interp_bicubic_new_1d_s_r8 + +#undef HORIZ_INTERP_BICUBIC_NEW_1D_ +#define HORIZ_INTERP_BICUBIC_NEW_1D_ horiz_interp_bicubic_new_1d_r8 + +#undef HORIZ_INTERP_BICUBIC_NEW_ +#define HORIZ_INTERP_BICUBIC_NEW_ horiz_interp_bicubic_r8 + +#undef BCUINT_ +#define BCUINT_ bcuint_r8 + +#undef BCUCOF_ +#define BCUCOF_ bcucof_r8 + +#undef INDL_ +#define INDL_ indl_r8 + +#undef INDU_ +#define INDU_ indu_r8 + +#undef FILL_XY_ +#define FILL_XY_ fill_xy_r8 + +#include "horiz_interp_bicubic.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_bilinear.inc b/horiz_interp/include/horiz_interp_bilinear.inc new file mode 100644 index 0000000000..7b6fcd7ed2 --- /dev/null +++ b/horiz_interp/include/horiz_interp_bilinear.inc @@ -0,0 +1,1230 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_bilinear_mod +!> @{ + subroutine HORIZ_INTERP_BILINEAR_NEW_1D_ ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo ) + + !----------------------------------------------------------------------- + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + integer, intent(in), optional :: verbose + logical, intent(in), optional :: src_modulo + + logical :: src_is_modulo + integer :: nlon_in, nlat_in, nlon_out, nlat_out, n, m + integer :: ie, is, je, js, ln_err, lt_err, warns, unit + real(FMS_HI_KIND_) :: wtw, wte, wts, wtn, lon, lat, tpi, hpi + real(FMS_HI_KIND_) :: glt_min, glt_max, gln_min, gln_max, min_lon, max_lon + integer,parameter :: kindl = FMS_HI_KIND_ + + warns = 0 + if(present(verbose)) warns = verbose + src_is_modulo = .true. + if (present(src_modulo)) src_is_modulo = src_modulo + + hpi = 0.5_kindl * real(pi, FMS_HI_KIND_) + tpi = 4.0_kindl * hpi + glt_min = hpi + glt_max = -hpi + gln_min = tpi + gln_max = -tpi + min_lon = 0.0_kindl + max_lon = tpi + ln_err = 0 + lt_err = 0 + !----------------------------------------------------------------------- + + allocate ( Interp % HI_KIND_TYPE_ % wti (size(lon_out,1),size(lon_out,2),2), & + Interp % HI_KIND_TYPE_ % wtj (size(lon_out,1),size(lon_out,2),2), & + Interp % i_lon (size(lon_out,1),size(lon_out,2),2), & + Interp % j_lat (size(lon_out,1),size(lon_out,2),2)) + !----------------------------------------------------------------------- + + nlon_in = size(lon_in(:)) ; nlat_in = size(lat_in(:)) + nlon_out = size(lon_out, 1); nlat_out = size(lon_out, 2) + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out + + if(src_is_modulo) then + if(lon_in(nlon_in) - lon_in(1) .gt. tpi + real(epsln, FMS_HI_KIND_)) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: '// & + 'The range of source grid longitude should be no larger than tpi') + + if(lon_in(1) .lt. 0.0_kindl .OR. lon_in(nlon_in) > tpi ) then + min_lon = lon_in(1) + max_lon = lon_in(nlon_in) + endif + endif + + do n = 1, nlat_out + do m = 1, nlon_out + lon = lon_out(m,n) + lat = lat_out(m,n) + + if(src_is_modulo) then + if(lon .lt. min_lon) then + lon = lon + tpi + else if(lon .gt. max_lon) then + lon = lon - tpi + endif + else ! when the input grid is in not cyclic, the output grid should located inside + ! the input grid + if((lon .lt. lon_in(1)) .or. (lon .gt. lon_in(nlon_in))) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: ' //& + 'when input grid is not modulo, output grid should locate inside input grid') + endif + + glt_min = min(lat,glt_min); glt_max = max(lat,glt_max) + gln_min = min(lon,gln_min); gln_max = max(lon,gln_max) + + is = indp(lon, lon_in ) + if( lon_in(is) .gt. lon ) is = max(is-1,1) + if( lon_in(is) .eq. lon .and. is .eq. nlon_in) is = max(is - 1,1) + ie = min(is+1,nlon_in) + if(lon_in(is) .ne. lon_in(ie) .and. lon_in(is) .le. lon) then + wtw = ( lon_in(ie) - lon) / (lon_in(ie) - lon_in(is) ) + else + ! east or west of the last data value. this could be because a + ! cyclic condition is needed or the dataset is too small. + ln_err = 1 + ie = 1 + is = nlon_in + if (lon_in(ie) .ge. lon ) then + wtw = (lon_in(ie) -lon)/(lon_in(ie)-lon_in(is)+tpi+real(epsln,FMS_HI_KIND_)) + else + wtw = (lon_in(ie)-lon+tpi+real(epsln,FMS_HI_KIND_))/(lon_in(ie)-lon_in(is)+tpi+real(epsln,FMS_HI_KIND_)) + endif + endif + wte = 1.0_kindl - wtw + + js = indp(lat, lat_in ) + + if( lat_in(js) .gt. lat ) js = max(js - 1, 1) + if( lat_in(js) .eq. lat .and. js .eq. nlat_in) js = max(js - 1, 1) + je = min(js + 1, nlat_in) + + if ( lat_in(js) .ne. lat_in(je) .and. lat_in(js) .le. lat) then + wts = ( lat_in(je) - lat )/(lat_in(je)-lat_in(js)) + else + ! north or south of the last data value. this could be because a + ! pole is not included in the data set or the dataset is too small. + ! in either case extrapolate north or south + lt_err = 1 + wts = 1.0_kindl + endif + + wtn = 1.0_kindl - wts + + Interp % i_lon (m,n,1) = is; Interp % i_lon (m,n,2) = ie + Interp % j_lat (m,n,1) = js; Interp % j_lat (m,n,2) = je + Interp % HI_KIND_TYPE_ % wti (m,n,1) = wtw + Interp % HI_KIND_TYPE_ % wti (m,n,2) = wte + Interp % HI_KIND_TYPE_ % wtj (m,n,1) = wts + Interp % HI_KIND_TYPE_ % wtj (m,n,2) = wtn + + enddo + enddo + + unit = stdout() + + if (ln_err .eq. 1 .and. warns > 0) then + write (unit,'(/,(1x,a))') & + '==> Warning: the geographic data set does not extend far ', & + ' enough east or west - a cyclic boundary ', & + ' condition was applied. check if appropriate ' + write (unit,'(/,(1x,a,2f8.4))') & + ' data required between longitudes:', gln_min, gln_max, & + ' data set is between longitudes:', lon_in(1), lon_in(nlon_in) + warns = warns - 1 + endif + + if (lt_err .eq. 1 .and. warns > 0) then + write (unit,'(/,(1x,a))') & + '==> Warning: the geographic data set does not extend far ',& + ' enough north or south - extrapolation from ',& + ' the nearest data was applied. this may create ',& + ' artificial gradients near a geographic pole ' + write (unit,'(/,(1x,a,2f8.4))') & + ' data required between latitudes:', glt_min, glt_max, & + ' data set is between latitudes:', lat_in(1), lat_in(nlat_in) + endif + + return + + end subroutine HORIZ_INTERP_BILINEAR_NEW_1D_ + + !####################################################################### + + !> Initialization routine. + !! + !> Allocates space and initializes a derived-type variable + !! that contains pre-computed interpolation indices and weights. + subroutine HORIZ_INTERP_BILINEAR_NEW_2D_ ( Interp, lon_in, lat_in, lon_out, lat_out, & + verbose, src_modulo, new_search, no_crash_when_not_found ) + + !----------------------------------------------------------------------- + type(horiz_interp_type), intent(inout) :: Interp !< A derived type variable containing indices + !! and weights for subsequent interpolations. To + !! reinitialize for different grid-to-grid interpolation + !! @ref horiz_interp_del must be used first. + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in !< Latitude (radians) for source data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lat_in !< Longitude (radians) for source data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out !< Longitude (radians) for output data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lat_out !< Latitude (radians) for output data grid + integer, intent(in), optional :: verbose !< flag for amount of print output + logical, intent(in), optional :: src_modulo !< indicates if the boundary condition + !! along zonal boundary is cyclic or not. Cyclic when true + logical, intent(in), optional :: new_search + logical, intent(in), optional :: no_crash_when_not_found + integer :: warns + logical :: src_is_modulo + integer :: nlon_in, nlat_in, nlon_out, nlat_out + integer :: m, n, is, ie, js, je, num_solution + real(FMS_HI_KIND_) :: lon, lat, quadra, x, y, y1, y2 + real(FMS_HI_KIND_) :: a1, b1, c1, d1, a2, b2, c2, d2, a, b, c + real(FMS_HI_KIND_) :: lon1, lat1, lon2, lat2, lon3, lat3, lon4, lat4 + real(FMS_HI_KIND_) :: tpi, lon_min, lon_max + real(FMS_HI_KIND_) :: epsln2 + logical :: use_new_search, no_crash + + integer, parameter :: kindl=FMS_HI_KIND_ + + tpi = 2.0_kindl * real(pi, FMS_HI_KIND_) + + warns = 0 + if(present(verbose)) warns = verbose + src_is_modulo = .true. + if (present(src_modulo)) src_is_modulo = src_modulo + use_new_search = .false. + if (present(new_search)) use_new_search = new_search + no_crash = .false. + if(present(no_crash_when_not_found)) no_crash = no_crash_when_not_found + + ! make sure lon and lat has the same dimension + if(size(lon_out,1) /= size(lat_out,1) .or. size(lon_out,2) /= size(lat_out,2) ) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear ' // & + 'interplation, the output grids should be geographical grids') + + if(size(lon_in,1) /= size(lat_in,1) .or. size(lon_in,2) /= size(lat_in,2) ) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: when using bilinear '// & + 'interplation, the input grids should be geographical grids') + + !--- get the grid size + nlon_in = size(lon_in,1) ; nlat_in = size(lat_in,2) + nlon_out = size(lon_out,1); nlat_out = size(lon_out,2) + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out + + allocate ( Interp % HI_KIND_TYPE_ % wti (size(lon_out,1),size(lon_out,2),2), & + Interp % HI_KIND_TYPE_ % wtj (size(lon_out,1),size(lon_out,2),2), & + Interp % i_lon (size(lon_out,1),size(lon_out,2),2), & + Interp % j_lat (size(lon_out,1),size(lon_out,2),2)) + + !--- first fine the neighbor points for the destination points. + if(use_new_search) then + epsln2 = real(epsln,FMS_HI_KIND_)* 1.0e5_kindl + call FIND_NEIGHBOR_NEW_(Interp, lon_in, lat_in, lon_out, lat_out, src_is_modulo, no_crash) + else + epsln2 = real(epsln,FMS_HI_KIND_) + call FIND_NEIGHBOR_(Interp, lon_in, lat_in, lon_out, lat_out, src_is_modulo) + endif + + !*************************************************************************** + ! Algorithm explanation (from disscussion with Steve Garner ) * + ! * + ! lon(x,y) = a1*x + b1*y + c1*x*y + d1 (1) * + ! lat(x,y) = a2*x + b2*y + c2*x*y + d2 (2) * + ! f (x,y) = a3*x + b3*y + c3*x*y + d3 (3) * + ! with x and y is between 0 and 1. * + ! lon1 = lon(0,0) = d1, lat1 = lat(0,0) = d2 * + ! lon2 = lon(1,0) = a1+d1, lat2 = lat(1,0) = a2+d2 * + ! lon3 = lon(1,1) = a1+b1+c1+d1, lat3 = lat(1,1) = a2+b2+c2+d2 * + ! lon4 = lon(0,1) = b1+d1, lat4 = lat(0,1) = b2+d2 * + ! where (lon1,lat1),(lon2,lat2),(lon3,lat3),(lon4,lat4) represents * + ! the four corners starting from the left lower corner of grid box * + ! that encloses a destination grid ( the rotation direction is * + ! counterclockwise ). With these conditions, we get * + ! a1 = lon2-lon1, a2 = lat2-lat1 * + ! b1 = lon4-lon1, b2 = lat4-lat1 * + ! c1 = lon3-lon2-lon4+lon1, c2 = lat3-lat2-lat4+lat1 * + ! d1 = lon1 d2 = lat1 * + ! So given any point (lon,lat), from equation (1) and (2) we can * + ! solve (x,y). * + ! From equation (3) * + ! f1 = f(0,0) = d3, f2 = f(1,0) = a3+d3 * + ! f3 = f(1,1) = a3+b3+c3+d3, f4 = f(0,1) = b3+d3 * + ! we obtain * + ! a3 = f2-f1, b3 = f4-f1 * + ! c3 = f3-f2-f4+f1, d3 = f1 * + ! at point (lon,lat) ---> (x,y) * + ! f(x,y) = (f2-f1)x + (f4-f1)y + (f3-f2-f4+f1)xy + f1 * + ! = f1*(1-x)*(1-y) + f2*x*(1-y) + f3*x*y + f4*y*(1-x) * + ! wtw=1-x; wte=x; wts=1-y; xtn=y * + ! * + !*************************************************************************** + + lon_min = minval(lon_in); + lon_max = maxval(lon_in); + !--- calculate the weight + do n = 1, nlat_out + do m = 1, nlon_out + lon = lon_out(m,n) + lat = lat_out(m,n) + if(lon .lt. lon_min) then + lon = lon + tpi + else if(lon .gt. lon_max) then + lon = lon - tpi + endif + is = Interp%i_lon(m,n,1); ie = Interp%i_lon(m,n,2) + js = Interp%j_lat(m,n,1); je = Interp%j_lat(m,n,2) + if( is == DUMMY) cycle + lon1 = lon_in(is,js); lat1 = lat_in(is,js); + lon2 = lon_in(ie,js); lat2 = lat_in(ie,js); + lon3 = lon_in(ie,je); lat3 = lat_in(ie,je); + lon4 = lon_in(is,je); lat4 = lat_in(is,je); + if(lon .lt. lon_min) then + lon1 = lon1 -tpi; lon4 = lon4 - tpi + else if(lon .gt. lon_max) then + lon2 = lon2 +tpi; lon3 = lon3 + tpi + endif + a1 = lon2-lon1 + b1 = lon4-lon1 + c1 = lon1+lon3-lon4-lon2 + d1 = lon1 + a2 = lat2-lat1 + b2 = lat4-lat1 + c2 = lat1+lat3-lat4-lat2 + d2 = lat1 + !--- the coefficient of the quadratic equation + a = b2*c1-b1*c2 + b = a1*b2-a2*b1+c1*d2-c2*d1+c2*lon-c1*lat + c = a2*lon-a1*lat+a1*d2-a2*d1 + quadra = b*b-4._kindl*a*c + if(abs(quadra) < real(epsln, FMS_HI_KIND_)) quadra = 0.0_kindl + if(quadra < 0.0_kindl) call mpp_error(FATAL, & + "horiz_interp_bilinear_mod: No solution existed for this quadratic equation") + if ( abs(a) .lt. epsln2) then ! a = 0 is a linear equation + if( abs(b) .lt. real(epsln,FMS_HI_KIND_)) call mpp_error(FATAL, & + "horiz_interp_bilinear_mod: no unique solution existed for this linear equation") + y = -c/b + else + y1 = 0.5_kindl*(-b+sqrt(quadra))/a + y2 = 0.5_kindl*(-b-sqrt(quadra))/a + if(abs(y1) < epsln2) y1 = 0.0_kindl + if(abs(y2) < epsln2) y2 = 0.0_kindl + if(abs(1.0_kindl-y1) < epsln2) y1 = 1.0_kindl + if(abs(1.0_kindl-y2) < epsln2) y2 = 1.0_kindl + num_solution = 0 + if(y1 >= 0.0_kindl .and. y1 <= 1.0_kindl) then + y = y1 + num_solution = num_solution +1 + endif + if(y2 >= 0.0_kindl .and. y2 <= 1.0_kindl) then + y = y2 + num_solution = num_solution + 1 + endif + if(num_solution == 0) then + call mpp_error(FATAL, "horiz_interp_bilinear_mod: No solution found") + else if(num_solution == 2) then + call mpp_error(FATAL, "horiz_interp_bilinear_mod: Two solutions found") + endif + endif + if(abs(a1+c1*y) < real(epsln,FMS_HI_KIND_)) call mpp_error(FATAL, & + "horiz_interp_bilinear_mod: the denomenator is 0") + if(abs(y) < epsln2) y = 0.0_kindl + if(abs(1.0_kindl-y) < epsln2) y = 1.0_kindl + x = (lon-b1*y-d1)/(a1+c1*y) + if(abs(x) < epsln2) x = 0.0_kindl + if(abs(1.0_kindl-x) < epsln2) x = 1.0_kindl + ! x and y should be between 0 and 1. + !! Added for ECDA + if(use_new_search) then + if (x < 0.0_kindl) x = 0.0_kindl ! snz + if (y < 0.0_kindl) y = 0.0_kindl ! snz + if (x > 1.0_kindl) x = 1.0_kindl + if (y > 1.0_kindl) y = 1.0_kindl + endif + if( x>1.0_kindl .or. x<0.0_kindl .or. y>1.0_kindl .or. y < 0.0_kindl) & + call mpp_error(FATAL, "horiz_interp_bilinear_mod: weight should be between 0 and 1") + Interp % HI_KIND_TYPE_ % wti(m,n,1)=1.0_kindl-x + Interp % HI_KIND_TYPE_ % wti(m,n,2)=x + Interp % HI_KIND_TYPE_ % wtj(m,n,1)=1.0_kindl-y + Interp % HI_KIND_TYPE_ % wtj(m,n,2)=y + enddo + enddo + + end subroutine + + !####################################################################### + !> this routine will search the source grid to fine the grid box that encloses + !! each destination grid. + subroutine FIND_NEIGHBOR_ ( Interp, lon_in, lat_in, lon_out, lat_out, src_modulo ) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + logical, intent(in) :: src_modulo + integer :: nlon_in, nlat_in, nlon_out, nlat_out + integer :: max_step, n, m, l, i, j, ip1, jp1, step + integer :: is, js, jstart, jend, istart, iend, npts + integer, allocatable, dimension(:) :: ilon, jlat + real(FMS_HI_KIND_) :: lon_min, lon_max, lon, lat, tpi + logical :: found + real(FMS_HI_KIND_) :: lon1, lat1, lon2, lat2, lon3, lat3, lon4, lat4 + + integer, parameter :: kindl=FMS_HI_KIND_ + + tpi = 2.0_kindl*real(pi, FMS_HI_KIND_) + nlon_in = size(lon_in,1) ; nlat_in = size(lat_in,2) + nlon_out = size(lon_out,1); nlat_out = size(lon_out,2) + + lon_min = minval(lon_in); + lon_max = maxval(lon_in); + + max_step = max(nlon_in,nlat_in) ! can be adjusted if needed + allocate(ilon(5*max_step), jlat(5*max_step) ) + + do n = 1, nlat_out + do m = 1, nlon_out + found = .false. + lon = lon_out(m,n) + lat = lat_out(m,n) + + if(src_modulo) then + if(lon .lt. lon_min) then + lon = lon + tpi + else if(lon .gt. lon_max) then + lon = lon - tpi + endif + else + if(lon .lt. lon_min .or. lon .gt. lon_max ) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: ' //& + 'when input grid is not modulo, output grid should locate inside input grid') + endif + !--- search for the surrounding four points locatioon. + if(m==1 .and. n==1) then + J_LOOP: do j = 1, nlat_in-1 + do i = 1, nlon_in + ip1 = i+1 + jp1 = j+1 + if(i==nlon_in) then + if(src_modulo)then + ip1 = 1 + else + cycle + endif + endif + lon1 = lon_in(i, j); lat1 = lat_in(i,j) + lon2 = lon_in(ip1,j); lat2 = lat_in(ip1,j) + lon3 = lon_in(ip1,jp1); lat3 = lat_in(ip1,jp1) + lon4 = lon_in(i, jp1); lat4 = lat_in(i, jp1) + + if(lon .lt. lon_min .or. lon .gt. lon_max) then + if(i .ne. nlon_in) then + cycle + else + if(lon .lt. lon_min) then + lon1 = lon1 -tpi; lon4 = lon4 - tpi + else if(lon .gt. lon_max) then + lon2 = lon2 +tpi; lon3 = lon3 + tpi + endif + endif + endif + + if(lat .ge. intersect(lon1,lat1,lon2,lat2,lon))then ! south + if(lon .le. intersect(lat2,lon2,lat3,lon3,lat))then ! east + if(lat .le. intersect(lon3,lat3,lon4,lat4,lon))then ! north + if(lon .ge. intersect(lat4,lon4,lat1,lon1,lat))then ! west + found = .true. + Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 + Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 + exit J_LOOP + endif + endif + endif + endif + enddo + enddo J_LOOP + else + step = 0 + do while ( .not. found .and. step .lt. max_step ) + !--- take the adajcent point as the starting point + if(m == 1) then + is = Interp % i_lon (m,n-1,1) + js = Interp % j_lat (m,n-1,1) + else + is = Interp % i_lon (m-1,n,1) + js = Interp % j_lat (m-1,n,1) + endif + if(step==0) then + npts = 1 + ilon(1) = is + jlat(1) = js + else + npts = 0 + !--- bottom boundary + jstart = max(js-step,1) + jend = min(js+step,nlat_in) + + do l = -step, step + i = is+l + if(src_modulo)then + if( i < 1) then + i = i + nlon_in + else if (i > nlon_in) then + i = i - nlon_in + endif + if( i < 1 .or. i > nlon_in) call mpp_error(FATAL, & + 'horiz_interp_bilinear_mod: max_step is too big, decrease max_step' ) + else + if( i < 1 .or. i > nlon_in) cycle + endif + + npts = npts + 1 + ilon(npts) = i + jlat(npts) = jstart + enddo + + !--- right and left boundary ----------------------------------------------- + istart = is - step + iend = is + step + if(src_modulo) then + if( istart < 1) istart = istart + nlon_in + if( iend > nlon_in) iend = iend - nlon_in + else + istart = max(istart,1) + iend = min(iend, nlon_in) + endif + do l = -step, step + j = js+l + if( j < 1 .or. j > nlat_in .or. j==jstart .or. j==jend) cycle + npts = npts+1 + ilon(npts) = istart + jlat(npts) = j + npts = npts+1 + ilon(npts) = iend + jlat(npts) = j + end do + + !--- top boundary + + do l = -step, step + i = is+l + if(src_modulo)then + if( i < 1) then + i = i + nlon_in + else if (i > nlon_in) then + i = i - nlon_in + endif + if( i < 1 .or. i > nlon_in) call mpp_error(FATAL, & + 'horiz_interp_bilinear_mod: max_step is too big, decrease max_step' ) + else + if( i < 1 .or. i > nlon_in) cycle + endif + + npts = npts + 1 + ilon(npts) = i + jlat(npts) = jend + enddo + + + end if + + !--- find the surrouding points + do l = 1, npts + i = ilon(l) + j = jlat(l) + ip1 = i+1 + if(ip1>nlon_in) then + if(src_modulo) then + ip1 = 1 + else + cycle + endif + endif + jp1 = j+1 + if(jp1>nlat_in) cycle + lon1 = lon_in(i, j); lat1 = lat_in(i,j) + lon2 = lon_in(ip1,j); lat2 = lat_in(ip1,j) + lon3 = lon_in(ip1,jp1); lat3 = lat_in(ip1,jp1) + lon4 = lon_in(i, jp1); lat4 = lat_in(i, jp1) + + if(lon .lt. lon_min .or. lon .gt. lon_max) then + if(i .ne. nlon_in) then + cycle + else + if(lon .lt. lon_min) then + lon1 = lon1 -tpi; lon4 = lon4 - tpi + else if(lon .gt. lon_max) then + lon2 = lon2 +tpi; lon3 = lon3 + tpi + endif + endif + endif + + if(lat .ge. intersect(lon1,lat1,lon2,lat2,lon))then ! south + if(lon .le. intersect(lat2,lon2,lat3,lon3,lat))then ! east + if(lat .le. intersect(lon3,lat3,lon4,lat4,lon))then !north + if(lon .ge. intersect(lat4,lon4,lat1,lon1,lat))then ! west + found = .true. + is=i; js=j + Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 + Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 + exit + endif + endif + endif + endif + enddo + step = step + 1 + enddo + endif + if(.not.found) then + print *,'lon,lat=',lon*180.0_kindl/real(PI,FMS_HI_KIND_),lat*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'npts=',npts + print *,'is,ie= ',istart,iend + print *,'js,je= ',jstart,jend + print *,'lon_in(is,js)=',lon_in(istart,jstart)*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'lon_in(ie,js)=',lon_in(iend,jstart)*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'lat_in(is,js)=',lat_in(istart,jstart)*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'lat_in(ie,js)=',lat_in(iend,jstart)*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'lon_in(is,je)=',lon_in(istart,jend)*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'lon_in(ie,je)=',lon_in(iend,jend)*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'lat_in(is,je)=',lat_in(istart,jend)*180.0_kindl/real(PI,FMS_HI_KIND_) + print *,'lat_in(ie,je)=',lat_in(iend,jend)*180.0_kindl/real(PI,FMS_HI_KIND_) + + call mpp_error(FATAL, & + 'FIND_NEIGHBOR_: the destination point is not inside the source grid' ) + endif + enddo + enddo + + end subroutine + + !####################################################################### + + !> The function will return true if the point x,y is inside a polygon, or + !! false if it is not. If the point is exactly on the edge of a polygon, + !! the function will return .true. + function INSIDE_POLYGON_(polyx, polyy, x, y) + real(FMS_HI_KIND_), dimension(:), intent(in) :: polyx !< longitude coordinates of corners + real(FMS_HI_KIND_), dimension(:), intent(in) :: polyy !< latitude coordinates of corners + real(FMS_HI_KIND_), intent(in) :: x !< x coordinate of point to be tested + real(FMS_HI_KIND_), intent(in) :: y !< y coordinate of point to be tested + logical :: INSIDE_POLYGON_ + integer :: i, j, nedges + real(FMS_HI_KIND_) :: xx + + INSIDE_POLYGON_ = .false. + nedges = size(polyx(:)) + j = nedges + do i = 1, nedges + if( (polyy(i) < y .AND. polyy(j) >= y) .OR. (polyy(j) < y .AND. polyy(i) >= y) ) then + xx = polyx(i)+(y-polyy(i))/(polyy(j)-polyy(i))*(polyx(j)-polyx(i)) + if( xx == x ) then + INSIDE_POLYGON_ = .true. + return + else if( xx < x ) then + INSIDE_POLYGON_ = .not. INSIDE_POLYGON_ + endif + endif + j = i + enddo + + return + + end function + + !####################################################################### + !> this routine will search the source grid to fine the grid box that encloses + !! each destination grid. + subroutine FIND_NEIGHBOR_NEW_( Interp, lon_in, lat_in, lon_out, lat_out, src_modulo, no_crash ) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + logical, intent(in) :: src_modulo, no_crash + integer :: nlon_in, nlat_in, nlon_out, nlat_out + integer :: max_step, n, m, l, i, j, ip1, jp1, step + integer :: is, js, jstart, jend, istart, iend, npts + integer, allocatable, dimension(:) :: ilon, jlat + real(FMS_HI_KIND_) :: lon_min, lon_max, lon, lat, tpi + logical :: found + real(FMS_HI_KIND_) :: polyx(4), polyy(4) + real(FMS_HI_KIND_) :: min_lon, min_lat, max_lon, max_lat + + integer, parameter :: step_div=8, kindl = FMS_HI_KIND_ + + tpi = 2.0_kindl * real(pi, FMS_HI_KIND_) + nlon_in = size(lon_in,1) ; nlat_in = size(lat_in,2) + nlon_out = size(lon_out,1); nlat_out = size(lon_out,2) + + lon_min = minval(lon_in); + lon_max = maxval(lon_in); + + max_step = min(nlon_in,nlat_in)/step_div ! can be adjusted if needed + allocate(ilon(step_div*max_step), jlat(step_div*max_step) ) + + do n = 1, nlat_out + do m = 1, nlon_out + found = .false. + lon = lon_out(m,n) + lat = lat_out(m,n) + + if(src_modulo) then + if(lon .lt. lon_min) then + lon = lon + tpi + else if(lon .gt. lon_max) then + lon = lon - tpi + endif + else + if(lon .lt. lon_min .or. lon .gt. lon_max ) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: ' //& + 'when input grid is not modulo, output grid should locate inside input grid') + endif + !--- search for the surrounding four points locatioon. + if(m==1 .and. n==1) then + J_LOOP: do j = 1, nlat_in-1 + do i = 1, nlon_in + ip1 = i+1 + jp1 = j+1 + if(i==nlon_in) then + if(src_modulo)then + ip1 = 1 + else + cycle + endif + endif + + polyx(1) = lon_in(i, j); polyy(1) = lat_in(i,j) + polyx(2) = lon_in(ip1,j); polyy(2) = lat_in(ip1,j) + polyx(3) = lon_in(ip1,jp1); polyy(3) = lat_in(ip1,jp1) + polyx(4) = lon_in(i, jp1); polyy(4) = lat_in(i, jp1) + if(lon .lt. lon_min .or. lon .gt. lon_max) then + if(i .ne. nlon_in) then + cycle + else + if(lon .lt. lon_min) then + polyx(1) = polyx(1) -tpi; polyx(4) = polyx(4) - tpi + else if(lon .gt. lon_max) then + polyx(2) = polyx(2) +tpi; polyx(3) = polyx(3) + tpi + endif + endif + endif + + min_lon = minval(polyx) + max_lon = maxval(polyx) + min_lat = minval(polyy) + max_lat = maxval(polyy) +! if( lon .GE. min_lon .AND. lon .LE. max_lon .AND. & +! lat .GE. min_lat .AND. lat .LE. max_lat ) then +! print*, 'i =', i, 'j = ', j +! print '(5f15.11)', lon, polyx +! print '(5f15.11)', lat, polyy +! endif + + if(INSIDE_POLYGON_(polyx, polyy, lon, lat)) then + found = .true. +! print*, " found ", i, j + Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 + Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 + exit J_LOOP + endif + enddo + enddo J_LOOP + else + step = 0 + do while ( .not. found .and. step .lt. max_step ) + !--- take the adajcent point as the starting point + if(m == 1) then + is = Interp % i_lon (m,n-1,1) + js = Interp % j_lat (m,n-1,1) + else + is = Interp % i_lon (m-1,n,1) + js = Interp % j_lat (m-1,n,1) + endif + if(step==0) then + npts = 1 + ilon(1) = is + jlat(1) = js + else + npts = 0 + !--- bottom and top boundary + jstart = max(js-step,1) + jend = min(js+step,nlat_in) + + do l = -step, step + i = is+l + if(src_modulo)then + if( i < 1) then + i = i + nlon_in + else if (i > nlon_in) then + i = i - nlon_in + endif + if( i < 1 .or. i > nlon_in) call mpp_error(FATAL, & + 'horiz_interp_bilinear_mod: max_step is too big, decrease max_step' ) + else + if( i < 1 .or. i > nlon_in) cycle + endif + + npts = npts + 1 + ilon(npts) = i + jlat(npts) = jstart + npts = npts + 1 + ilon(npts) = i + jlat(npts) = jend + enddo + + !--- right and left boundary ----------------------------------------------- + istart = is - step + iend = is + step + if(src_modulo) then + if( istart < 1) istart = istart + nlon_in + if( iend > nlon_in) iend = iend - nlon_in + else + istart = max(istart,1) + iend = min(iend, nlon_in) + endif + do l = -step, step + j = js+l + if( j < 1 .or. j > nlat_in) cycle + npts = npts+1 + ilon(npts) = istart + jlat(npts) = j + npts = npts+1 + ilon(npts) = iend + jlat(npts) = j + end do + end if + + !--- find the surrouding points + do l = 1, npts + i = ilon(l) + j = jlat(l) + ip1 = i+1 + if(ip1>nlon_in) then + if(src_modulo) then + ip1 = 1 + else + cycle + endif + endif + jp1 = j+1 + if(jp1>nlat_in) cycle + polyx(1) = lon_in(i, j); polyy(1) = lat_in(i,j) + polyx(2) = lon_in(ip1,j); polyy(2) = lat_in(ip1,j) + polyx(3) = lon_in(ip1,jp1); polyy(3) = lat_in(ip1,jp1) + polyx(4) = lon_in(i, jp1); polyy(4) = lat_in(i, jp1) + if(INSIDE_POLYGON_(polyx, polyy, lon, lat)) then + found = .true. + Interp % i_lon (m,n,1) = i; Interp % i_lon (m,n,2) = ip1 + Interp % j_lat (m,n,1) = j; Interp % j_lat (m,n,2) = jp1 + exit + endif + enddo + step = step + 1 + enddo + endif + if(.not.found) then + if(no_crash) then + Interp % i_lon (m,n,1:2) = DUMMY + Interp % j_lat (m,n,1:2) = DUMMY + print*,'lon,lat=',lon,lat ! snz + else + call mpp_error(FATAL, & + 'horiz_interp_bilinear_mod: the destination point is not inside the source grid' ) + endif + endif + enddo + enddo + + end subroutine + + !####################################################################### + function INTERSECT_(x1, y1, x2, y2, x) + real(FMS_HI_KIND_), intent(in) :: x1, y1, x2, y2, x + real(FMS_HI_KIND_) :: INTERSECT_ + + INTERSECT_ = (y2-y1)*(x-x1)/(x2-x1) + y1 + + return + + end function INTERSECT_ + + !####################################################################### + + !> Subroutine for performing the horizontal interpolation between two grids + !! + !! @ref horiz_interp_bilinear_new must be called before calling this routine. + subroutine HORIZ_INTERP_BILINEAR_ ( Interp, data_in, data_out, verbose, mask_in,mask_out, & + missing_value, missing_permit, new_handle_missing ) + !----------------------------------------------------------------------- + type (horiz_interp_type), intent(in) :: Interp !< Derived type variable containing + !! interpolation indices and weights. Returned by a + !! previous call to horiz_interp_bilinear_new + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in !< input data on source grid + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out !< output data on source grid + integer, intent(in), optional :: verbose !< 0 = no output; 1 = min,max,means; 2 = + !! all output + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in !< Input mask, must be the same size as + !! the input data. The real(FMS_HI_KIND_) value of mask_in must be in the + !! range (0.,1.). Set mask_in=0.0 for data points + !! that should not be used or have missing data + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out !< output mask that specifies whether + !! data was computed + real(FMS_HI_KIND_), intent(in), optional :: missing_value + integer, intent(in), optional :: missing_permit + logical, intent(in), optional :: new_handle_missing + !----------------------------------------------------------------------- + integer :: nlon_in, nlat_in, nlon_out, nlat_out, n, m, & + is, ie, js, je, iverbose, max_missing, num_missing, & + miss_in, miss_out, unit + real(FMS_HI_KIND_) :: dwtsum, wtsum, min_in, max_in, avg_in, & + min_out, max_out, avg_out, wtw, wte, wts, wtn + real(FMS_HI_KIND_) :: mask(size(data_in,1), size(data_in,2) ) + logical :: set_to_missing, is_missing(4), new_handler + real(FMS_HI_KIND_) :: f1, f2, f3, f4, middle, w, s + integer, parameter :: kindl = FMS_HI_KIND_ + + num_missing = 0 + + nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src + nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst + + if(present(mask_in)) then + mask = mask_in + else + mask = 1.0_kindl + endif + + if (present(verbose)) then + iverbose = verbose + else + iverbose = 0 + endif + + if(present(missing_permit)) then + max_missing = missing_permit + else + max_missing = 0 + endif + + if(present(new_handle_missing)) then + new_handler = new_handle_missing + else + new_handler = .false. + endif + + if(max_missing .gt. 3 .or. max_missing .lt. 0) call mpp_error(FATAL, & + 'horiz_interp_bilinear_mod: missing_permit should be between 0 and 3') + + if (size(data_in,1) /= nlon_in .or. size(data_in,2) /= nlat_in) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: size of input array incorrect') + + if (size(data_out,1) /= nlon_out .or. size(data_out,2) /= nlat_out) & + call mpp_error(FATAL,'horiz_interp_bilinear_mod: size of output array incorrect') + + if(new_handler) then + if( .not. present(missing_value) ) call mpp_error(FATAL, & + "horiz_interp_bilinear_mod: misisng_value must be present when new_handle_missing is .true.") + if( present(mask_in) ) call mpp_error(FATAL, & + "horiz_interp_bilinear_mod: mask_in should not be present when new_handle_missing is .true.") + do n = 1, nlat_out + do m = 1, nlon_out + is = Interp % i_lon (m,n,1); ie = Interp % i_lon (m,n,2) + js = Interp % j_lat (m,n,1); je = Interp % j_lat (m,n,2) + wtw = Interp % HI_KIND_TYPE_ % wti (m,n,1) + wte = Interp % HI_KIND_TYPE_ % wti (m,n,2) + wts = Interp % HI_KIND_TYPE_ % wtj (m,n,1) + wtn = Interp % HI_KIND_TYPE_ % wtj (m,n,2) + + is_missing = .false. + num_missing = 0 + set_to_missing = .false. + if(data_in(is,js) == missing_value) then + num_missing = num_missing+1 + is_missing(1) = .true. + if(wtw .GE. 0.5_kindl .AND. wts .GE. 0.5_kindl) set_to_missing = .true. + endif + + if(data_in(ie,js) == missing_value) then + num_missing = num_missing+1 + is_missing(2) = .true. + if(wte .GE. 0.5_kindl .AND. wts .GE. 0.5_kindl ) set_to_missing = .true. + endif + if(data_in(ie,je) == missing_value) then + num_missing = num_missing+1 + is_missing(3) = .true. + if(wte .GE. 0.5_kindl .AND. wtn .GE. 0.5_kindl ) set_to_missing = .true. + endif + if(data_in(is,je) == missing_value) then + num_missing = num_missing+1 + is_missing(4) = .true. + if(wtw .GE. 0.5_kindl .AND. wtn .GE. 0.5_kindl) set_to_missing = .true. + endif + + if( num_missing == 4 .OR. set_to_missing ) then + data_out(m,n) = missing_value + if(present(mask_out)) mask_out(m,n) = 0.0_kindl + cycle + else if(num_missing == 0) then + f1 = data_in(is,js) + f2 = data_in(ie,js) + f3 = data_in(ie,je) + f4 = data_in(is,je) + w = wtw + s = wts + else if(num_missing == 3) then !--- three missing value + if(.not. is_missing(1) ) then + data_out(m,n) = data_in(is,js) + else if(.not. is_missing(2) ) then + data_out(m,n) = data_in(ie,js) + else if(.not. is_missing(3) ) then + data_out(m,n) = data_in(ie,je) + else if(.not. is_missing(4) ) then + data_out(m,n) = data_in(is,je) + endif + if(present(mask_out) ) mask_out(m,n) = 1.0_kindl + cycle + else !--- one or two missing value + if( num_missing == 1) then + if( is_missing(1) .OR. is_missing(3) ) then + middle = 0.5_kindl *(data_in(ie,js)+data_in(is,je)) + else + middle = 0.5_kindl *(data_in(is,js)+data_in(ie,je)) + endif + else ! num_missing = 2 + if( is_missing(1) .AND. is_missing(2) ) then + middle = 0.5_kindl *(data_in(ie,je)+data_in(is,je)) + else if( is_missing(1) .AND. is_missing(3) ) then + middle = 0.5_kindl *(data_in(ie,js)+data_in(is,je)) + else if( is_missing(1) .AND. is_missing(4) ) then + middle = 0.5_kindl *(data_in(ie,js)+data_in(ie,je)) + else if( is_missing(2) .AND. is_missing(3) ) then + middle = 0.5_kindl *(data_in(is,js)+data_in(is,je)) + else if( is_missing(2) .AND. is_missing(4) ) then + middle = 0.5_kindl*(data_in(is,js)+data_in(ie,je)) + else if( is_missing(3) .AND. is_missing(4) ) then + middle = 0.5_kindl*(data_in(is,js)+data_in(ie,js)) + endif + endif + + if( wtw .GE. 0.5_kindl .AND. wts .GE. 0.5_kindl ) then ! zone 1 + w = 2.0_kindl*(wtw-0.5_kindl) + s = 2.0_kindl*(wts-0.5_kindl) + f1 = data_in(is,js) + if(is_missing(2)) then + f2 = f1 + else + f2 = 0.5_kindl*(data_in(is,js)+data_in(ie,js)) + endif + f3 = middle + if(is_missing(4)) then + f4 = f1 + else + f4 = 0.5_kindl*(data_in(is,js)+data_in(is,je)) + endif + else if( wte .GE. 0.5_kindl .AND. wts .GE. 0.5_kindl ) then ! zone 2 + w = 2.0_kindl*(1.0_kindl-wte) + s = 2.0_kindl*(wts-0.5_kindl) + f2 = data_in(ie,js) + if(is_missing(1)) then + f1 = f2 + else + f1 = 0.5_kindl*(data_in(is,js)+data_in(ie,js)) + endif + f4 = middle + if(is_missing(3)) then + f3 = f2 + else + f3 = 0.5_kindl*(data_in(ie,js)+data_in(ie,je)) + endif + else if( wte .GE. 0.5_kindl .AND. wtn .GE. 0.5_kindl ) then ! zone 3 + w = 2.0_kindl*(1.0_kindl-wte) + s = 2.0_kindl*(1.0_kindl-wtn) + f3 = data_in(ie,je) + if(is_missing(2)) then + f2 = f3 + else + f2 = 0.5_kindl*(data_in(ie,js)+data_in(ie,je)) + endif + f1 = middle + if(is_missing(4)) then + f4 = f3 + else + f4 = 0.5_kindl*(data_in(ie,je)+data_in(is,je)) + endif + else if( wtw .GE. 0.5_kindl .AND. wtn .GE. 0.5_kindl ) then ! zone 4 + w = 2.0_kindl*(wtw-0.5_kindl) + s = 2.0_kindl*(1.0_kindl-wtn) + f4 = data_in(is,je) + if(is_missing(1)) then + f1 = f4 + else + f1 = 0.5_kindl*(data_in(is,js)+data_in(is,je)) + endif + f2 = middle + if(is_missing(3)) then + f3 = f4 + else + f3 = 0.5_kindl*(data_in(ie,je)+data_in(is,je)) + endif + else + call mpp_error(FATAL, & + "horiz_interp_bilinear_mod: the point should be in one of the four zone") + endif + endif + + data_out(m,n) = f3 + (f4-f3)*w + (f2-f3)*s + ((f1-f2)+(f3-f4))*w*s + if(present(mask_out)) mask_out(m,n) = 1.0_kindl + enddo + enddo + else + do n = 1, nlat_out + do m = 1, nlon_out + is = Interp % i_lon (m,n,1); ie = Interp % i_lon (m,n,2) + js = Interp % j_lat (m,n,1); je = Interp % j_lat (m,n,2) + wtw = Interp % HI_KIND_TYPE_ % wti (m,n,1) + wte = Interp % HI_KIND_TYPE_ % wti (m,n,2) + wts = Interp % HI_KIND_TYPE_ % wtj (m,n,1) + wtn = Interp % HI_KIND_TYPE_ % wtj (m,n,2) + + if(present(missing_value) ) then + num_missing = 0 + if(data_in(is,js) == missing_value) then + num_missing = num_missing+1 + mask(is,js) = 0.0_kindl + endif + if(data_in(ie,js) == missing_value) then + num_missing = num_missing+1 + mask(ie,js) = 0.0_kindl + endif + if(data_in(ie,je) == missing_value) then + num_missing = num_missing+1 + mask(ie,je) = 0.0_kindl + endif + if(data_in(is,je) == missing_value) then + num_missing = num_missing+1 + mask(is,je) = 0.0_kindl + endif + endif + + dwtsum = data_in(is,js)*mask(is,js)*wtw*wts & + + data_in(ie,js)*mask(ie,js)*wte*wts & + + data_in(ie,je)*mask(ie,je)*wte*wtn & + + data_in(is,je)*mask(is,je)*wtw*wtn + wtsum = mask(is,js)*wtw*wts + mask(ie,js)*wte*wts & + + mask(ie,je)*wte*wtn + mask(is,je)*wtw*wtn + + if(.not. present(mask_in) .and. .not. present(missing_value)) wtsum = 1.0_kindl + + if(num_missing .gt. max_missing ) then + data_out(m,n) = missing_value + if(present(mask_out)) mask_out(m,n) = 0.0_kindl + else if(wtsum .lt. real(epsln, FMS_HI_KIND_)) then + if(present(missing_value)) then + data_out(m,n) = missing_value + else + data_out(m,n) = 0.0_kindl + endif + if(present(mask_out)) mask_out(m,n) = 0.0_kindl + else + data_out(m,n) = dwtsum/wtsum + if(present(mask_out)) mask_out(m,n) = wtsum + endif + enddo + enddo + endif + !*********************************************************************** + ! compute statistics: minimum, maximum, and mean + !----------------------------------------------------------------------- + if (iverbose > 0) then + + ! compute statistics of input data + + call stats (data_in, min_in, max_in, avg_in, miss_in, missing_value, mask_in) + + ! compute statistics of output data + call stats (data_out, min_out, max_out, avg_out, miss_out, missing_value, mask_out) + + !---- output statistics ---- + unit = stdout() + write (unit,900) + write (unit,901) min_in ,max_in, avg_in + if (present(mask_in)) write (unit,903) miss_in + write (unit,902) min_out,max_out,avg_out + if (present(mask_out)) write (unit,903) miss_out + +900 format (/,1x,10('-'),' output from horiz_interp ',10('-')) +901 format (' input: min=',f16.9,' max=',f16.9,' avg=',f22.15) +902 format (' output: min=',f16.9,' max=',f16.9,' avg=',f22.15) +903 format (' number of missing points = ',i6) + + endif + + return + + end subroutine + + + !####################################################################### + !> @returns index of nearest data point to "value" + !! if "value" is outside the domain of "array" then INDP_ = 1 + !! or "ia" depending on whether array(1) or array(ia) is + !! closest to "value" + function INDP_ (value, array) + integer :: INDP_ !< index of nearest data point within "array" + !! corresponding to "value". + real(FMS_HI_KIND_), dimension(:), intent(in) :: array !< array of data points (must be monotonically increasing) + real(FMS_HI_KIND_), intent(in) :: value !< arbitrary data, same units as elements in 'array' + + !======================================================================= + + integer i, ia, unit + logical keep_going + ! + ia = size(array(:)) + do i=2,ia + if (array(i) .lt. array(i-1)) then + unit = stdout() + write (unit,*) & + ' => Error: array must be monotonically increasing in "INDP_"' , & + ' when searching for nearest element to value=',value + write (unit,*) ' array(i) < array(i-1) for i=',i + write (unit,*) ' array(i) for i=1..ia follows:' + call mpp_error() + endif + enddo + if (value .lt. array(1) .or. value .gt. array(ia)) then + if (value .lt. array(1)) INDP_ = 1 + if (value .gt. array(ia)) INDP_ = ia + else + i=1 + keep_going = .true. + do while (i .le. ia .and. keep_going) + i = i+1 + if (value .le. array(i)) then + INDP_ = i + if (array(i)-value .gt. value-array(i-1)) INDP_ = i-1 + keep_going = .false. + endif + enddo + endif + return + end function INDP_ +!> @} diff --git a/horiz_interp/include/horiz_interp_bilinear_r4.fh b/horiz_interp/include/horiz_interp_bilinear_r4.fh new file mode 100644 index 0000000000..bcb96fcdec --- /dev/null +++ b/horiz_interp/include/horiz_interp_bilinear_r4.fh @@ -0,0 +1,52 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_bilinear +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r4_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals4_type + +#undef HORIZ_INTERP_BILINEAR_NEW_1D_ +#define HORIZ_INTERP_BILINEAR_NEW_1D_ horiz_interp_bilinear_new_1d_r4 + +#undef HORIZ_INTERP_BILINEAR_NEW_2D_ +#define HORIZ_INTERP_BILINEAR_NEW_2D_ horiz_interp_bilinear_new_2d_r4 + +#undef HORIZ_INTERP_BILINEAR_ +#define HORIZ_INTERP_BILINEAR_ horiz_interp_bilinear_r4 + +#undef FIND_NEIGHBOR_ +#define FIND_NEIGHBOR_ find_neighbor_r4 + +#undef FIND_NEIGHBOR_NEW_ +#define FIND_NEIGHBOR_NEW_ find_neighbor_new_r4 + +#undef INSIDE_POLYGON_ +#define INSIDE_POLYGON_ inside_polygon_r4 + +#undef INTERSECT_ +#define INTERSECT_ intersect_r4 + +#undef INDP_ +#define INDP_ indp_r4 + +#include "horiz_interp_bilinear.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_bilinear_r8.fh b/horiz_interp/include/horiz_interp_bilinear_r8.fh new file mode 100644 index 0000000000..af68b4c454 --- /dev/null +++ b/horiz_interp/include/horiz_interp_bilinear_r8.fh @@ -0,0 +1,52 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_bilinear +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r8_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals8_type + +#undef HORIZ_INTERP_BILINEAR_NEW_1D_ +#define HORIZ_INTERP_BILINEAR_NEW_1D_ horiz_interp_bilinear_new_1d_r8 + +#undef HORIZ_INTERP_BILINEAR_NEW_2D_ +#define HORIZ_INTERP_BILINEAR_NEW_2D_ horiz_interp_bilinear_new_2d_r8 + +#undef HORIZ_INTERP_BILINEAR_ +#define HORIZ_INTERP_BILINEAR_ horiz_interp_bilinear_r8 + +#undef FIND_NEIGHBOR_ +#define FIND_NEIGHBOR_ find_neighbor_r8 + +#undef FIND_NEIGHBOR_NEW_ +#define FIND_NEIGHBOR_NEW_ find_neighbor_new_r8 + +#undef INSIDE_POLYGON_ +#define INSIDE_POLYGON_ inside_polygon_r8 + +#undef INTERSECT_ +#define INTERSECT_ intersect_r8 + +#undef INDP_ +#define INDP_ indp_r8 + +#include "horiz_interp_bilinear.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_conserve.inc b/horiz_interp/include/horiz_interp_conserve.inc new file mode 100644 index 0000000000..3fe5168e4b --- /dev/null +++ b/horiz_interp/include/horiz_interp_conserve.inc @@ -0,0 +1,926 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_conserve_mod +!> @{ +subroutine HORIZ_INTERP_CONSERVE_NEW_1DX1D_ ( Interp, lon_in, lat_in, lon_out, lat_out, verbose) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out, lat_out + integer, intent(in), optional :: verbose + + !----------------------------------------------------------------------- + real(FMS_HI_KIND_), dimension(size(lat_out(:))-1,2) :: sph + real(FMS_HI_KIND_), dimension(size(lon_out(:))-1,2) :: theta + real(FMS_HI_KIND_), dimension(size(lat_in(:))) :: slat_in + real(FMS_HI_KIND_), dimension(size(lon_in(:))-1) :: dlon_in + real(FMS_HI_KIND_), dimension(size(lat_in(:))-1) :: dsph_in + real(FMS_HI_KIND_), dimension(size(lon_out(:))-1) :: dlon_out + real(FMS_HI_KIND_), dimension(size(lat_out(:))-1) :: dsph_out + real(FMS_HI_KIND_) :: blon, fac, hpi, tpi, eps + integer, parameter :: num_iters = 4 + integer :: i, j, m, n, nlon_in, nlat_in, nlon_out, nlat_out, & + iverbose, m2, n2, iter + logical :: s2n + character(len=64) :: mesg + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + + if(.not. module_is_initialized) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_1DX1D_: horiz_interp_conserve_init is not called') + + if(great_circle_algorithm) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_1DX1D_: great_circle_algorithm is not implemented, contact developer') + !----------------------------------------------------------------------- + iverbose = 0; if (present(verbose)) iverbose = verbose + + pe = mpp_pe() + root_pe = mpp_root_pe() + !----------------------------------------------------------------------- + hpi = 0.5_kindl * real(pi, FMS_HI_KIND_) + tpi = 4.0_kindl * real(hpi, FMS_HI_KIND_) + Interp%version = 1 + nlon_in = size(lon_in(:))-1; nlat_in = size(lat_in(:))-1 + nlon_out = size(lon_out(:))-1; nlat_out = size(lat_out(:))-1 + + allocate ( Interp % HI_KIND_TYPE_ % facj (nlat_out,2), Interp % jlat (nlat_out,2), & + Interp % HI_KIND_TYPE_ % faci (nlon_out,2), Interp % ilon (nlon_out,2), & + Interp % HI_KIND_TYPE_ % area_src (nlon_in, nlat_in), & + Interp % HI_KIND_TYPE_ % area_dst (nlon_out, nlat_out) ) + + !----------------------------------------------------------------------- + ! --- set-up for input grid boxes --- + + do j = 1, nlat_in+1 + slat_in(j) = sin(lat_in(j)) + enddo + + do j = 1, nlat_in + dsph_in(j) = abs(slat_in(j+1)-slat_in(j)) + enddo + + do i = 1,nlon_in + dlon_in(i) = abs(lon_in(i+1)-lon_in(i)) + enddo + + ! set south to north flag + s2n = .true. + if (lat_in(1) > lat_in(nlat_in+1)) s2n = .false. + + !----------------------------------------------------------------------- + ! --- set-up for output grid boxes --- + + do n = 1, nlat_out + dsph_out(n) = abs(sin(lat_out(n+1))-sin(lat_out(n))) + enddo + + do m = 1,nlon_out + theta(m,1) = lon_out(m) + theta(m,2) = lon_out(m+1) + dlon_out(m) = abs(lon_out(m+1)-lon_out(m)) + enddo + + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out + !*********************************************************************** + + !------ set up latitudinal indexing ------ + !------ make sure output grid goes south to north ------ + + do n = 1, nlat_out + if (lat_out(n) < lat_out(n+1)) then + sph(n,1) = sin(lat_out(n)) + sph(n,2) = sin(lat_out(n+1)) + else + sph(n,1) = sin(lat_out(n+1)) + sph(n,2) = sin(lat_out(n)) + endif + enddo + + Interp%jlat = 0 + do n2 = 1, 2 ! looping on grid box edges + do n = 1, nlat_out ! looping on output latitudes + eps = 0.0_kindl + do iter=1,num_iters + ! find indices from input latitudes + do j = 1, nlat_in + if ( (s2n .and. (slat_in(j)-sph(n,n2)) <= eps .and. & + (sph(n,n2)-slat_in(j+1)) <= eps) .or. & + (.not.s2n .and. (slat_in(j+1)-sph(n,n2)) <= eps .and. & + (sph(n,n2)-slat_in(j)) <= eps) ) then + Interp%jlat(n,n2) = j + ! weight with sin(lat) to exactly conserve area-integral + fac = (sph(n,n2)-slat_in(j))/(slat_in(j+1)-slat_in(j)) + if (s2n) then + if (n2 == 1) Interp%HI_KIND_TYPE_%facj(n,n2) = 1.0_kindl - fac + if (n2 == 2) Interp%HI_KIND_TYPE_%facj(n,n2) = fac + else + if (n2 == 1) Interp%HI_KIND_TYPE_%facj(n,n2) = fac + if (n2 == 2) Interp%HI_KIND_TYPE_%facj(n,n2) = 1.0_kindl - fac + endif + exit + endif + enddo + if ( Interp%jlat(n,n2) /= 0 ) exit + ! did not find this output grid edge in the input grid + ! increase tolerance for multiple passes + eps = epsilon(sph)*real(10.0_kindl**iter, kindl) + enddo + ! no match + if ( Interp%jlat(n,n2) == 0 ) then + write (mesg,710) n,sph(n,n2) +710 format (': n,sph=',i3,f14.7,40x) + call mpp_error(FATAL, 'horiz_interp_conserve_mod:no latitude index found'//trim(mesg)) + endif + enddo + enddo + + !------ set up longitudinal indexing ------ + + Interp%ilon = 0 + do m2 = 1, 2 ! looping on grid box edges + do m = 1, nlon_out ! looping on output longitudes + blon = theta(m,m2) + if ( blon < lon_in(1) ) blon = blon + tpi + if ( blon > lon_in(nlon_in+1) ) blon = blon - tpi + eps = 0.0_kindl + do iter=1,num_iters + ! find indices from input longitudes + do i = 1, nlon_in + if ( (lon_in(i)-blon) <= eps .and. & + (blon-lon_in(i+1)) <= eps ) then + Interp%ilon(m,m2) = i + fac = (blon-lon_in(i))/(lon_in(i+1)-lon_in(i)) + if (m2 == 1) Interp%HI_KIND_TYPE_%faci(m,m2) = 1.0_kindl - fac + if (m2 == 2) Interp%HI_KIND_TYPE_%faci(m,m2) = fac + exit + endif + enddo + if ( Interp%ilon(m,m2) /= 0 ) exit + ! did not find this output grid edge in the input grid + ! increase tolerance for multiple passes + eps = epsilon(blon)*real(10.0_kindl**iter, kindl) + enddo + ! no match + if ( Interp%ilon(m,m2) == 0 ) then + print *, 'lon_out,blon,blon_in,eps=', & + theta(m,m2),blon,lon_in(1),lon_in(nlon_in+1),eps + call mpp_error(FATAL, 'horiz_interp_conserve_mod: no longitude index found') + endif + enddo + enddo + + ! --- area of input grid boxes --- + + do j = 1,nlat_in + do i = 1,nlon_in + Interp%HI_KIND_TYPE_%area_src(i,j) = dlon_in(i) * dsph_in(j) + enddo + enddo + + ! --- area of output grid boxes --- + + do n = 1, nlat_out + do m = 1, nlon_out + Interp%HI_KIND_TYPE_%area_dst(m,n) = dlon_out(m) * dsph_out(n) + enddo + enddo + + !----------------------------------------------------------------------- + ! this output may be quite lengthy and is not recommended + ! when using more than one processor + if (iverbose > 2) then + write (*,801) (i,Interp%ilon(i,1),Interp%ilon(i,2), & + Interp%HI_KIND_TYPE_%faci(i,1),Interp%HI_KIND_TYPE_%faci(i,2),i=1,nlon_out) + write (*,802) (j,Interp%jlat(j,1),Interp%jlat(j,2), & + Interp%HI_KIND_TYPE_%facj(j,1),Interp%HI_KIND_TYPE_%facj(j,2),j=1,nlat_out) +801 format (/,2x,'i',4x,'is',5x,'ie',4x,'facis',4x,'facie', & + /,(i4,2i7,2f10.5)) +802 format (/,2x,'j',4x,'js',5x,'je',4x,'facjs',4x,'facje', & + /,(i4,2i7,2f10.5)) + endif + !----------------------------------------------------------------------- + + end subroutine HORIZ_INTERP_CONSERVE_NEW_1DX1D_ + + !####################################################################### + + subroutine HORIZ_INTERP_CONSERVE_NEW_1DX2D_ ( Interp, lon_in, lat_in, lon_out, lat_out, & + mask_in, mask_out, verbose) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + real(FMS_HI_KIND_), intent(in), optional, dimension(:,:) :: mask_in + real(FMS_HI_KIND_), intent(inout), optional, dimension(:,:) :: mask_out + integer, intent(in), optional :: verbose + + + integer :: create_xgrid_1DX2D_order1, get_maxxgrid, maxxgrid + integer :: create_xgrid_great_circle + integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i, j + real(r8_kind), dimension(size(lon_in(:))-1, size(lat_in(:))-1) :: mask_src + integer, allocatable, dimension(:) :: i_src, j_src, i_dst, j_dst + real(r8_kind), allocatable, dimension(:) :: xgrid_area, clon, clat + real(r8_kind), allocatable, dimension(:,:) :: dst_area, lon_src, lat_src + real(r8_kind), allocatable, dimension(:) :: lat_in_flip + real(r8_kind), allocatable, dimension(:,:) :: mask_src_flip + real(r8_kind), allocatable, dimension(:) :: lon_in_r8, lat_in_r8 + real(r8_kind), allocatable, dimension(:,:) :: lon_out_r8, lat_out_r8 + + integer :: nincrease, ndecrease + logical :: flip_lat + integer :: wordsz + integer(kind=1) :: one_byte(8) + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + + if(.not. module_is_initialized) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_1DX2D_: horiz_interp_conserve_init is not called') + + wordsz=size(transfer(lon_in(1), one_byte)) + if(wordsz .NE. 4 .AND. wordsz .NE. 8) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_1DX2D_: wordsz should be 4 or 8') + + if( (size(lon_out,1) .NE. size(lat_out,1)) .OR. (size(lon_out,2) .NE. size(lat_out,2)) ) & + call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_out and lat_out') + nlon_in = size(lon_in(:)) - 1; nlat_in = size(lat_in(:)) - 1 + nlon_out = size(lon_out,1) - 1; nlat_out = size(lon_out,2) - 1 + + mask_src = 1.0_r8_kind + if(present(mask_in)) then + if( (size(mask_in,1) .NE. nlon_in) .OR. (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, & + 'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in') + mask_src = real(mask_in, r8_kind) + end if + + maxxgrid = get_maxxgrid() + allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) ) + allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) ) + + !--- check if source latitude is flipped + nincrease = 0 + ndecrease = 0 + do j = 1, nlat_in + if( lat_in(j+1) > lat_in(j) ) then + nincrease = nincrease + 1 + else if ( lat_in(j+1) < lat_in(j) ) then + ndecrease = ndecrease + 1 + endif + enddo + + if(nincrease == nlat_in) then + flip_lat = .false. + else if(ndecrease == nlat_in) then + flip_lat = .true. + else + call mpp_error(FATAL, 'horiz_interp_conserve_mod: nlat_in should be equal to nincreaase or ndecrease') + endif + + allocate(lon_out_r8(size(lon_out,1),size(lon_out,2))) + allocate(lat_out_r8(size(lat_out,1),size(lat_out,2))) + lon_out_r8 = real(lon_out, r8_kind) + lat_out_r8 = real(lat_out, r8_kind) + + if( .not. great_circle_algorithm ) then + if(flip_lat) then + allocate(lat_in_flip(nlat_in+1), mask_src_flip(nlon_in,nlat_in)) + do j = 1, nlat_in+1 + lat_in_flip(j) = real(lat_in(nlat_in+2-j), r8_kind) + enddo + do j = 1, nlat_in + mask_src_flip(:,j) = mask_src(:,nlat_in+1-j) + enddo + allocate(lon_in_r8(size(lon_in))) + lon_in_r8 = real(lon_in, r8_kind) + nxgrid = create_xgrid_1DX2D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_flip, & + lon_out_r8, lat_out_r8, mask_src_flip, i_src, j_src, i_dst, j_dst, xgrid_area) + deallocate(lon_in_r8, lat_in_flip, mask_src_flip) + else + allocate(lon_in_r8(size(lon_in))) + allocate(lat_in_r8(size(lat_in))) + lon_in_r8 = real(lon_in, r8_kind) + lat_in_r8 = real(lat_in, r8_kind) + nxgrid = create_xgrid_1DX2D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_out_r8, & + & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area) + deallocate(lon_in_r8,lat_in_r8) + endif + else + allocate(lon_src(nlon_in+1,nlat_in+1), lat_src(nlon_in+1,nlat_in+1)) + allocate(clon(maxxgrid), clat(maxxgrid)) + if(flip_lat) then + allocate(mask_src_flip(nlon_in,nlat_in)) + do j = 1, nlat_in+1 + do i = 1, nlon_in+1 + lon_src(i,j) = real(lon_in(i), r8_kind) + lat_src(i,j) = real(lat_in(nlat_in+2-j), r8_kind) + enddo + enddo + do j = 1, nlat_in + mask_src_flip(:,j) = mask_src(:,nlat_in+1-j) + enddo + nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_src, lat_src, lon_out_r8, & + & lat_out_r8, mask_src_flip, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) + deallocate(mask_src_flip) + else + do j = 1, nlat_in+1 + do i = 1, nlon_in+1 + lon_src(i,j) = real(lon_in(i), r8_kind) + lat_src(i,j) = real(lat_in(j), r8_kind) + enddo + enddo + nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_src, lat_src, lon_out_r8, & + & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) + endif + deallocate(lon_src, lat_src, clon, clat) + endif + + deallocate(lon_out_r8, lat_out_r8) + + allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) ) + allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) ) + allocate(Interp%HI_KIND_TYPE_%area_frac_dst(nxgrid) ) + Interp%version = 2 + Interp%nxgrid = nxgrid + Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0 + Interp%j_src = j_src(1:nxgrid)+1 + if(flip_lat) Interp%j_src = nlat_in+1-Interp%j_src + Interp%i_dst = i_dst(1:nxgrid)+1 + Interp%j_dst = j_dst(1:nxgrid)+1 + + ! sum over exchange grid area to get destination grid area + dst_area = 0.0_r8_kind + do i = 1, nxgrid + dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i) + end do + + do i = 1, nxgrid + Interp%HI_KIND_TYPE_%area_frac_dst(i) = real(xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i) ), & + FMS_HI_KIND_) + end do + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out + if(present(mask_out)) then + if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, & + 'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out') + mask_out = 0.0_kindl + do i = 1, nxgrid + mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i), & + & Interp%j_dst(i)) + Interp%HI_KIND_TYPE_%area_frac_dst(i) + end do + end if + + deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area ) + + end subroutine HORIZ_INTERP_CONSERVE_NEW_1DX2D_ + + !####################################################################### + + subroutine HORIZ_INTERP_CONSERVE_NEW_2DX1D_ ( Interp, lon_in, lat_in, lon_out, lat_out, & + mask_in, mask_out, verbose) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:) :: lon_out, lat_out + real(FMS_HI_KIND_), intent(in), optional, dimension(:,:) :: mask_in + real(FMS_HI_KIND_), intent(inout), optional, dimension(:,:) :: mask_out + integer, intent(in), optional :: verbose + + integer :: create_xgrid_2DX1D_order1, get_maxxgrid, maxxgrid + integer :: create_xgrid_great_circle + integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i, j + integer, allocatable, dimension(:) :: i_src, j_src, i_dst, j_dst + real(r8_kind), allocatable, dimension(:,:) :: dst_area + real(r8_kind), dimension(size(lon_in,1)-1, size(lon_in,2)-1) :: mask_src + real(r8_kind), allocatable, dimension(:) :: xgrid_area, clon, clat + real(r8_kind), allocatable, dimension(:) :: lon_out_r8, lat_out_r8 + real(r8_kind), allocatable, dimension(:,:) :: lon_in_r8, lat_in_r8 + real(r8_kind), allocatable, dimension(:,:) :: lon_dst, lat_dst + integer :: wordsz + integer(kind=1) :: one_byte(8) + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + + if(.not. module_is_initialized) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_2DX1D_: horiz_interp_conserve_init is not called') + + wordsz=size(transfer(lon_in(1,1), one_byte)) + if(wordsz .NE. 8) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_2DX1D_: currently only support 64-bit real(FMS_HI_KIND_), contact developer') + + if( (size(lon_in,1) .NE. size(lat_in,1)) .OR. (size(lon_in,2) .NE. size(lat_in,2)) ) & + call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_in and lat_in') + nlon_in = size(lon_in,1) - 1; nlat_in = size(lon_in,2) - 1 + nlon_out = size(lon_out(:)) - 1; nlat_out = size(lat_out(:)) - 1 + + mask_src = 1.0_r8_kind + if(present(mask_in)) then + if( (size(mask_in,1) .NE. nlon_in) .OR. (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, & + 'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in') + mask_src = real(mask_in, r8_kind) + end if + + maxxgrid = get_maxxgrid() + allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) ) + allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) ) + + allocate(lon_in_r8(size(lon_in,1), size(lon_in, 2))) + allocate(lat_in_r8(size(lat_in,1), size(lat_in, 2))) + allocate(lon_out_r8(size(lon_out))) + allocate(lat_out_r8(size(lat_out))) + lon_out_r8 = real(lon_out, r8_kind) + lat_out_r8 = real(lat_out, r8_kind) + lon_in_r8 = real(lon_in, r8_kind) + lat_in_r8 = real(lat_in, r8_kind) + + if( .not. great_circle_algorithm ) then + nxgrid = create_xgrid_2DX1D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, & + lon_out_r8, lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area) + else + allocate(lon_dst(nlon_out+1, nlat_out+1), lat_dst(nlon_out+1, nlat_out+1) ) + allocate(clon(maxxgrid), clat(maxxgrid)) + do j = 1, nlat_out+1 + do i = 1, nlon_out+1 + lon_dst(i,j) = real(lon_out(i), r8_kind) + lat_dst(i,j) = real(lat_out(j), r8_kind) + enddo + enddo + nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_dst, & + & lat_dst, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) + endif + deallocate(lon_out_r8,lat_out_r8, lon_in_r8, lat_in_r8) + allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) ) + allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) ) + allocate(Interp%HI_KIND_TYPE_%area_frac_dst(nxgrid) ) + Interp%version = 2 + Interp%nxgrid = nxgrid + Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0 + Interp%j_src = j_src(1:nxgrid)+1 + Interp%i_dst = i_dst(1:nxgrid)+1 + Interp%j_dst = j_dst(1:nxgrid)+1 + + ! sum over exchange grid area to get destination grid area + dst_area = 0.0_r8_kind + do i = 1, nxgrid + dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i) + end do + + do i = 1, nxgrid + Interp%HI_KIND_TYPE_%area_frac_dst(i) = real(xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i) ), & + FMS_HI_KIND_) + end do + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out + if(present(mask_out)) then + if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, & + 'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out') + mask_out = 0.0_kindl + do i = 1, nxgrid + mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i), & + & Interp%j_dst(i)) + Interp%HI_KIND_TYPE_%area_frac_dst(i) + end do + end if + + deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area) + + end subroutine HORIZ_INTERP_CONSERVE_NEW_2DX1D_ + + !####################################################################### + + subroutine HORIZ_INTERP_CONSERVE_NEW_2DX2D_ ( Interp, lon_in, lat_in, lon_out, lat_out, & + mask_in, mask_out, verbose) + type(horiz_interp_type), intent(inout) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in , lat_in + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out, lat_out + real(FMS_HI_KIND_), intent(in), optional, dimension(:,:) :: mask_in + real(FMS_HI_KIND_), intent(inout), optional, dimension(:,:) :: mask_out + integer, intent(in), optional :: verbose + + integer :: create_xgrid_2DX2D_order1, get_maxxgrid, maxxgrid + integer :: create_xgrid_great_circle + integer :: nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, i + integer, allocatable, dimension(:) :: i_src, j_src, i_dst, j_dst + real(r8_kind), dimension(size(lon_in,1)-1, size(lon_in,2)-1) :: mask_src + real(r8_kind), allocatable, dimension(:) :: xgrid_area, clon, clat + real(r8_kind), allocatable, dimension(:,:) :: dst_area + real(r8_kind), allocatable, dimension(:,:) :: lon_in_r8, lat_in_r8 + real(r8_kind), allocatable, dimension(:,:) :: lon_out_r8, lat_out_r8 + integer :: wordsz + integer(kind=1) :: one_byte(8) + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + + if(.not. module_is_initialized) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_2DX2D_: horiz_interp_conserve_init is not called') + + wordsz=size(transfer(lon_in(1,1), one_byte)) + if(wordsz .NE. 4 .AND. wordsz .NE. 8) call mpp_error(FATAL, & + 'HORIZ_INTERP_CONSERVE_NEW_2DX2D_: wordsz should be 4 or 8') + + if( (size(lon_in,1) .NE. size(lat_in,1)) .OR. (size(lon_in,2) .NE. size(lat_in,2)) ) & + call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_in and lat_in') + if( (size(lon_out,1) .NE. size(lat_out,1)) .OR. (size(lon_out,2) .NE. size(lat_out,2)) ) & + call mpp_error(FATAL, 'horiz_interp_conserve_mod: size mismatch between lon_out and lat_out') + nlon_in = size(lon_in,1) - 1; nlat_in = size(lon_in,2) - 1 + nlon_out = size(lon_out,1) - 1; nlat_out = size(lon_out,2) - 1 + + mask_src = 1.0_r8_kind + if(present(mask_in)) then + if( (size(mask_in,1) .NE. nlon_in) .OR. (size(mask_in,2) .NE. nlat_in)) call mpp_error(FATAL, & + 'horiz_interp_conserve_mod: size mismatch between mask_in and lon_in/lat_in') + mask_src = real(mask_in, r8_kind) + end if + + maxxgrid = get_maxxgrid() + allocate(i_src(maxxgrid), j_src(maxxgrid), i_dst(maxxgrid), j_dst(maxxgrid) ) + allocate( xgrid_area(maxxgrid), dst_area(nlon_out, nlat_out) ) + + allocate(lon_in_r8(size(lon_in,1),size(lon_in,2))) + allocate(lat_in_r8(size(lat_in,1),size(lat_in,2))) + allocate(lon_out_r8(size(lon_out,1),size(lon_out,2))) + allocate(lat_out_r8(size(lat_out,1),size(lat_out,2))) + lon_in_r8 = real(lon_in,r8_kind) + lat_in_r8 = real(lat_in, r8_kind) + lon_out_r8 = real(lon_out, r8_kind) + lat_out_r8 = real(lat_out, r8_kind) + + if( .not. great_circle_algorithm ) then + nxgrid = create_xgrid_2DX2D_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_out_r8, & + & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area) + else + allocate(clon(maxxgrid), clat(maxxgrid)) + nxgrid = create_xgrid_great_circle(nlon_in, nlat_in, nlon_out, nlat_out, lon_in_r8, lat_in_r8, lon_out_r8, & + & lat_out_r8, mask_src, i_src, j_src, i_dst, j_dst, xgrid_area, clon, clat) + deallocate(clon, clat) + endif + + deallocate(lon_in_r8, lat_in_r8, lon_out_r8, lat_out_r8) + + allocate(Interp%i_src(nxgrid), Interp%j_src(nxgrid) ) + allocate(Interp%i_dst(nxgrid), Interp%j_dst(nxgrid) ) + allocate(Interp%HI_KIND_TYPE_%area_frac_dst(nxgrid) ) + Interp%version = 2 + Interp%nxgrid = nxgrid + Interp%i_src = i_src(1:nxgrid)+1 ! in C, the starting index is 0 + Interp%j_src = j_src(1:nxgrid)+1 + Interp%i_dst = i_dst(1:nxgrid)+1 + Interp%j_dst = j_dst(1:nxgrid)+1 + + ! sum over exchange grid area to get destination grid area + dst_area = 0.0_r8_kind + do i = 1, nxgrid + dst_area(Interp%i_dst(i), Interp%j_dst(i)) = dst_area(Interp%i_dst(i), Interp%j_dst(i)) + xgrid_area(i) + end do + + do i = 1, nxgrid + Interp%HI_KIND_TYPE_%area_frac_dst(i) = real(xgrid_area(i)/dst_area(Interp%i_dst(i), Interp%j_dst(i)), & + FMS_HI_KIND_) + end do + + Interp%nlon_src = nlon_in; Interp%nlat_src = nlat_in + Interp%nlon_dst = nlon_out; Interp%nlat_dst = nlat_out + if(present(mask_out)) then + if( (size(mask_out,1) .NE. nlon_out) .OR. (size(mask_out,2) .NE. nlat_out) ) call mpp_error(FATAL, & + 'horiz_interp_conserve_mod: size mismatch between mask_out and lon_out/lat_out') + mask_out = 0.0_kindl + do i = 1, nxgrid + mask_out(Interp%i_dst(i),Interp%j_dst(i)) = mask_out(Interp%i_dst(i), & + & Interp%j_dst(i)) + Interp%HI_KIND_TYPE_%area_frac_dst(i) + end do + end if + + deallocate(i_src, j_src, i_dst, j_dst, xgrid_area, dst_area ) + + end subroutine HORIZ_INTERP_CONSERVE_NEW_2DX2D_ + + !######################################################################## + + !> @brief Subroutine for performing the horizontal interpolation between two grids. + !! + !> Subroutine for performing the horizontal interpolation between two grids. + !! horiz_interp_conserve_new must be called before calling this routine. + subroutine HORIZ_INTERP_CONSERVE_( Interp, data_in, data_out, verbose, & + mask_in, mask_out) + !----------------------------------------------------------------------- + type (horiz_interp_type), intent(in) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in !< Input data on source grid + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out !< Output data on destination grid + integer, intent(in), optional :: verbose !< 0 = no output; 1 = min,max,means; + !! 2 = max output + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in !< Input mask, must be the same size as + !! the input data. The real value of mask_in must be in the range (0.,1.). + !! Set mask_in=0.0 for data points that should not be used or have missing + !! data. mask_in will be applied only when horiz_interp_conserve_new_1d is + !! called. mask_in will be passed into horiz_interp_conserve_new_2d + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out !< Output mask that specifies whether + !! data was computed. mask_out will be computed only when + !! horiz_interp_conserve_new_1d is called. mask_out will be computed in + !! horiz_interp_conserve_new_2d + + ! --- error checking --- + if (size(data_in,1) /= Interp%nlon_src .or. size(data_in,2) /= Interp%nlat_src) & + call mpp_error(FATAL, 'horiz_interp_conserve_mod: size of input array incorrect') + + if (size(data_out,1) /= Interp%nlon_dst .or. size(data_out,2) /= Interp%nlat_dst) & + call mpp_error(FATAL, 'horiz_interp_conserve_mod: size of output array incorrect') + + select case ( Interp%version) + case (1) + call horiz_interp_conserve_version1(Interp, data_in, data_out, verbose, mask_in, mask_out) + case (2) + if(present(mask_in) .OR. present(mask_out) ) call mpp_error(FATAL, 'HORIZ_INTERP_CONSERVE_:'// & + & ' for version 2, mask_in and mask_out must be passed in horiz_interp_new, not in horiz_interp') + call horiz_interp_conserve_version2(Interp, data_in, data_out, verbose) + end select + + end subroutine HORIZ_INTERP_CONSERVE_ + + !############################################################################## + subroutine HORIZ_INTERP_CONSERVE_VERSION1_ ( Interp, data_in, data_out, verbose, & + mask_in, mask_out) + !----------------------------------------------------------------------- + type (horiz_interp_type), intent(in) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out + !----------local variables---------------------------------------------------- + integer :: m, n, nlon_in, nlat_in, nlon_out, nlat_out, & + miss_in, miss_out, is, ie, js, je, & + np, npass, iverbose + real(FMS_HI_KIND_) :: dsum, wsum, avg_in, min_in, max_in, & + avg_out, min_out, max_out, eps, asum, & + dwtsum, wtsum, arsum, fis, fie, fjs, fje + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + !----------------------------------------------------------------------- + iverbose = 0; if (present(verbose)) iverbose = verbose + + eps = epsilon(wtsum) + + nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src + nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst + + if (present(mask_in)) then + if ( COUNT(mask_in < -.0001_kindl .or. mask_in > 1.0001_kindl) > 0 ) & + call mpp_error(FATAL, 'horiz_interp_conserve_mod: input mask not between 0,1') + endif + + !----------------------------------------------------------------------- + !---- loop through output grid boxes ---- + + data_out = 0.0_kindl + do n = 1, nlat_out + ! latitude window + ! setup ascending latitude indices and weights + if (Interp%jlat(n,1) <= Interp%jlat(n,2)) then + js = Interp%jlat(n,1); je = Interp%jlat(n,2) + fjs = Interp%HI_KIND_TYPE_%facj(n,1); fje = Interp%HI_KIND_TYPE_%facj(n,2) + else + js = Interp%jlat(n,2); je = Interp%jlat(n,1) + fjs = Interp%HI_KIND_TYPE_%facj(n,2); fje = Interp%HI_KIND_TYPE_%facj(n,1) + endif + + do m = 1, nlon_out + ! longitude window + is = Interp%ilon(m,1); ie = Interp%ilon(m,2) + fis = Interp%HI_KIND_TYPE_%faci(m,1); fie = Interp%HI_KIND_TYPE_%faci(m,2) + npass = 1 + dwtsum = 0.0_kindl + wtsum = 0.0_kindl + arsum = 0.0_kindl + + ! wrap-around on input grid + ! sum using 2 passes (pass 1: end of input grid) + if ( ie < is ) then + ie = nlon_in + fie = 1.0_kindl + npass = 2 + endif + + do np = 1, npass + ! pass 2: beginning of input grid + if ( np == 2 ) then + is = 1 + fis = 1.0_kindl + ie = Interp%ilon(m,2) + fie = Interp%HI_KIND_TYPE_%faci(m,2) + endif + + ! summing data*weight and weight for single grid point + if (present(mask_in)) then + call data_sum( data_in(is:ie,js:je), Interp%HI_KIND_TYPE_%area_src(is:ie,js:je), & + fis, fie, fjs,fje, dwtsum, wtsum, arsum, mask_in(is:ie,js:je) ) + else if( allocated(Interp%HI_KIND_TYPE_%mask_in) ) then + call data_sum( data_in(is:ie,js:je), Interp%HI_KIND_TYPE_%area_src(is:ie,js:je), & + fis, fie, fjs,fje, dwtsum, wtsum, arsum, Interp%HI_KIND_TYPE_%mask_in(is:ie,js:je) ) + else + call data_sum( data_in(is:ie,js:je), Interp%HI_KIND_TYPE_%area_src(is:ie,js:je), & + fis, fie, fjs,fje, dwtsum, wtsum, arsum ) + endif + enddo + + if (wtsum > eps) then + data_out(m,n) = dwtsum/wtsum + if (present(mask_out)) mask_out(m,n) = wtsum/arsum + else + data_out(m,n) = 0.0_kindl + if (present(mask_out)) mask_out(m,n) = 0.0_kindl + endif + + enddo + enddo + + !*********************************************************************** + ! compute statistics: minimum, maximum, and mean + !----------------------------------------------------------------------- + + if (iverbose > 0) then + + ! compute statistics of input data + + call stats(data_in, Interp%HI_KIND_TYPE_%area_src, asum, dsum, wsum, min_in, max_in, miss_in, mask_in) + ! diagnostic messages + ! on the root_pe, we can calculate the global mean, minimum and maximum. + if(pe == root_pe) then + if (wsum > 0.0_kindl) then + avg_in=dsum/wsum + else + print *, 'horiz_interp stats: input area equals zero ' + avg_in=0.0_kindl + endif + if (iverbose > 1) print '(2f16.11)', 'global sum area_in = ', asum, wsum + endif + + ! compute statistics of output data + call stats(data_out, Interp%HI_KIND_TYPE_%area_dst, asum, dsum, wsum, min_out, max_out, miss_out, mask_out) + ! diagnostic messages + if(pe == root_pe) then + if (wsum > 0.0_kindl ) then + avg_out=dsum/wsum + else + print *, 'horiz_interp stats: output area equals zero ' + avg_out=0.0_kindl + endif + if (iverbose > 1) print '(2f16.11)', 'global sum area_out = ', asum, wsum + endif + !---- output statistics ---- + ! the global mean, min and max are calculated on the root pe. + if(pe == root_pe) then + write (*,900) + write (*,901) min_in ,max_in ,avg_in + if (present(mask_in)) write (*,903) miss_in + write (*,902) min_out,max_out,avg_out + if (present(mask_out)) write (*,903) miss_out + endif + +900 format (/,1x,10('-'),' output from horiz_interp ',10('-')) +901 format (' input: min=',f16.9,' max=',f16.9,' avg=',f22.15) +902 format (' output: min=',f16.9,' max=',f16.9,' avg=',f22.15) +903 format (' number of missing points = ',i6) + + endif + + !----------------------------------------------------------------------- + end subroutine HORIZ_INTERP_CONSERVE_VERSION1_ + + !############################################################################# + subroutine HORIZ_INTERP_CONSERVE_VERSION2_ ( Interp, data_in, data_out, verbose ) + !----------------------------------------------------------------------- + type (horiz_interp_type), intent(in) :: Interp + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out + integer, intent(in), optional :: verbose + integer :: i, i_src, j_src, i_dst, j_dst + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + + data_out = 0.0_kindl + do i = 1, Interp%nxgrid + i_src = Interp%i_src(i); j_src = Interp%j_src(i) + i_dst = Interp%i_dst(i); j_dst = Interp%j_dst(i) + data_out(i_dst, j_dst) = data_out(i_dst, j_dst) + data_in(i_src,j_src)*Interp%HI_KIND_TYPE_%area_frac_dst(i) + end do + + end subroutine HORIZ_INTERP_CONSERVE_VERSION2_ + + + !####################################################################### + !> This statistics is for conservative scheme + subroutine STATS_ ( dat, area, asum, dsum, wsum, low, high, miss, mask ) + real(FMS_HI_KIND_), intent(in) :: dat(:,:), area(:,:) + real(FMS_HI_KIND_), intent(out) :: asum, dsum, wsum, low, high + integer, intent(out) :: miss + real(FMS_HI_KIND_), intent(in), optional :: mask(:,:) + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + + integer :: pe, root_pe, npes, p, buffer_int(1) + real(FMS_HI_KIND_) :: buffer_real(5) + + pe = mpp_pe() + root_pe = mpp_root_pe() + npes = mpp_npes() + + ! sum data, data*area; and find min,max on each pe. + + if (present(mask)) then + asum = sum(area(:,:)) + dsum = sum(area(:,:)*dat(:,:)*mask(:,:)) + wsum = sum(area(:,:)*mask(:,:)) + miss = count(mask(:,:) <= 0.5_kindl) + low = minval(dat(:,:),mask=mask(:,:) > 0.5_kindl ) + high = maxval(dat(:,:),mask=mask(:,:) > 0.5_kindl ) + else + asum = sum(area(:,:)) + dsum = sum(area(:,:)*dat(:,:)) + wsum = sum(area(:,:)) + miss = 0 + low = minval(dat(:,:)) + high = maxval(dat(:,:)) + endif + + ! other pe send local min, max, avg to the root pe and + ! root pe receive these information + + if(pe == root_pe) then + do p = 1, npes - 1 + ! Force use of "scalar", integer pointer mpp interface + call mpp_recv(buffer_real(1),glen=5,from_pe=root_pe+p, tag=COMM_TAG_1) + asum = asum + buffer_real(1) + dsum = dsum + buffer_real(2) + wsum = wsum + buffer_real(3) + low = min(low, buffer_real(4)) + high = max(high, buffer_real(5)) + call mpp_recv(buffer_int(1),glen=1,from_pe=root_pe+p, tag=COMM_TAG_2) + miss = miss + buffer_int(1) + enddo + else + buffer_real(1) = asum + buffer_real(2) = dsum + buffer_real(3) = wsum + buffer_real(4) = low + buffer_real(5) = high + ! Force use of "scalar", integer pointer mpp interface + call mpp_send(buffer_real(1),plen=5,to_pe=root_pe, tag=COMM_TAG_1) + buffer_int(1) = miss + call mpp_send(buffer_int(1),plen=1,to_pe=root_pe, tag=COMM_TAG_2) + endif + + call mpp_sync_self() + + end subroutine STATS_ + + !####################################################################### + + !> sums up the data and weights for a single output grid box + subroutine DATA_SUM_( data, area, facis, facie, facjs, facje, & + dwtsum, wtsum, arsum, mask ) + + !----------------------------------------------------------------------- + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data, area + real(FMS_HI_KIND_), intent(in) :: facis, facie, facjs, facje + real(FMS_HI_KIND_), intent(inout) :: dwtsum, wtsum, arsum + real(FMS_HI_KIND_), intent(in), optional :: mask(:,:) + + ! fac__ = fractional portion of each boundary grid box included + ! in the integral + ! dwtsum = sum(data*area*mask) + ! wtsum = sum(area*mask) + ! arsum = sum(area) + !----------------------------------------------------------------------- + real(FMS_HI_KIND_), dimension(size(area,1),size(area,2)) :: wt + real(FMS_HI_KIND_) :: asum + integer :: id, jd + !----------------------------------------------------------------------- + + id=size(area,1); jd=size(area,2) + + wt=area + wt( 1,:)=wt( 1,:)*facis + wt(id,:)=wt(id,:)*facie + wt(:, 1)=wt(:, 1)*facjs + wt(:,jd)=wt(:,jd)*facje + + asum = sum(wt) + arsum = arsum + asum + + if (present(mask)) then + wt = wt * mask + dwtsum = dwtsum + sum(wt*data) + wtsum = wtsum + sum(wt) + else + dwtsum = dwtsum + sum(wt*data) + wtsum = wtsum + asum + endif + !----------------------------------------------------------------------- + + end subroutine DATA_SUM_ +!> @} diff --git a/horiz_interp/include/horiz_interp_conserve_r4.fh b/horiz_interp/include/horiz_interp_conserve_r4.fh new file mode 100644 index 0000000000..0cf1c9cce2 --- /dev/null +++ b/horiz_interp/include/horiz_interp_conserve_r4.fh @@ -0,0 +1,55 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_conserve +!> @{ +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals4_type + +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r4_kind + +#undef HORIZ_INTERP_CONSERVE_NEW_1DX1D_ +#define HORIZ_INTERP_CONSERVE_NEW_1DX1D_ horiz_interp_conserve_new_1dx1d_r4 + +#undef HORIZ_INTERP_CONSERVE_NEW_1DX2D_ +#define HORIZ_INTERP_CONSERVE_NEW_1DX2D_ horiz_interp_conserve_new_1dx2d_r4 + +#undef HORIZ_INTERP_CONSERVE_NEW_2DX1D_ +#define HORIZ_INTERP_CONSERVE_NEW_2DX1D_ horiz_interp_conserve_new_2dx1d_r4 + +#undef HORIZ_INTERP_CONSERVE_NEW_2DX2D_ +#define HORIZ_INTERP_CONSERVE_NEW_2DX2D_ horiz_interp_conserve_new_2dx2d_r4 + +#undef HORIZ_INTERP_CONSERVE_ +#define HORIZ_INTERP_CONSERVE_ horiz_interp_conserve_r4 + +#undef HORIZ_INTERP_CONSERVE_VERSION1_ +#define HORIZ_INTERP_CONSERVE_VERSION1_ horiz_interp_conserve_version1_r4 + +#undef HORIZ_INTERP_CONSERVE_VERSION2_ +#define HORIZ_INTERP_CONSERVE_VERSION2_ horiz_interp_conserve_version2_r4 + +#undef STATS_ +#define STATS_ stats_r4 + +#undef DATA_SUM_ +#define DATA_SUM_ data_sum_r4 + +#include "horiz_interp_conserve.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_conserve_r8.fh b/horiz_interp/include/horiz_interp_conserve_r8.fh new file mode 100644 index 0000000000..0b3b0d2ff4 --- /dev/null +++ b/horiz_interp/include/horiz_interp_conserve_r8.fh @@ -0,0 +1,55 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_conserve +!> @{ +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals8_type + +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r8_kind + +#undef HORIZ_INTERP_CONSERVE_NEW_1DX1D_ +#define HORIZ_INTERP_CONSERVE_NEW_1DX1D_ horiz_interp_conserve_new_1dx1d_r8 + +#undef HORIZ_INTERP_CONSERVE_NEW_1DX2D_ +#define HORIZ_INTERP_CONSERVE_NEW_1DX2D_ horiz_interp_conserve_new_1dx2d_r8 + +#undef HORIZ_INTERP_CONSERVE_NEW_2DX1D_ +#define HORIZ_INTERP_CONSERVE_NEW_2DX1D_ horiz_interp_conserve_new_2dx1d_r8 + +#undef HORIZ_INTERP_CONSERVE_NEW_2DX2D_ +#define HORIZ_INTERP_CONSERVE_NEW_2DX2D_ horiz_interp_conserve_new_2dx2d_r8 + +#undef HORIZ_INTERP_CONSERVE_ +#define HORIZ_INTERP_CONSERVE_ horiz_interp_conserve_r8 + +#undef HORIZ_INTERP_CONSERVE_VERSION1_ +#define HORIZ_INTERP_CONSERVE_VERSION1_ horiz_interp_conserve_version1_r8 + +#undef HORIZ_INTERP_CONSERVE_VERSION2_ +#define HORIZ_INTERP_CONSERVE_VERSION2_ horiz_interp_conserve_version2_r8 + +#undef STATS_ +#define STATS_ stats_r8 + +#undef DATA_SUM_ +#define DATA_SUM_ data_sum_r8 + +#include "horiz_interp_conserve.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_r4.fh b/horiz_interp/include/horiz_interp_r4.fh new file mode 100644 index 0000000000..40cd267bcb --- /dev/null +++ b/horiz_interp/include/horiz_interp_r4.fh @@ -0,0 +1,64 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r4_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals4_type + +#undef HORIZ_INTERP_NEW_1D_ +#define HORIZ_INTERP_NEW_1D_ horiz_interp_new_1d_r4 + +#undef HORIZ_INTERP_NEW_1D_SRC_ +#define HORIZ_INTERP_NEW_1D_SRC_ horiz_interp_new_1d_src_r4 + +#undef HORIZ_INTERP_NEW_1D_DST_ +#define HORIZ_INTERP_NEW_1D_DST_ horiz_interp_new_1d_dst_r4 + +#undef HORIZ_INTERP_BASE_2D_ +#define HORIZ_INTERP_BASE_2D_ horiz_interp_base_2d_r4 + +#undef HORIZ_INTERP_BASE_3D_ +#define HORIZ_INTERP_BASE_3D_ horiz_interp_base_3d_r4 + +#undef HORIZ_INTERP_SOLO_1D_ +#define HORIZ_INTERP_SOLO_1D_ horiz_interp_solo_1d_r4 + +#undef HORIZ_INTERP_SOLO_1D_SRC_ +#define HORIZ_INTERP_SOLO_1D_SRC_ horiz_interp_solo_1d_src_r4 + +#undef HORIZ_INTERP_SOLO_1D_DST_ +#define HORIZ_INTERP_SOLO_1D_DST_ horiz_interp_solo_1d_dst_r4 + +#undef HORIZ_INTERP_SOLO_2D_ +#define HORIZ_INTERP_SOLO_2D_ horiz_interp_solo_2d_r4 + +#undef HORIZ_INTERP_SOLO_OLD_ +#define HORIZ_INTERP_SOLO_OLD_ horiz_interp_solo_old_r4 + +#undef HORIZ_INTERP_NEW_2D_ +#define HORIZ_INTERP_NEW_2D_ horiz_interp_new_2d_r4 + +#undef IS_LAT_LON_ +#define IS_LAT_LON_ is_lat_lon_r4 + +#include "horiz_interp.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_r8.fh b/horiz_interp/include/horiz_interp_r8.fh new file mode 100644 index 0000000000..a70bd1e3ef --- /dev/null +++ b/horiz_interp/include/horiz_interp_r8.fh @@ -0,0 +1,64 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r8_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals8_type + +#undef HORIZ_INTERP_NEW_1D_ +#define HORIZ_INTERP_NEW_1D_ horiz_interp_new_1d_r8 + +#undef HORIZ_INTERP_NEW_1D_SRC_ +#define HORIZ_INTERP_NEW_1D_SRC_ horiz_interp_new_1d_src_r8 + +#undef HORIZ_INTERP_NEW_1D_DST_ +#define HORIZ_INTERP_NEW_1D_DST_ horiz_interp_new_1d_dst_r8 + +#undef HORIZ_INTERP_BASE_2D_ +#define HORIZ_INTERP_BASE_2D_ horiz_interp_base_2d_r8 + +#undef HORIZ_INTERP_BASE_3D_ +#define HORIZ_INTERP_BASE_3D_ horiz_interp_base_3d_r8 + +#undef HORIZ_INTERP_SOLO_1D_ +#define HORIZ_INTERP_SOLO_1D_ horiz_interp_solo_1d_r8 + +#undef HORIZ_INTERP_SOLO_1D_SRC_ +#define HORIZ_INTERP_SOLO_1D_SRC_ horiz_interp_solo_1d_src_r8 + +#undef HORIZ_INTERP_SOLO_1D_DST_ +#define HORIZ_INTERP_SOLO_1D_DST_ horiz_interp_solo_1d_dst_r8 + +#undef HORIZ_INTERP_SOLO_2D_ +#define HORIZ_INTERP_SOLO_2D_ horiz_interp_solo_2d_r8 + +#undef HORIZ_INTERP_SOLO_OLD_ +#define HORIZ_INTERP_SOLO_OLD_ horiz_interp_solo_old_r8 + +#undef HORIZ_INTERP_NEW_2D_ +#define HORIZ_INTERP_NEW_2D_ horiz_interp_new_2d_r8 + +#undef IS_LAT_LON_ +#define IS_LAT_LON_ is_lat_lon_r8 + +#include "horiz_interp.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_spherical.inc b/horiz_interp/include/horiz_interp_spherical.inc new file mode 100644 index 0000000000..cc00a4264e --- /dev/null +++ b/horiz_interp/include/horiz_interp_spherical.inc @@ -0,0 +1,821 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_spherical_mod +!> @{ + !> Initialization routine. + !! + !> Allocates space and initializes a derived-type variable + !! that contains pre-computed interpolation indices and weights. + subroutine HORIZ_INTERP_SPHERICAL_NEW_(Interp, lon_in,lat_in,lon_out,lat_out, & + num_nbrs, max_dist, src_modulo) + + type(horiz_interp_type), intent(inout) :: Interp !< A derived type variable containing indices + !! and weights for subsequent interpolations. To + !! reinitialize for different grid-to-grid interpolation + !! @ref horiz_interp_del must be used first. + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_in !< Latitude (radians) for source data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lat_in !< Longitude (radians) for source data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lon_out !< Longitude (radians) for output data grid + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: lat_out !< Latitude (radians) for output data grid + logical, intent(in), optional :: src_modulo !< indicates if the boundary condition + !! along zonal boundary is cyclic or not. Cyclic when true + integer, intent(in), optional :: num_nbrs !< Number of nearest neighbors for regridding + !! When number of neighbors within the radius max_dist + !! is less than num_nbrs, All the neighbors will be used + !! to interpolate onto destination grid. when number of + !! neighbors within the radius max_dist is greater than + !! num_nbrs, at least "num_nbrs" + ! neighbors will be used to remap onto destination grid + real(FMS_HI_KIND_), optional, intent(in) :: max_dist !< Maximum region of influence around + !! destination grid points + + !------local variables --------------------------------------- + integer :: i, j, n + integer :: map_dst_xsize, map_dst_ysize, map_src_xsize, map_src_ysize + integer :: map_src_size, num_neighbors + real(FMS_HI_KIND_) :: max_src_dist, tpi, hpi + logical :: src_is_modulo + real(FMS_HI_KIND_) :: min_theta_dst, max_theta_dst, min_phi_dst, max_phi_dst + real(FMS_HI_KIND_) :: min_theta_src, max_theta_src, min_phi_src, max_phi_src + integer :: map_src_add(size(lon_out,1),size(lon_out,2),max_neighbors) + real(FMS_HI_KIND_) :: map_src_dist(size(lon_out,1),size(lon_out,2),max_neighbors) + integer :: num_found(size(lon_out,1),size(lon_out,2)) + integer :: ilon(max_neighbors), jlat(max_neighbors) + real(FMS_HI_KIND_), dimension(size(lon_out,1),size(lon_out,2)) :: theta_dst, phi_dst + real(FMS_HI_KIND_), dimension(size(lon_in,1)*size(lon_in,2)) :: theta_src, phi_src + integer, parameter :: kindl = FMS_HI_KIND_ + + !-------------------------------------------------------------- + + pe = mpp_pe() + root_pe = mpp_root_pe() + + tpi = 2.0_kindl*real(PI, FMS_HI_KIND_); hpi = 0.5_kindl*real(PI,FMS_HI_KIND_) + + num_neighbors = num_nbrs_default + if(present(num_nbrs)) num_neighbors = num_nbrs + if (num_neighbors <= 0) call mpp_error(FATAL,'horiz_interp_spherical_mod: num_neighbors must be > 0') + + max_src_dist = real(max_dist_default, FMS_HI_KIND_) + if (PRESENT(max_dist)) max_src_dist = max_dist + Interp%HI_KIND_TYPE_%max_src_dist = max_src_dist + + src_is_modulo = .true. + if (PRESENT(src_modulo)) src_is_modulo = src_modulo + + !--- check the grid size comformable + map_dst_xsize=size(lon_out,1);map_dst_ysize=size(lon_out,2) + map_src_xsize=size(lon_in,1); map_src_ysize=size(lon_in,2) + map_src_size = map_src_xsize*map_src_ysize + + if (map_dst_xsize /= size(lat_out,1) .or. map_dst_ysize /= size(lat_out,2)) & + call mpp_error(FATAL,'horiz_interp_spherical_mod: destination grids not conformable') + if (map_src_xsize /= size(lat_in,1) .or. map_src_ysize /= size(lat_in,2)) & + call mpp_error(FATAL,'horiz_interp_spherical_mod: source grids not conformable') + + theta_src = reshape(lon_in,(/map_src_size/)) + phi_src = reshape(lat_in,(/map_src_size/)) + theta_dst(:,:) = lon_out(:,:) + phi_dst(:,:) = lat_out(:,:) + + min_theta_dst=real(tpi, FMS_HI_KIND_);max_theta_dst=0.0_kindl + min_phi_dst=real(pi, FMS_HI_KIND_);max_phi_dst=real(-pi, FMS_HI_KIND_) + min_theta_src=real(tpi, FMS_HI_KIND_);max_theta_src=0.0_kindl + min_phi_src=real(pi, FMS_HI_KIND_);max_phi_src=real(-pi, FMS_HI_KIND_) + + where(theta_dst<0.0_kindl) theta_dst = theta_dst+real(tpi,FMS_HI_KIND_) + + where(theta_dst>real(tpi,FMS_HI_KIND_)) theta_dst = theta_dst-real(tpi,FMS_HI_KIND_) + where(theta_src<0.0_kindl) theta_src = theta_src+real(tpi,FMS_HI_KIND_) + where(theta_src>real(tpi,FMS_HI_KIND_)) theta_src = theta_src-real(tpi,FMS_HI_KIND_) + + where(phi_dst < -hpi) phi_dst = -hpi + where(phi_dst > hpi) phi_dst = hpi + where(phi_src < -hpi) phi_src = -hpi + where(phi_src > hpi) phi_src = hpi + + do j=1,map_dst_ysize + do i=1,map_dst_xsize + min_theta_dst = min(min_theta_dst,theta_dst(i,j)) + max_theta_dst = max(max_theta_dst,theta_dst(i,j)) + min_phi_dst = min(min_phi_dst,phi_dst(i,j)) + max_phi_dst = max(max_phi_dst,phi_dst(i,j)) + enddo + enddo + + do i=1,map_src_size + min_theta_src = min(min_theta_src,theta_src(i)) + max_theta_src = max(max_theta_src,theta_src(i)) + min_phi_src = min(min_phi_src,phi_src(i)) + max_phi_src = max(max_phi_src,phi_src(i)) + enddo + + if (min_phi_dst < min_phi_src) print *, '=> WARNING: latitute of dest grid exceeds src' + if (max_phi_dst > max_phi_src) print *, '=> WARNING: latitute of dest grid exceeds src' + ! when src is cyclic, no need to print out the following warning. + if(.not. src_is_modulo) then + if (min_theta_dst < min_theta_src) print *, '=> WARNING : longitude of dest grid exceeds src' + if (max_theta_dst > max_theta_src) print *, '=> WARNING : longitude of dest grid exceeds src' + endif + + ! allocate memory to data type + if(ALLOCATED(Interp%i_lon)) then + if(size(Interp%i_lon,1) .NE. map_dst_xsize .OR. & + size(Interp%i_lon,2) .NE. map_dst_ysize ) call mpp_error(FATAL, & + 'horiz_interp_spherical_mod: size(Interp%i_lon(:),1) .NE. map_dst_xsize .OR. '// & + 'size(Interp%i_lon(:),2) .NE. map_dst_ysize') + else + allocate(Interp%i_lon(map_dst_xsize,map_dst_ysize,max_neighbors), & + Interp%j_lat(map_dst_xsize,map_dst_ysize,max_neighbors), & + Interp%HI_KIND_TYPE_%src_dist(map_dst_xsize,map_dst_ysize,max_neighbors), & + Interp%num_found(map_dst_xsize,map_dst_ysize) ) + endif + + map_src_add = 0 + map_src_dist = real(large, FMS_HI_KIND_) + num_found = 0 + + !using radial_search to find the nearest points and corresponding distance. + + select case(trim(search_method)) + case ("radial_search") ! will be efficient, but may be not so accurate for some cases + call radial_search(theta_src, phi_src, theta_dst, phi_dst, map_src_xsize, map_src_ysize, & + map_src_add, map_src_dist, num_found, num_neighbors,max_src_dist,src_is_modulo) + case ("full_search") ! always accurate, but less efficient. + call full_search(theta_src, phi_src, theta_dst, phi_dst, map_src_add, map_src_dist, & + num_found, num_neighbors,max_src_dist ) + case default + call mpp_error(FATAL,"HORIZ_INTERP_SPHERICAL_NEW_: nml search_method = "// & + trim(search_method)//" is not a valid namelist option") + end select + + do j=1,map_dst_ysize + do i=1,map_dst_xsize + do n=1,num_found(i,j) + if(map_src_add(i,j,n) == 0) then + jlat(n) = 0; ilon(n) = 0 + else + jlat(n) = map_src_add(i,j,n)/map_src_xsize + 1 + ilon(n) = map_src_add(i,j,n) - (jlat(n)-1)*map_src_xsize + if(ilon(n) == 0) then + jlat(n) = jlat(n) - 1 + ilon(n) = map_src_xsize + endif + endif + enddo + Interp%i_lon(i,j,:) = ilon(:) + Interp%j_lat(i,j,:) = jlat(:) + Interp%num_found(i,j) = num_found(i,j) + Interp%HI_KIND_TYPE_%src_dist(i,j,:) = map_src_dist(i,j,:) + enddo + enddo + + Interp%nlon_src = map_src_xsize; Interp%nlat_src = map_src_ysize + Interp%nlon_dst = map_dst_xsize; Interp%nlat_dst = map_dst_ysize + + return + + end subroutine HORIZ_INTERP_SPHERICAL_NEW_ + + !####################################################################### + + !> Subroutine for performing the horizontal interpolation between two grids. + !! HORIZ_INTERP_SPHERICAL_NEW_ must be called before calling this routine. + subroutine HORIZ_INTERP_SPHERICAL_( Interp, data_in, data_out, verbose, mask_in, mask_out, missing_value) + type(horiz_interp_type), intent(in) :: Interp !< A derived type variable containing indices + !! and weights for subsequent interpolations. Returned + !! by a previous call to HORIZ_INTERP_SPHERICAL_NEW_ + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data_in !< Input data on source grid + real(FMS_HI_KIND_), intent(out), dimension(:,:) :: data_out !< Output data on destination grid + integer, intent(in), optional :: verbose !< 0 = no output; 1 = min,max,means; 2 = most output + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in !< Input mask, must be the same size as + !! the input data. The real(FMS_HI_KIND_) value of mask_in must be + !! in the range (0.,1.). Set mask_in=0.0 for data points + !! that should not be used or have missing data + real(FMS_HI_KIND_), intent(out), dimension(:,:), optional :: mask_out !< Output mask that specifies whether data + !! was computed. + real(FMS_HI_KIND_), intent(in), optional :: missing_value !< Used to indicate missing data + + !--- some local variables ---------------------------------------- + real(FMS_HI_KIND_), dimension(Interp%nlon_dst, Interp%nlat_dst,size(Interp%HI_KIND_TYPE_%src_dist,3)) :: wt + real(FMS_HI_KIND_), dimension(Interp%nlon_src, Interp%nlat_src) :: mask_src + real(FMS_HI_KIND_), dimension(Interp%nlon_dst, Interp%nlat_dst) :: mask_dst + integer :: nlon_in, nlat_in, nlon_out, nlat_out, num_found + integer :: m, n, i, j, k, miss_in, miss_out, i1, i2, j1, j2, iverbose + real(FMS_HI_KIND_) :: min_in, max_in, avg_in, min_out, max_out, avg_out, sum + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled real kind size + !----------------------------------------------------------------- + + iverbose = 0; if (present(verbose)) iverbose = verbose + + nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src + nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst + + if(size(data_in,1) .ne. nlon_in .or. size(data_in,2) .ne. nlat_in ) & + call mpp_error(FATAL,'horiz_interp_spherical_mod: size of input array incorrect') + + if(size(data_out,1) .ne. nlon_out .or. size(data_out,2) .ne. nlat_out ) & + call mpp_error(FATAL,'horiz_interp_spherical_mod: size of output array incorrect') + + mask_src = 1.0_kindl; mask_dst = 1.0_kindl + if(present(mask_in)) mask_src = mask_in + + do n=1,nlat_out + do m=1,nlon_out + ! neighbors are sorted nearest to farthest + ! check nearest to see if it is a land point + num_found = Interp%num_found(m,n) + if(num_found == 0 ) then + mask_dst(m,n) = 0.0_kindl + else + i1 = Interp%i_lon(m,n,1); j1 = Interp%j_lat(m,n,1) + if (mask_src(i1,j1) .lt. 0.5_kindl ) then + mask_dst(m,n) = 0.0_kindl + endif + + if(num_found .gt. 1 ) then + i2 = Interp%i_lon(m,n,2); j2 = Interp%j_lat(m,n,2) + ! compare first 2 nearest neighbors -- if they are nearly + ! equidistant then use this mask for robustness + if(abs(Interp%HI_KIND_TYPE_%src_dist(m,n,2)-Interp%HI_KIND_TYPE_%src_dist(m,n,1)) .lt. & + real(epsln,FMS_HI_KIND_)) then + if((mask_src(i1,j1) .lt. 0.5_kindl )) mask_dst(m,n) = 0.0_kindl + endif + endif + + sum=0.0_kindl + do k=1, num_found + if(mask_src(Interp%i_lon(m,n,k),Interp%j_lat(m,n,k)) .lt. 0.5_kindl ) then + wt(m,n,k) = 0.0_kindl + else + if (Interp%HI_KIND_TYPE_%src_dist(m,n,k) <= real(epsln,FMS_HI_KIND_)) then + wt(m,n,k) = real(large, FMS_HI_KIND_) + sum = sum + real(large, FMS_HI_KIND_) + else if(Interp%HI_KIND_TYPE_%src_dist(m,n,k) <= Interp%HI_KIND_TYPE_%max_src_dist ) then + wt(m,n,k) = 1.0_kindl /Interp%HI_KIND_TYPE_%src_dist(m,n,k) + sum = sum+wt(m,n,k) + else + wt(m,n,k) = 0.0_kindl + endif + endif + enddo + if (sum > real(epsln,FMS_HI_KIND_)) then + do k = 1, num_found + wt(m,n,k) = wt(m,n,k)/sum + enddo + else + mask_dst(m,n) = 0.0_kindl + endif + endif + enddo + enddo + + data_out = 0.0_kindl + do n=1,nlat_out + do m=1,nlon_out + if(mask_dst(m,n) .gt. 0.5_kindl ) then + do k=1, Interp%num_found(m,n) + i = Interp%i_lon(m,n,k) + j = Interp%j_lat(m,n,k) + data_out(m,n) = data_out(m,n)+data_in(i,j)*wt(m,n,k) + enddo + else + if(present(missing_value)) then + data_out(m,n) = missing_value + else + data_out(m,n) = 0.0_kindl + endif + endif + enddo + enddo + + if(present(mask_out)) mask_out = mask_dst + + !*********************************************************************** + ! compute statistics: minimum, maximum, and mean + !----------------------------------------------------------------------- + + if (iverbose > 0) then + + ! compute statistics of input data + + call stats (data_in, min_in, max_in, avg_in, miss_in, missing_value, mask=mask_src) + + ! compute statistics of output data + call stats (data_out, min_out, max_out, avg_out, miss_out, missing_value, mask=mask_dst) + + !---- output statistics ---- + ! root_pe have the information of global mean, min and max + if(pe == root_pe) then + write (*,900) + write (*,901) min_in ,max_in, avg_in + if (present(mask_in)) write (*,903) miss_in + write (*,902) min_out,max_out,avg_out + if (present(mask_out)) write (*,903) miss_out + endif +900 format (/,1x,10('-'),' output from horiz_interp ',10('-')) +901 format (' input: min=',f16.9,' max=',f16.9,' avg=',f22.15) +902 format (' output: min=',f16.9,' max=',f16.9,' avg=',f22.15) +903 format (' number of missing points = ',i6) + + endif + + return + end subroutine HORIZ_INTERP_SPHERICAL_ + + !####################################################################### + !> This routine isn't used internally + !! it's similar to the routine above, just gets the weights as an out variable + subroutine HORIZ_INTERP_SPHERICAL_WGHT_( Interp, wt, verbose, mask_in, mask_out, missing_value) + type (horiz_interp_type), intent(in) :: Interp + real(FMS_HI_KIND_), intent(out), dimension(:,:,:) :: wt + integer, intent(in), optional :: verbose + real(FMS_HI_KIND_), intent(in), dimension(:,:), optional :: mask_in + real(FMS_HI_KIND_), intent(inout), dimension(:,:), optional :: mask_out + real(FMS_HI_KIND_), intent(in), optional :: missing_value + + !--- some local variables ---------------------------------------- + real(FMS_HI_KIND_), dimension(Interp%nlon_src, Interp%nlat_src) :: mask_src + real(FMS_HI_KIND_), dimension(Interp%nlon_dst, Interp%nlat_dst) :: mask_dst + integer :: nlon_in, nlat_in, nlon_out, nlat_out, num_found + integer :: m, n, k, i1, i2, j1, j2, iverbose + real(FMS_HI_KIND_) :: sum + integer, parameter :: kindl = FMS_HI_KIND_ + !----------------------------------------------------------------- + + iverbose = 0; if (present(verbose)) iverbose = verbose + + nlon_in = Interp%nlon_src; nlat_in = Interp%nlat_src + nlon_out = Interp%nlon_dst; nlat_out = Interp%nlat_dst + + mask_src = 1.0_kindl ; mask_dst = 1.0_kindl + if(present(mask_in)) mask_src = mask_in + + do n=1,nlat_out + do m=1,nlon_out + ! neighbors are sorted nearest to farthest + ! check nearest to see if it is a land point + num_found = Interp%num_found(m,n) + + if (num_found > num_nbrs_default) then + if( iverbose .gt. 0) print *,'pe=',mpp_pe(),'num_found=',num_found + num_found = num_nbrs_default + end if + + if(num_found == 0 ) then + mask_dst(m,n) = 0.0_kindl + else + i1 = Interp%i_lon(m,n,1); j1 = Interp%j_lat(m,n,1) + if (mask_src(i1,j1) .lt. 0.5_kindl) then + mask_dst(m,n) = 0.0_kindl + endif + + if(num_found .gt. 1 ) then + i2 = Interp%i_lon(m,n,2); j2 = Interp%j_lat(m,n,2) + ! compare first 2 nearest neighbors -- if they are nearly + ! equidistant then use this mask for robustness + if(abs(Interp%HI_KIND_TYPE_%src_dist(m,n,2)-Interp%HI_KIND_TYPE_%src_dist(m,n,1)) .lt. & + real(epsln,FMS_HI_KIND_)) then + if((mask_src(i1,j1) .lt. 0.5_kindl )) mask_dst(m,n) = 0.0_kindl + endif + endif + + sum=0.0_kindl + do k=1, num_found + if(mask_src(Interp%i_lon(m,n,k),Interp%j_lat(m,n,k)) .lt. 0.5_kindl ) then + wt(m,n,k) = 0.0_kindl + else + if (Interp%HI_KIND_TYPE_%src_dist(m,n,k) <= real(epsln, FMS_HI_KIND_)) then + wt(m,n,k) = real(large, FMS_HI_KIND_) + sum = sum + real(large, FMS_HI_KIND_) + else if(Interp%HI_KIND_TYPE_%src_dist(m,n,k) <= Interp%HI_KIND_TYPE_%max_src_dist ) then + wt(m,n,k) = 1.0_kindl /Interp%HI_KIND_TYPE_%src_dist(m,n,k) + sum = sum+wt(m,n,k) + else + wt(m,n,k) = 0.0_kindl + endif + endif + enddo + if (sum > real(epsln,FMS_HI_KIND_)) then + do k = 1, num_found + wt(m,n,k) = wt(m,n,k)/sum + enddo + else + mask_dst(m,n) = 0.0_kindl + endif + endif + enddo + enddo + + return + end subroutine HORIZ_INTERP_SPHERICAL_WGHT_ + + !####################################################################### + + subroutine RADIAL_SEARCH_(theta_src,phi_src,theta_dst,phi_dst, map_src_xsize, map_src_ysize, & + map_src_add, map_src_dist, num_found, num_neighbors,max_src_dist,src_is_modulo) + real(FMS_HI_KIND_), intent(in), dimension(:) :: theta_src, phi_src + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: theta_dst, phi_dst + integer, intent(in) :: map_src_xsize, map_src_ysize + integer, intent(out), dimension(:,:,:) :: map_src_add + real(FMS_HI_KIND_), intent(out), dimension(:,:,:) :: map_src_dist + integer, intent(inout), dimension(:,:) :: num_found + integer, intent(in) :: num_neighbors + real(FMS_HI_KIND_), intent(in) :: max_src_dist + logical, intent(in) :: src_is_modulo + + !---------- local variables ---------------------------------------- + integer, parameter :: max_nbrs = 50 + integer :: i, j, jj, i0, j0, n, l,i_left, i_right + integer :: map_dst_xsize, map_dst_ysize + integer :: i_left1, i_left2, i_right1, i_right2 + integer :: map_src_size, step, step_size, bound, bound_start, bound_end + logical :: continue_search, result, continue_radial_search + real(FMS_HI_KIND_) :: d, res + !------------------------------------------------------------------ + map_dst_xsize=size(theta_dst,1);map_dst_ysize=size(theta_dst,2) + map_src_size = map_src_xsize*map_src_ysize + + do j=1,map_dst_ysize + do i=1,map_dst_xsize + continue_search=.true. + step = 1 + step_size = int( sqrt(real(map_src_size, kind=FMS_HI_KIND_ ))) + do while (continue_search .and. step_size > 0) + do while (step <= map_src_size .and. continue_search) + ! count land points as nearest neighbors + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(step),phi_src(step)) + if (d <= max_src_dist) then + result = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + step,d, num_found(i,j), num_neighbors ) + if (result) then + n = 0 + i0 = mod(step,map_src_xsize) + + if (i0 == 0) i0 = map_src_xsize + res = real(step, FMS_HI_KIND_)/real(map_src_xsize, FMS_HI_KIND_) + j0 = ceiling(res) + continue_radial_search = .true. + do while (continue_radial_search) + continue_radial_search = .false. + n = n+1 ! radial counter + if(n > max_nbrs) exit + ! ************** left boundary ******************************* + i_left = i0-n + if (i_left <= 0) then + if (src_is_modulo) then + i_left = map_src_xsize + i_left + else + i_left = 1 + endif + endif + + do l = 0, 2*n + jj = j0 - n - 1 + l + if( jj < 0) then + bound = ( 1 - jj )*map_src_xsize - i_left + else if ( jj >= map_src_ysize ) then + bound = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left + else + bound = jj * map_src_xsize + i_left + endif + + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound), & + phi_src(bound)) + if(d<=max_src_dist) then + result = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + bound,d, num_found(i,j), num_neighbors) + if (result) continue_radial_search = .true. + endif + enddo + + ! ***************************right boundary ******************************* + i_right = i0+n + if (i_right > map_src_xsize) then + if (src_is_modulo) then + i_right = i_right - map_src_xsize + else + i_right = map_src_xsize + endif + endif + + do l = 0, 2*n + jj = j0 - n - 1 + l + if( jj < 0) then + bound = ( 1 - jj )*map_src_xsize - i_right + else if ( jj >= map_src_ysize ) then + bound = ( 2*map_src_ysize - jj) * map_src_xsize - i_right + + else + bound = jj * map_src_xsize + i_right + endif + + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound), & + phi_src(bound)) + if(d<=max_src_dist) then + result = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + bound,d, num_found(i,j), num_neighbors) + if (result) continue_radial_search = .true. + endif + enddo + + ! ************************* bottom boundary ********************************** + i_left2 = 0 + if( i_left > i_right) then + i_left1 = 1 + i_right1 = i_right + i_left2 = i_left + i_right2 = map_src_xsize + else + i_left1 = i_left + i_right1 = i_right + endif + + jj = j0 - n - 1 + if( jj < 0 ) then + bound_start = ( 1 - jj)*map_src_xsize - i_right1 + bound_end = ( 1 - jj)*map_src_xsize - i_left1 + else + bound_start = jj * map_src_xsize + i_left1 + bound_end = jj * map_src_xsize + i_right1 + endif + + bound = bound_start + do while (bound <= bound_end) + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound), & + phi_src(bound)) + if(d<=max_src_dist) then + result = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + bound,d, num_found(i,j), num_neighbors) + if (result) continue_radial_search = .true. + endif + bound = bound + 1 + + enddo + + if(i_left2 > 0 ) then + if( jj < 0 ) then + bound_start = ( 1 - jj)*map_src_xsize - i_right2 + bound_end = ( 1 - jj)*map_src_xsize - i_left2 + else + bound_start = jj * map_src_xsize + i_left2 + bound_end = jj * map_src_xsize + i_right2 + endif + + bound = bound_start + do while (bound <= bound_end) + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound), & + phi_src(bound)) + if(d<=max_src_dist) then + result = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + bound,d, num_found(i,j), num_neighbors) + if (result) continue_radial_search = .true. + endif + bound = bound + 1 + enddo + endif + + ! ************************** top boundary ************************************ + jj = j0 + n - 1 + if( jj >= map_src_ysize) then + bound_start = ( 2*map_src_ysize - jj ) * map_src_xsize - i_right1 + bound_end = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left1 + else + bound_start = jj * map_src_xsize + i_left1 + bound_end = jj * map_src_xsize + i_right1 + endif + + bound = bound_start + do while (bound <= bound_end) + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound), & + phi_src(bound)) + if(d<=max_src_dist) then + result = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + bound,d, num_found(i,j), num_neighbors) + if (result) continue_radial_search = .true. + endif + bound = bound + 1 + enddo + + if(i_left2 > 0) then + if( jj >= map_src_ysize) then + bound_start = ( 2*map_src_ysize - jj ) * map_src_xsize - i_right2 + bound_end = ( 2*map_src_ysize - jj ) * map_src_xsize - i_left2 + else + bound_start = jj * map_src_xsize + i_left2 + bound_end = jj * map_src_xsize + i_right2 + endif + + bound = bound_start + do while (bound <= bound_end) + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(bound), & + phi_src(bound)) + if(d<=max_src_dist) then + result = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + bound,d, num_found(i,j), num_neighbors) + if (result) continue_radial_search = .true. + endif + bound = bound + 1 + enddo + endif + + enddo + continue_search = .false. ! stop looking + endif + endif + step=step+step_size + enddo ! search loop + step = 1 + step_size = step_size/2 + enddo + enddo + enddo + + return + + end subroutine RADIAL_SEARCH_ + + + !##################################################################### + + function UPDATE_DEST_NEIGHBORS_(map_src_add, map_src_dist, src_add,d, num_found, min_nbrs) + + integer, intent(inout), dimension(:) :: map_src_add + real(FMS_HI_KIND_), intent(inout), dimension(:) :: map_src_dist + integer, intent(in) :: src_add + real(FMS_HI_KIND_), intent(in) :: d + integer, intent(inout) :: num_found + integer, intent(in) :: min_nbrs + + logical :: UPDATE_DEST_NEIGHBORS_, already_exist = .false. + + integer :: n,m + + UPDATE_DEST_NEIGHBORS_ = .false. + + n = 0 + NLOOP : do while ( n .le. num_found ) + n = n + 1 + DIST_CHK : if (d .le. map_src_dist(n)) then + do m=n,num_found + if (src_add == map_src_add(m)) then + already_exist = .true. + exit NLOOP + endif + enddo + if(num_found < max_neighbors) then + num_found = num_found + 1 + else + call mpp_error(FATAL,'UPDATE_DEST_NEIGHBORS_: '// & + 'number of neighbor points found is greated than maxium neighbor points' ) + endif + do m=num_found,n+1,-1 + map_src_add(m) = map_src_add(m-1) + map_src_dist(m) = map_src_dist(m-1) + enddo + map_src_add(n) = src_add + map_src_dist(n) = d + UPDATE_DEST_NEIGHBORS_ = .true. + if( num_found > min_nbrs ) then + if( map_src_dist(num_found) > map_src_dist(num_found-1) ) then + num_found = num_found - 1 + endif + if( map_src_dist(min_nbrs+1) > map_src_dist(min_nbrs) ) then + num_found = min_nbrs + endif + endif + exit NLOOP ! n loop + endif DIST_CHK + end do NLOOP + if(already_exist) return + + if( .not. UPDATE_DEST_NEIGHBORS_ ) then + if( num_found < min_nbrs ) then + num_found = num_found + 1 + UPDATE_DEST_NEIGHBORS_ = .true. + map_src_add(num_found) = src_add + map_src_dist(num_found) = d + endif + endif + + + return + + end function UPDATE_DEST_NEIGHBORS_ + + !######################################################################## +! function HORIZ_INTERP_SPHERICAL_DISTANCE_(theta1,phi1,theta2,phi2) + +! real(FMS_HI_KIND_), intent(in) :: theta1, phi1, theta2, phi2 +! real(FMS_HI_KIND_) :: HORIZ_INTERP_SPHERICAL_DISTANCE_ + +! real(FMS_HI_KIND_) :: r1(3), r2(3), cross(3), s, dot, ang + + ! this is a simple, enough way to calculate distance on the sphere + ! first, construct cartesian vectors r1 and r2 + ! then calculate the cross-product which is proportional to the area + ! between the 2 vectors. The angular distance is arcsin of the + ! distancealong the sphere + ! + ! theta is longitude and phi is latitude + ! + + +! r1(1) = cos(theta1)*cos(phi1);r1(2)=sin(theta1)*cos(phi1);r1(3)=sin(phi1) +! r2(1) = cos(theta2)*cos(phi2);r2(2)=sin(theta2)*cos(phi2);r2(3)=sin(phi2) + +! cross(1) = r1(2)*r2(3)-r1(3)*r2(2) +! cross(2) = r1(3)*r2(1)-r1(1)*r2(3) +! cross(3) = r1(1)*r2(2)-r1(2)*r2(1) + +! s = sqrt(cross(1)**2.+cross(2)**2.+cross(3)**2.) + +! s = min(s,real(1.0, FMS_HI_KIND_)-epsln) + +! dot = r1(1)*r2(1) + r1(2)*r2(2) + r1(3)*r2(3) + +! if (dot > 0) then +! ang = asin(s) +! else if (dot < 0) then +! ang = pi + asin(s) !? original is pi - asin(s) +! else +! ang = pi/real(2., FMS_HI_KIND_) +! endif + +! HORIZ_INTERP_SPHERICAL_DISTANCE_ = abs(ang) ! in radians + +! return + +! end function HORIZ_INTERP_SPHERICAL_DISTANCE_ + ! The great cycle distance + function HORIZ_INTERP_SPHERICAL_DISTANCE_(theta1,phi1,theta2,phi2) + + real(FMS_HI_KIND_), intent(in) :: theta1, phi1, theta2, phi2 + real(FMS_HI_KIND_) :: HORIZ_INTERP_SPHERICAL_DISTANCE_, dot + integer, parameter :: kindl = FMS_HI_KIND_ + + if(theta1 == theta2 .and. phi1 == phi2) then + HORIZ_INTERP_SPHERICAL_DISTANCE_ = 0.0_kindl + return + endif + + dot = cos(phi1)*cos(phi2)*cos(theta1-theta2) + sin(phi1)*sin(phi2) + if(dot > 1.0_kindl) dot = 1.0_kindl + if(dot < real(-1.0_kindl, FMS_HI_KIND_)) dot = -1.0_kindl + HORIZ_INTERP_SPHERICAL_DISTANCE_ = acos(dot) + + return + + end function HORIZ_INTERP_SPHERICAL_DISTANCE_ + + + !####################################################################### + + subroutine FULL_SEARCH_(theta_src,phi_src,theta_dst,phi_dst,map_src_add, map_src_dist,num_found, & + num_neighbors,max_src_dist) + real(FMS_HI_KIND_), intent(in), dimension(:) :: theta_src, phi_src + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: theta_dst, phi_dst + integer, intent(out), dimension(:,:,:) :: map_src_add + real(FMS_HI_KIND_), intent(out), dimension(:,:,:) :: map_src_dist + integer, intent(out), dimension(:,:) :: num_found + integer, intent(in) :: num_neighbors + real(FMS_HI_KIND_), intent(in) :: max_src_dist + + integer :: i,j,map_src_size, step + integer :: map_dst_xsize,map_dst_ysize + real(FMS_HI_KIND_) :: d + logical :: found + + map_dst_xsize=size(theta_dst,1);map_dst_ysize=size(theta_dst,2) + map_src_size =size(theta_src(:)) + + do j=1,map_dst_ysize + do i=1,map_dst_xsize + do step = 1, map_src_size + d = spherical_distance(theta_dst(i,j),phi_dst(i,j),theta_src(step),phi_src(step)) + if( d <= max_src_dist) then + found = UPDATE_DEST_NEIGHBORS_(map_src_add(i,j,:),map_src_dist(i,j,:), & + step,d,num_found(i,j), num_neighbors ) + endif + enddo + enddo + enddo + + end subroutine FULL_SEARCH_ +!> @} diff --git a/horiz_interp/include/horiz_interp_spherical_r4.fh b/horiz_interp/include/horiz_interp_spherical_r4.fh new file mode 100644 index 0000000000..a4a0f3fd6b --- /dev/null +++ b/horiz_interp/include/horiz_interp_spherical_r4.fh @@ -0,0 +1,49 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_spherical +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r4_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals4_type + +#undef HORIZ_INTERP_SPHERICAL_ +#define HORIZ_INTERP_SPHERICAL_ horiz_interp_spherical_r4 + +#undef HORIZ_INTERP_SPHERICAL_NEW_ +#define HORIZ_INTERP_SPHERICAL_NEW_ horiz_interp_spherical_new_r4 + +#undef HORIZ_INTERP_SPHERICAL_WGHT_ +#define HORIZ_INTERP_SPHERICAL_WGHT_ horiz_interp_spherical_wght_r4 + +#undef RADIAL_SEARCH_ +#define RADIAL_SEARCH_ radial_search_r4 + +#undef UPDATE_DEST_NEIGHBORS_ +#define UPDATE_DEST_NEIGHBORS_ update_dest_neighbors_r4 + +#undef HORIZ_INTERP_SPHERICAL_DISTANCE_ +#define HORIZ_INTERP_SPHERICAL_DISTANCE_ spherical_distance_r4 + +#undef FULL_SEARCH_ +#define FULL_SEARCH_ full_search_r4 + +#include "horiz_interp_spherical.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_spherical_r8.fh b/horiz_interp/include/horiz_interp_spherical_r8.fh new file mode 100644 index 0000000000..500e826ded --- /dev/null +++ b/horiz_interp/include/horiz_interp_spherical_r8.fh @@ -0,0 +1,49 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_spherical +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r8_kind + +#undef HI_KIND_TYPE_ +#define HI_KIND_TYPE_ horizInterpReals8_type + +#undef HORIZ_INTERP_SPHERICAL_ +#define HORIZ_INTERP_SPHERICAL_ horiz_interp_spherical_r8 + +#undef HORIZ_INTERP_SPHERICAL_NEW_ +#define HORIZ_INTERP_SPHERICAL_NEW_ horiz_interp_spherical_new_r8 + +#undef HORIZ_INTERP_SPHERICAL_WGHT_ +#define HORIZ_INTERP_SPHERICAL_WGHT_ horiz_interp_spherical_wght_r8 + +#undef RADIAL_SEARCH_ +#define RADIAL_SEARCH_ radial_search_r8 + +#undef UPDATE_DEST_NEIGHBORS_ +#define UPDATE_DEST_NEIGHBORS_ update_dest_neighbors_r8 + +#undef HORIZ_INTERP_SPHERICAL_DISTANCE_ +#define HORIZ_INTERP_SPHERICAL_DISTANCE_ spherical_distance_r8 + +#undef FULL_SEARCH_ +#define FULL_SEARCH_ full_search_r8 + +#include "horiz_interp_spherical.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_type.inc b/horiz_interp/include/horiz_interp_type.inc new file mode 100644 index 0000000000..4715143dac --- /dev/null +++ b/horiz_interp/include/horiz_interp_type.inc @@ -0,0 +1,90 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_type_mod +!> @{ +!> @brief This statistics is for bilinear interpolation and spherical regrid. + subroutine STATS_ ( dat, low, high, avg, miss, missing_value, mask ) + real(FMS_HI_KIND_), intent(in) :: dat(:,:) + real(FMS_HI_KIND_), intent(out) :: low, high, avg + integer, intent(out) :: miss + real(FMS_HI_KIND_), intent(in), optional :: missing_value + real(FMS_HI_KIND_), intent(in), optional :: mask(:,:) + + real(FMS_HI_KIND_) :: dsum, buffer_real(3) + integer :: pe, root_pe, npes, p, buffer_int(2), npts + integer, parameter :: kindl = FMS_HI_KIND_ !< compiled kind size + + pe = mpp_pe() + root_pe = mpp_root_pe() + npes = mpp_npes() + + dsum = 0.0_kindl + miss = 0 + + if (present(missing_value)) then + miss = count(dat(:,:) == missing_value) + low = minval(dat(:,:), dat(:,:) /= missing_value) + high = maxval(dat(:,:), dat(:,:) /= missing_value) + dsum = sum(dat(:,:), dat(:,:) /= missing_value) + else if(present(mask)) then + miss = count(mask(:,:) <= 0.5_kindl ) + low = minval(dat(:,:),mask=mask(:,:) > 0.5_kindl) + high = maxval(dat(:,:),mask=mask(:,:) > 0.5_kindl) + dsum = sum(dat(:,:), mask=mask(:,:) > 0.5_kindl) + else + miss = 0 + low = minval(dat(:,:)) + high = maxval(dat(:,:)) + dsum = sum(dat(:,:)) + endif + avg = 0.0_kindl + + npts = size(dat(:,:)) - miss + if(pe == root_pe) then + do p = 1, npes - 1 ! root_pe receive data from other pe + ! Force use of "scalar", integer pointer mpp interface + call mpp_recv(buffer_real(1),glen=3, from_pe=p+root_pe, tag=COMM_TAG_1) + dsum = dsum + buffer_real(1) + low = min(low, buffer_real(2)) + high = max(high, buffer_real(3)) + call mpp_recv(buffer_int(1), glen=2, from_pe=p+root_pe, tag=COMM_TAG_2) + miss = miss + buffer_int(1) + npts = npts + buffer_int(2) + enddo + if(npts == 0) then + print*, 'Warning: no points is valid' + else + avg = dsum/real(npts, FMS_HI_KIND_) + endif + else ! other pe send data to the root_pe. + buffer_real(1) = dsum + buffer_real(2) = low + buffer_real(3) = high + ! Force use of "scalar", integer pointer mpp interface + call mpp_send(buffer_real(1),plen=3,to_pe=root_pe, tag=COMM_TAG_1) + buffer_int(1) = miss + buffer_int(2) = npts + call mpp_send(buffer_int(1), plen=2, to_pe=root_pe, tag=COMM_TAG_2) + endif + + call mpp_sync_self() + + return + + end subroutine STATS_ \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_type_r4.fh b/horiz_interp/include/horiz_interp_type_r4.fh new file mode 100644 index 0000000000..3b45c8eb29 --- /dev/null +++ b/horiz_interp/include/horiz_interp_type_r4.fh @@ -0,0 +1,28 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_type +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r4_kind + +#undef STATS_ +#define STATS_ stats_r4 + +#include "horiz_interp_type.inc" +!> @} \ No newline at end of file diff --git a/horiz_interp/include/horiz_interp_type_r8.fh b/horiz_interp/include/horiz_interp_type_r8.fh new file mode 100644 index 0000000000..67d496fa28 --- /dev/null +++ b/horiz_interp/include/horiz_interp_type_r8.fh @@ -0,0 +1,28 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup horiz_interp_type +!> @{ +#undef FMS_HI_KIND_ +#define FMS_HI_KIND_ r8_kind + +#undef STATS_ +#define STATS_ stats_r8 + +#include "horiz_interp_type.inc" +!> @} \ No newline at end of file diff --git a/sat_vapor_pres/Makefile.am b/sat_vapor_pres/Makefile.am index 6a8546691b..2511061c62 100644 --- a/sat_vapor_pres/Makefile.am +++ b/sat_vapor_pres/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/28/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/sat_vapor_pres/include AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build these uninstalled convenience library. @@ -31,16 +31,30 @@ noinst_LTLIBRARIES = libsat_vapor_pres.la # Each convenience library depends on its source. libsat_vapor_pres_la_SOURCES = \ - sat_vapor_pres.F90 \ - sat_vapor_pres_k.F90 + sat_vapor_pres.F90 \ + include/sat_vapor_pres_r4.fh \ + include/sat_vapor_pres_r8.fh \ + include/sat_vapor_pres.inc \ + sat_vapor_pres_k.F90 \ + include/sat_vapor_pres_k_r4.fh \ + include/sat_vapor_pres_k_r8.fh \ + include/sat_vapor_pres_k.inc # Some mods are dependant on other mods in this dir. -sat_vapor_pres_mod.$(FC_MODEXT): sat_vapor_pres_k_mod.$(FC_MODEXT) +sat_vapor_pres_mod.$(FC_MODEXT): \ + sat_vapor_pres_k_mod.$(FC_MODEXT) \ + include/sat_vapor_pres_r4.fh \ + include/sat_vapor_pres_r8.fh \ + include/sat_vapor_pres.inc +sat_vapor_pres_k_mod.$(FC_MODEXT): \ + include/sat_vapor_pres_k_r4.fh \ + include/sat_vapor_pres_k_r8.fh \ + include/sat_vapor_pres_k.inc # Mod files are built and then installed as headers. MODFILES = \ - sat_vapor_pres_k_mod.$(FC_MODEXT) \ - sat_vapor_pres_mod.$(FC_MODEXT) + sat_vapor_pres_k_mod.$(FC_MODEXT) \ + sat_vapor_pres_mod.$(FC_MODEXT) BUILT_SOURCES = $(MODFILES) nodist_include_HEADERS = $(MODFILES) diff --git a/sat_vapor_pres/include/sat_vapor_pres.inc b/sat_vapor_pres/include/sat_vapor_pres.inc new file mode 100644 index 0000000000..35a67fa8a2 --- /dev/null +++ b/sat_vapor_pres/include/sat_vapor_pres.inc @@ -0,0 +1,1984 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup sat_vapor_pres_mod +!> @{ + +!####################################################################### +! +! +! +! +! + subroutine LOOKUP_ES_0D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES_0D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES_1D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif + +!----------------------------------------------- + + end subroutine LOOKUP_ES_1D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES_2D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif + +!----------------------------------------------- + + end subroutine LOOKUP_ES_2D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES_3D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:,:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_tmp,err_msg)) return + endif + + end subroutine LOOKUP_ES_3D_ + + +!####################################################################### +! +! +! +! +! + subroutine LOOKUP_ES2_0D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES2_0D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES2_1D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return + endif + +!----------------------------------------------- + + end subroutine LOOKUP_ES2_1D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES2_2D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return + endif + +!----------------------------------------------- + + end subroutine LOOKUP_ES2_2D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES2_3D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:,:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2',err_msg_tmp,err_msg)) return + endif + + end subroutine LOOKUP_ES2_3D_ + + +!####################################################################### +! +! +! +! +! + subroutine LOOKUP_ES3_0D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES3_0D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES3_1D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return + endif + +!----------------------------------------------- + + end subroutine LOOKUP_ES3_1D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES3_2D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return + endif + +!----------------------------------------------- + + end subroutine LOOKUP_ES3_2D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_ES3_3D_ ( temp, esat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat(:,:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_k(temp, esat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3',err_msg_tmp,err_msg)) return + endif + + end subroutine LOOKUP_ES3_3D_ + + +!####################################################################### +! routines for computing derivative of es +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_DES_0D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des_k( temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_DES_0D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_DES_1D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if(present(err_msg)) err_msg='' + + call lookup_des_k(temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif +!----------------------------------------------- + + end subroutine LOOKUP_DES_1D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_DES_2D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:,:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des_k(temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif +!----------------------------------------------- + + end subroutine LOOKUP_DES_2D_ + +!####################################################################### +! +! +! +! +! + subroutine LOOKUP_DES_3D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:,:,:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des_k( temp, desat, nbad ) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg='' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des',err_msg_tmp,err_msg)) return + endif + + end subroutine LOOKUP_DES_3D_ + + +! +! +! +! +! + subroutine LOOKUP_DES2_0D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des2_k( temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_DES2_0D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_DES2_1D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if(present(err_msg)) err_msg='' + + call lookup_des2_k(temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return + endif +!----------------------------------------------- + + end subroutine LOOKUP_DES2_1D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_DES2_2D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:,:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des2_k(temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return + endif +!----------------------------------------------- + + end subroutine LOOKUP_DES2_2D_ + +!####################################################################### +! +! +! +! +! + subroutine LOOKUP_DES2_3D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:,:,:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des2_k( temp, desat, nbad ) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg='' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des2',err_msg_tmp,err_msg)) return + endif + + end subroutine LOOKUP_DES2_3D_ + + +! +! +! +! +! + subroutine LOOKUP_DES3_0D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des3_k( temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_DES3_0D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_DES3_1D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if(present(err_msg)) err_msg='' + + call lookup_des3_k(temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return + endif +!----------------------------------------------- + + end subroutine LOOKUP_DES3_1D_ + +!####################################################################### + +! +! +! +! +! + subroutine LOOKUP_DES3_2D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:,:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + character(len=54) :: err_msg_local + integer :: nbad !< if temperature is out of range +!----------------------------------------------- + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des3_k(temp, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return + endif +!----------------------------------------------- + + end subroutine LOOKUP_DES3_2D_ + +!####################################################################### +! +! +! +! +! + subroutine LOOKUP_DES3_3D_ ( temp, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp (:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: desat(:,:,:) !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_des3_k( temp, desat, nbad ) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg='' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_des3',err_msg_tmp,err_msg)) return + endif + + end subroutine LOOKUP_DES3_3D_ + +!======================================================================================================== + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES_DES_0D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_des_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES_DES_0D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES_DES_1D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_des_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES_DES_1D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES_DES_2D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_des_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES_DES_2D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES_DES_3D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es_des_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES_DES_3D_ + +!####################################################################### +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES2_DES2_0D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_des2_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES2_DES2_0D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES2_DES2_1D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_des2_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES2_DES2_1D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES2_DES2_2D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_des2_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES2_DES2_2D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES2_DES2_3D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es2_des2_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES2_DES2_3D_ + + +!####################################################################### +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES3_DES3_0D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_des3_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES3_DES3_0D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES3_DES3_1D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_des3_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES3_DES3_1D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES3_DES3_2D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:,:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_des3_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES3_DES3_2D_ + +!####################################################################### + +! +! +! +! +! +! + subroutine LOOKUP_ES3_DES3_3D_ ( temp, esat, desat, err_msg ) + + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), dimension(:,:,:), intent(out) :: desat !< derivative of saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_local + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + call lookup_es3_des3_k(temp, esat, desat, nbad) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return + endif + + end subroutine LOOKUP_ES3_DES3_3D_ + +!####################################################################### + +! +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_QS_0D_ ( temp, press, qsat, q, hc, dqsdT, esat, & + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: qsat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(in), optional :: q !< vapor relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dqsdT !< d(qsat)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILO_loc=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + + call compute_qs_k (temp, press, EPSILO_loc, ZVIRl, qsat, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_QS_0D_ + +!####################################################################### + +! +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_QS_1D_ ( temp, press, qsat, q, hc, dqsdT, esat, & + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press(:) !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: qsat(:) !< specific humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: q(:) !< vapor relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dqsdT(:) !< d(qsat)/dT + real(kind=FMS_SVP_KIND_),intent(out), optional :: esat(:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILOl=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + +! call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, dqsdT) + call compute_qs_k (temp, press, EPSILOl, ZVIRl, qsat, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_QS_1D_ + + +!####################################################################### + +! +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_QS_2D_ ( temp, press, qsat, q, hc, dqsdT, esat, & + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press(:,:) !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: qsat(:,:) !< specific humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: q(:,:) !< vapor relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dqsdT(:,:) !< d(qsat)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat(:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILOl=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + +! call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, dqsdT) + call compute_qs_k (temp, press, EPSILOl, ZVIRl, qsat, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_QS_2D_ + +!####################################################################### + +! +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_QS_3D_ ( temp, press, qsat, q, hc, dqsdT, esat, & + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press(:,:,:) !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: qsat(:,:,:) !< specific humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: q(:,:,:) !< vapor relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dqsdT(:,:,:) !< d(qsat)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat(:,:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILOl=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + +! call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, dqsdT) + call compute_qs_k (temp, press, EPSILOl, ZVIRl, qsat, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_QS_3D_ + +!####################################################################### +!####################################################################### + +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_MRS_0D_ ( temp, press, mrsat, mr, hc, dmrsdT, esat, & + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: mrsat !< mixing ratio at relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: mr !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dmrsdT !< d(mrsat)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILOl=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_mrs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + + call compute_mrs_k (temp, press, EPSILOl, ZVIRl, mrsat, nbad, mr, & + hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_MRS_0D_ + +!####################################################################### +!####################################################################### + +! +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_MRS_1D_ ( temp, press, mrsat, mr, hc, dmrsdT, esat,& + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press(:) !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: mrsat(:) !< mixing ratio at relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: mr(:) !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dmrsdT(:) !< d(mrsat)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat(:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILOl=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_mrs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + +! call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, & +! nbad, mr, dmrsdT) + call compute_mrs_k (temp, press, EPSILOl, ZVIRl, mrsat, nbad, mr, & + hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_MRS_1D_ + +!####################################################################### + +! +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_MRS_2D_ ( temp, press, mrsat, mr, hc, dmrsdT, esat,& + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press(:,:) !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: mrsat(:,:) !< mixing ratio at relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: mr(:,:) !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dmrsdT(:,:) !< d(mrsat)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat(:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILOl=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_mrs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + +! call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, & +! nbad, mr, dmrsdT) + call compute_mrs_k (temp, press, EPSILOl, ZVIRl, mrsat, nbad, mr, & + hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_MRS_2D_ + +!####################################################################### + +! +! +! +! +! +! +! +! +! +! + subroutine COMPUTE_MRS_3D_ ( temp, press, mrsat, mr, hc, dmrsdT, esat,& + err_msg, es_over_liq, es_over_liq_and_ice ) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) + real(kind=FMS_SVP_KIND_), intent(in) :: press(:,:,:) !< pressure + real(kind=FMS_SVP_KIND_), intent(out) :: mrsat(:,:,:) !< mixing ratio at relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: mr(:,:,:) !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dmrsdT(:,:,:) !< d(mrsat)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat(:,:,:) !< saturation vapor pressure + character(len=*), intent(out), optional :: err_msg + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer :: nbad !< if temperature is out of range + character(len=128) :: err_msg_tmp + !> EPSILO and ZVIR are module level variables that are declared in r8_kind. + !! Thus they need to be converted to FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: EPSILOl=real(EPSILO,FMS_SVP_KIND_) + real(kind=FMS_SVP_KIND_), parameter :: ZVIRl=real(ZVIR,FMS_SVP_KIND_) + + if (.not.module_is_initialized) then + if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return + endif + + if (present(es_over_liq)) then + if (.not. (construct_table_wrt_liq)) then + call error_mesg ('compute_mrs', & + 'requesting es wrt liq, but that table not constructed', & + FATAL) + endif + endif + if (present(es_over_liq_and_ice)) then + if (.not. (construct_table_wrt_liq_and_ice)) then + call error_mesg ('compute_qs', & + 'requesting es wrt liq and ice, but that table not constructed', & + FATAL) + endif + endif + +! call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, & +! nbad, mr, dmrsdT) + call compute_mrs_k (temp, press, EPSILOl, ZVIRl, mrsat, nbad, mr, & + hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) + + if ( nbad == 0 ) then + if(present(err_msg)) err_msg = '' + else + if(show_bad_value_count_by_slice) call temp_check ( temp ) + if(show_all_bad_values) call show_all_bad ( temp ) + write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad + if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return + endif + + end subroutine COMPUTE_MRS_3D_ + + +!####################################################################### + + function CHECK_1D_ ( temp ) result ( nbad ) + real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + integer :: nbad, ind, i + + !> DTINV, TMIN, TEPS are module level variables declared in r8_kind + !! Thus they need to be converted to FMS_SVP_KIND_ + real(FMS_SVP_KIND_) :: dtinvll !< local version of module variable dtinvl + real(FMS_SVP_KIND_) :: tminll !< local version of module variable tminl + real(FMS_SVP_KIND_) :: tepsll !< local version of module variable tepsl + + dtinvll=real(dtinv,FMS_SVP_KIND_) + tminll=real(tmin,FMS_SVP_KIND_) + tepsll=real(teps,FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + ind = int( dtinvll*(temp(i)-tminll + tepsll) ) + if (ind < 0 .or. ind > nlim) nbad = nbad+1 + enddo + + end function CHECK_1D_ + +!------------------------------------------------ + + function CHECK_2D_ ( temp ) result ( nbad ) + real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + integer :: nbad + integer :: j + + nbad = 0 + do j = 1, size(temp,2) + nbad = nbad + check_1d ( temp(:,j) ) + enddo + end function CHECK_2D_ + +!####################################################################### + + subroutine TEMP_CHECK_1D_ ( temp ) + real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + integer :: i, unit + + unit = stdoutunit + write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1)) + + end subroutine TEMP_CHECK_1D_ + +!-------------------------------------------------------------- + + subroutine TEMP_CHECK_2D_ ( temp ) + real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + integer :: i, j, unit + + unit = stdoutunit + write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1)) + write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2)) + + end subroutine TEMP_CHECK_2D_ + +!-------------------------------------------------------------- + + subroutine TEMP_CHECK_3D_ ( temp ) + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) + integer :: i, j, k, unit + + unit = stdoutunit + write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1)) + write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2)) + write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3)) + + end subroutine TEMP_CHECK_3D_ + +!####################################################################### + + subroutine SHOW_ALL_BAD_0D_ ( temp ) + real(kind=FMS_SVP_KIND_) , intent(in) :: temp !< temperature in degrees Kelvin (K) + integer :: ind, unit + !> DTINV, TMIN, TEPS are module level variables declared in r8_kind + !! Thus they need to be converted to FMS_SVP_KIND_ + real(FMS_SVP_KIND_) :: dtinvll !< local version of module variable dtinvl + real(FMS_SVP_KIND_) :: tminll !< local version of module variable tminl + real(FMS_SVP_KIND_) :: tepsll !< local version of module variable tepsl + + dtinvll=real(dtinv,FMS_SVP_KIND_) + tminll=real(tmin,FMS_SVP_KIND_) + tepsll=real(teps,FMS_SVP_KIND_) + + unit = stdoutunit + ind = int( dtinvll*(temp-tminll+tepsll) ) + if (ind < 0 .or. ind > nlim) then + write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe() + endif + + end subroutine SHOW_ALL_BAD_0D_ + +!-------------------------------------------------------------- + + subroutine SHOW_ALL_BAD_1D_ ( temp ) + real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:) !< temperature in degrees Kelvin (K) + integer :: i, ind, unit + !> DTINV, TMIN, TEPS are module level variables declared in r8_kind + !! Thus they need to be converted to FMS_SVP_KIND_ + real(FMS_SVP_KIND_) :: dtinvll !< local version of module variable dtinvl + real(FMS_SVP_KIND_) :: tminll !< local version of module variable tminl + real(FMS_SVP_KIND_) :: tepsll !< local version of module variable tepsl + + dtinvll=real(dtinv,FMS_SVP_KIND_) + tminll=real(tmin,FMS_SVP_KIND_) + tepsll=real(teps,FMS_SVP_KIND_) + + unit = stdoutunit + do i=1,size(temp) + ind = int( dtinvll*(temp(i)-tminll+tepsll) ) + if (ind < 0 .or. ind > nlim) then + write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe() + endif + enddo + + end subroutine SHOW_ALL_BAD_1D_ + +!-------------------------------------------------------------- + + subroutine SHOW_ALL_BAD_2D_ ( temp ) + real(kind=FMS_SVP_KIND_) , intent(in) :: temp(:,:) !< temperature in degrees Kelvin (K) + integer :: i, j, ind, unit + !> DTINV, TMIN, TEPS are module level variables declared in r8_kind + !! Thus they need to be converted to FMS_SVP_KIND_ + real(FMS_SVP_KIND_) :: dtinvll !< local version of module variable dtinvl + real(FMS_SVP_KIND_) :: tminll !< local version of module variable tminl + real(FMS_SVP_KIND_) :: tepsll !< local version of module variable tepsl + + dtinvll=real(dtinv,FMS_SVP_KIND_) + tminll=real(tmin,FMS_SVP_KIND_) + tepsll=real(teps,FMS_SVP_KIND_) + + unit = stdoutunit + do j=1,size(temp,2) + do i=1,size(temp,1) + ind = int( dtinvll*(temp(i,j)-tminll+tepsll) ) + if (ind < 0 .or. ind > nlim) then + write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe() + endif + enddo + enddo + + end subroutine SHOW_ALL_BAD_2D_ + +!-------------------------------------------------------------- + + subroutine SHOW_ALL_BAD_3D_ ( temp ) + real(kind=FMS_SVP_KIND_), intent(in) :: temp(:,:,:) !< temperature in degrees Kelvin (K) + integer :: i, j, k, ind, unit + !> DTINV, TMIN, TEPS are module level variables declared in r8_kind + !! Thus they need to be converted to FMS_SVP_KIND_ + real(FMS_SVP_KIND_) :: dtinvll !< local version of module variable dtinvl + real(FMS_SVP_KIND_) :: tminll !< local version of module variable tminl + real(FMS_SVP_KIND_) :: tepsll !< local version of module variable tepsl + + dtinvll=real(dtinv,FMS_SVP_KIND_) + tminll=real(tmin,FMS_SVP_KIND_) + tepsll=real(teps,FMS_SVP_KIND_) + + unit = stdoutunit + do k=1,size(temp,3) + do j=1,size(temp,2) + do i=1,size(temp,1) + ind = int( dtinvll*(temp(i,j,k)-tminll+tepsll) ) + if (ind < 0 .or. ind > nlim) then + write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),' at i=',i,' j=',j,' k=',k, & + & ' pe=',mpp_pe() + endif + enddo + enddo + enddo + + end subroutine SHOW_ALL_BAD_3D_ + +!-------------------------------------------------------------- + +!> @} diff --git a/sat_vapor_pres/include/sat_vapor_pres_k.inc b/sat_vapor_pres/include/sat_vapor_pres_k.inc new file mode 100644 index 0000000000..00ce7089d0 --- /dev/null +++ b/sat_vapor_pres/include/sat_vapor_pres_k.inc @@ -0,0 +1,2647 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup sat_vapor_pres_k_mod +!> @brief Kernel module to be used by @ref sat_vapor_pres_mod for +!> @{ + +!! table lookups and calculations + +!> This routine has been generalized to return tables for any temperature range and resolution +!! The TABLEs for saturation vapor pressure are computed with r8_kind precision since +!! these TABLES are module level variables that are decared as r8_kind. +!! The subroutines compute_es_k, compute_es_k, compute_es_liq_k, and compute_es_liq_ice_k +!! seem to be mostly used to compute the TABLE values (and thus all variables within them can be declared +!! as r8_kind). However, these compute* subroutines have been modified to accept both r4_kind and r8_kind arguments +!! for general usage and the math can be conducted in either r4_kind and r8_kind. +!! In this initialization routine, r8_kind arguments are passed to these compute* subroutines. +!! This routine does not assume the passed in arguments are in r8_precision. +!! Thus all variables used for the computation of the TABLES (e.g. TABLE, DTABLE*, D2TABLE*) are promoted +!! to r8_kind precision. All local variables used for computation are in r8_kind precision +!! Thus the TABLEs are constructed as accurately as possible and are promoted down to r4_kind when users +!! pass in r4_kind arguments to the LOOKUP* subroutines. + subroutine SAT_VAPOR_PRES_INIT_K_(table_size, tcmin, tcmax, TFREEZE, HLV, RVGAS, ES0, err_msg, & + use_exact_qs_input, do_simple, & + construct_table_wrt_liq, & + construct_table_wrt_liq_and_ice, & + teps, tmin, dtinv) + + integer, intent(in) :: table_size + real(kind=FMS_SVP_KIND_), intent(in) :: tcmin !< TABLE(1) = sat vapor pressure at temperature tcmin (deg C) + real(kind=FMS_SVP_KIND_), intent(in) :: tcmax !< TABLE(table_size) = sat vapor pressure at temperature tcmax (deg C) + real(kind=FMS_SVP_KIND_), intent(in) :: TFREEZE !< Conversion to Kelvin + real(kind=FMS_SVP_KIND_), intent(in) :: HLV !< Latent heat of evaporation [J/kg] + real(kind=FMS_SVP_KIND_), intent(in) :: RVGAS !< Gas constant for water vapor + real(kind=FMS_SVP_KIND_), intent(in) :: ES0 !< Humidity factor [dimensionless] + logical, intent(in) :: use_exact_qs_input + logical, intent(in) :: do_simple + logical, intent(in) :: construct_table_wrt_liq + logical, intent(in) :: construct_table_wrt_liq_and_ice + character(len=*), intent(out) :: err_msg + real(kind=FMS_SVP_KIND_), intent(out), optional :: teps + real(kind=FMS_SVP_KIND_), intent(out), optional :: tmin + real(kind=FMS_SVP_KIND_), intent(out), optional :: dtinv + + +!> increment used to generate derivative table +!! the following variables are used in the computation +!! of the *TABLES* (which is defined in r8_kind in sat_vapor_pres_mod) +!! Thus these variables are declared with r8_kind + real(kind=r8_kind), dimension(3) :: tem(3), es(3) + real(kind=r8_kind) :: hdtinv, tinrc, tfact + integer :: i + + err_msg = '' + + if (module_is_initialized) return + + if(allocated(TABLE) .or. allocated(DTABLE) .or. allocated(D2TABLE)) then + err_msg = 'Attempt to allocate sat vapor pressure tables when already allocated' + return + else + allocate(TABLE(table_size), DTABLE(table_size), D2TABLE(table_size)) + endif + + if (construct_table_wrt_liq) then + if(allocated(TABLE2) .or. allocated(DTABLE2) .or. allocated(D2TABLE2)) then + err_msg = 'Attempt to allocate sat vapor pressure table2s when already allocated' + return + else + allocate(TABLE2(table_size), DTABLE2(table_size), D2TABLE2(table_size)) + endif + endif + + if (construct_table_wrt_liq_and_ice) then + if(allocated(TABLE3) .or. allocated(DTABLE3) .or. allocated(D2TABLE3)) then + err_msg = 'Attempt to allocate sat vapor pressure table2s when already allocated' + return + else + allocate(TABLE3(table_size), DTABLE3(table_size), D2TABLE3(table_size)) + endif + endif + + table_siz = table_size + dtres = (real(tcmax,r8_kind)-real(tcmin,r8_kind))/real(table_size-1,r8_kind) + tminl = real(tcmin,r8_kind)+real(TFREEZE,r8_kind) ! minimum valid temp in table + dtinvl = 1.0_r8_kind/dtres + tepsl = 0.5_r8_kind*dtres + tinrc = 0.1_r8_kind*dtres + if(present(teps )) teps =real(tepsl, FMS_SVP_KIND_) + if(present(tmin )) tmin =real(tminl, FMS_SVP_KIND_) + if(present(dtinv)) dtinv=real(dtinvl, FMS_SVP_KIND_) + +!> To be able to compute tables for any temperature range and resolution, +!! and at the same time exactly reproduce answers from memphis revision, +!! it is necessary to compute ftact differently than it is in memphis. + tfact = 5.0_r8_kind*dtinvl + + hdtinv = 0._r8_kind*dtinvl + +!> compute es tables from tcmin to tcmax +!> estimate es derivative with small +/- difference + + if (do_simple) then + + !> TABLE = 610.78ES0*exp(-HLV/RGAS[1/tem - 1.TFREEZE]) + !> DTABLE = HLV(TABLE/RVGAS)^2 + do i = 1, table_size + tem(1) = tminl + dtres*real(i-1,r8_kind) + TABLE(i) = real(ES0,r8_kind)*610.78_r8_kind* & + exp( -real(HLV,r8_kind)/real(RVGAS,r8_kind) * (1.0_r8_kind/tem(1) - 1._r8_kind/real(TFREEZE,r8_kind)) ) + DTABLE(i) = real(HLV,r8_kind)*TABLE(i)/real(RVGAS,r8_kind)/tem(1)**2._r8_kind + enddo + + else + + do i = 1, table_size + tem(1) = tminl + dtres*real(i-1,r8_kind) + tem(2) = tem(1)-tinrc + tem(3) = tem(1)+tinrc + es = compute_es_k (tem, real(TFREEZE,r8_kind)) + TABLE(i) = es(1) + DTABLE(i) = (es(3)-es(2))*tfact + enddo + + endif !if (do_simple) + +!> compute one-half second derivative using centered differences +!! differencing des values in the table + + do i = 2, table_size-1 + D2TABLE(i) = 0.25_r8_kind*dtinvl*(DTABLE(i+1)-DTABLE(i-1)) + enddo +!> one-sided derivatives at boundaries + + D2TABLE(1) = 0.50_r8_kind*dtinvl*(DTABLE(2)-DTABLE(1)) + + D2TABLE(table_size) = 0.50_r8_kind*dtinvl*(DTABLE(table_size)-DTABLE(table_size-1)) + + if (construct_table_wrt_liq) then +!> compute es tables from tcmin to tcmax +!> estimate es derivative with small +/- difference + + do i = 1, table_size + tem(1) = tminl + dtres*real(i-1,r8_kind) + tem(2) = tem(1)-tinrc + tem(3) = tem(1)+tinrc +!> pass in flag to force all values to be wrt liquid + es = compute_es_liq_k (tem, real(TFREEZE,r8_kind)) + TABLE2(i) = es(1) + DTABLE2(i) = (es(3)-es(2))*tfact + enddo + +!> compute one-half second derivative using centered differences +!! differencing des values in the table + + do i = 2, table_size-1 + D2TABLE2(i) = 0.25_r8_kind*dtinvl*(DTABLE2(i+1)-DTABLE2(i-1)) + enddo +!> one-sided derivatives at boundaries + + D2TABLE2(1) = 0.50_r8_kind*dtinvl*(DTABLE2(2)-DTABLE2(1)) + + D2TABLE2(table_size) = 0.50_r8_kind*dtinvl*(DTABLE2(table_size)-DTABLE2(table_size-1)) + endif + + + if (construct_table_wrt_liq_and_ice) then +!> compute es tables from tcmin to tcmax +!> estimate es derivative with small +/- difference + + do i = 1, table_size + tem(1) = tminl + dtres*real(i-1,r8_kind) + tem(2) = tem(1)-tinrc + tem(3) = tem(1)+tinrc +!> pass in flag to force all values to be wrt liquid + es = compute_es_liq_ice_k (tem, real(TFREEZE,r8_kind)) + TABLE3(i) = es(1) + DTABLE3(i) = (es(3)-es(2))*tfact + enddo + +!> compute one-half second derivative using centered differences +!! differencing des values in the table + + do i = 2, table_size-1 + D2TABLE3(i) = 0.25_r8_kind*dtinvl*(DTABLE3(i+1)-DTABLE3(i-1)) + enddo +!> one-sided derivatives at boundaries + + D2TABLE3(1) = 0.50_r8_kind*dtinvl*(DTABLE3(2)-DTABLE3(1)) + + D2TABLE3(table_size) = 0.50_r8_kind*dtinvl*(DTABLE3(table_size)-DTABLE3(table_size-1)) + endif + + use_exact_qs = use_exact_qs_input + module_is_initialized = .true. + + end subroutine SAT_VAPOR_PRES_INIT_K_ + +!####################################################################### + + function COMPUTE_ES_K_(tem, TFREEZE) result (es) + real(kind=FMS_SVP_KIND_), intent(in) :: tem(:) !< temperature + real(kind=FMS_SVP_KIND_), intent(in) :: TFREEZE !< conversion to Kelvin + real(kind=FMS_SVP_KIND_) :: es(size(tem,1)) !< saturation vapor pressure + + real(kind=FMS_SVP_KIND_) :: x + real(kind=FMS_SVP_KIND_) :: esice + real(kind=FMS_SVP_KIND_) :: esh2o + real(kind=FMS_SVP_KIND_) :: TBASW + real(kind=FMS_SVP_KIND_) :: TBASI + integer :: i + + integer, parameter :: lkind=FMS_SVP_KIND_ !< local kind parameter + + real(kind=FMS_SVP_KIND_), parameter :: ESBASW = 101324.60_lkind + real(kind=FMS_SVP_KIND_), parameter :: ESBASI = 610.71_lkind + + !> one and ten are declared for code readability. For example, one is easier to read + !! then 1.0_lkind where lkind=FMS_SVP_KIND_ throughout the code + real(FMS_SVP_KIND_), parameter :: one=1.0_lkind + real(FMS_SVP_KIND_), parameter :: ten=10.0_lkind + + TBASW = TFREEZE+100.0_lkind !to Kelvin + TBASI = TFREEZE + + do i = 1, size(tem) + +!> compute es over ice + + !> x = -9.09718(TBASI/tem-1) - 3.56654log(TBASI/tem) + 0.876793(1-tem/TBASI) + log(ESBASI) + !! the coded equation below is the commented equation above + if (tem(i) < TBASI) then + x = -9.09718_lkind*(TBASI/tem(i)-one) & + -3.56654_lkind*log10(TBASI/tem(i)) & + +0.876793_lkind*(one-tem(i)/TBASI) + log10(ESBASI) + esice =ten**(x) + else + esice = 0.0_lkind + endif + +!> compute es over water greater than -20 c. +!! values over 100 c may not be valid +!! see smithsonian meteorological tables page 350. + + !> x = -7.90298(TBASW/tem-1) + 5.02808log(TBASW/tem) + !! -1.3816d-07*10^[11.344(1-tem/TBASW)-1] + !! +8.1328d-03*10^[-3.49149(TBASW/tem-1)-1] + log(ESBASW) + !! the coded equation below is the commented equation above + if (tem(i) > -20.0_lkind+TBASI) then + x = -7.90298_lkind*(TBASW/tem(i)-one) & + +5.02808_lkind*log10(TBASW/tem(i)) & + -1.3816e-07_lkind*(ten**((one-tem(i)/TBASW)*11.344_lkind)-one) & + +8.1328e-03_lkind*(ten**((TBASW/tem(i)-one)*(-3.49149_lkind))-one) & + +log10(ESBASW) + esh2o = ten**(x) + else + esh2o = 0.0_lkind + endif + +!> derive blended es over ice and supercooled water between -20c and 0c + + !> es = 0.05*[esice*(TBASI-10)+esh2o*(tem-TBASI+20)] + !! the coded equation below is the commented equation above + if (tem(i) <= -20.0_lkind+TBASI) then + es(i) = esice + else if (tem(i) >= TBASI) then + es(i) = esh2o + else + es(i) = 0.05_lkind*((TBASI-tem(i))*esice + (tem(i)-TBASI+20.0_lkind)*esh2o) + endif + + enddo + + end function COMPUTE_ES_K_ + +!####################################################################### + + function COMPUTE_ES_LIQ_K_(tem, TFREEZE) result (es) + real(kind=FMS_SVP_KIND_), intent(in) :: tem(:) !< temperature + real(kind=FMS_SVP_KIND_), intent(in) :: TFREEZE !< conversion to Kelvin + real(kind=FMS_SVP_KIND_) :: es(size(tem,1)) !< saturation vapor pressure + + real(kind=FMS_SVP_KIND_) :: x + real(kind=FMS_SVP_KIND_) :: esh2o + real(kind=FMS_SVP_KIND_) :: TBASW + integer :: i + + !> local kind variable + !! one and ten are declared for code readability. For example, one is easier to read + !! then 1.0_lkind where lkind=FMS_SVP_KIND_ throughout the code + integer, parameter :: lkind=FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: one=1.0_lkind + real(kind=FMS_SVP_KIND_), parameter :: ten=10.0_lkind + real(kind=FMS_SVP_KIND_), parameter :: ESBASW = 101324.60_lkind + + TBASW = TFREEZE+100.0_lkind + + do i = 1, size(tem) + +!> compute es over water for all temps. +!! values over 100 c may not be valid +!! see smithsonian meteorological tables page 350. + + !> x = -7.90298(TBASW/tem-1) + 5.02808log(TBASW/tem) + !! -1.3816d-07*10^[11.344(1-tem/TBASW)-1] + !! +8.1328d-03*10^[-3.49149(TBASW/tem-1)-1] + log(ESBASW) + !! the coded equation below is the commented equation above + x = -7.90298_lkind*(TBASW/tem(i)-one) & + +5.02808_lkind*log10(TBASW/tem(i)) & + -1.3816e-07_lkind*(ten**((one-tem(i)/TBASW)*11.344_lkind)-one) & + +8.1328e-03_lkind*(ten**((TBASW/tem(i)-one)*(-3.49149_lkind))-one)& + +log10(ESBASW) + esh2o = ten**(x) + + es(i) = esh2o + + enddo + + end function COMPUTE_ES_LIQ_K_ + +!####################################################################### + + function COMPUTE_ES_LIQ_ICE_K_(tem, TFREEZE) result (es) + real(kind=FMS_SVP_KIND_), intent(in) :: tem(:) !< temperature + real(kind=FMS_SVP_KIND_), intent(in) :: TFREEZE !< conversion to Kelvin + real(kind=FMS_SVP_KIND_) :: es(size(tem,1)) !< saturation vapor pressure + + real(kind=FMS_SVP_KIND_) :: x + real(kind=FMS_SVP_KIND_) :: TBASW + real(kind=FMS_SVP_KIND_) :: TBASI + integer :: i + + integer, parameter :: lkind=FMS_SVP_KIND_ + real(kind=FMS_SVP_KIND_), parameter :: ESBASW = 101324.60_lkind + real(kind=FMS_SVP_KIND_), parameter :: ESBASI = 610.71_lkind + !> one and ten are declared for code readability. For example, one is easier to read + !! then 1.0_lkind where lkind=FMS_SVP_KIND_ throughout the code + real(kind=FMS_SVP_KIND_), parameter :: one=1.0_lkind + real(kind=FMS_SVP_KIND_), parameter :: ten=10.0_lkind + + TBASW = TFREEZE+100.0_lkind + TBASI = TFREEZE + + do i = 1, size(tem) + + if (tem(i) < TBASI) then + +!> compute es over ice + !> x= -9.09718(TBASI/tem-1) -3.56654log(TBASI/tem) +0.87679(1-tem/TBASI)+log(EBASI) + !! the coded equation below is the commented equation above + x = -9.09718_lkind*(TBASI/tem(i)-one) & + -3.56654_lkind*log10(TBASI/tem(i)) & + +0.876793_lkind*(one-tem(i)/TBASI) + log10(ESBASI) + es(i) =ten**(x) + else + +!> compute es over water +!! values over 100 c may not be valid +!! see smithsonian meteorological tables page 350. + !> x = -7.90298(TBASW/tem-1) + 5.02808log(TBASW/tem) + !! -1.3816d-07*10^[11.344(1-tem/TBASW)-1] + !! +8.1328d-03*10^[-3.49149(TBASW/tem-1)-1] + log(ESBASW) + !! the coded equation below is the commented equation above + x = -7.90298_lkind*(TBASW/tem(i)-one) & + +5.02808_lkind*log10(TBASW/tem(i)) & + -1.3816e-07_lkind*(ten**((one-tem(i)/TBASW)*11.344_lkind)-one) & + +8.1328e-03_lkind*(ten**((TBASW/tem(i)-one)*(-3.49149_lkind))-one) & + +log10(ESBASW) + es(i) = ten**(x) + endif + enddo + + end function COMPUTE_ES_LIQ_ICE_K_ + +!####################################################################### + + subroutine COMPUTE_QS_K_3D_ (temp, press, eps, zvir, qs, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: qs !< specific humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:), optional :: q !< vapor relative humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:), optional :: dqsdT !< d(qs)/dT + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:), optional :: esat !< saturation vapor pressure + logical,intent(in), optional :: es_over_liq !< use es table wrt liquid only + logical,intent(in), optional :: es_over_liq_and_ice + + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_, either r4_kind or r8_kind + + real(kind=FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: esloc + real(kind=FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: desat + real(kind=FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: denom + integer :: i, j, k + real(kind=FMS_SVP_KIND_) :: hc_loc + + if (present(hc)) then + hc_loc = hc + else + hc_loc = 1.0_lkind + endif + if (present(es_over_liq)) then + if (present (dqsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es2_k (temp, esloc, nbad) + endif + else if (present(es_over_liq_and_ice)) then + if (present (dqsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dqsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc + if (present (esat)) then + esat = esloc + endif + if (nbad == 0) then + if (present (q) .and. use_exact_qs) then + qs = (1.0_lkind + zvir*q)*eps*esloc/press + if (present (dqsdT)) then + dqsdT = (1.0_lkind + zvir*q)*eps*desat/press + endif + else ! (present(q)) + denom = press - (1.0_lkind - eps)*esloc + do k=1,size(qs,3) + do j=1,size(qs,2) + do i=1,size(qs,1) + if (denom(i,j,k) > 0.0_lkind) then + qs(i,j,k) = eps*esloc(i,j,k)/denom(i,j,k) + else + qs(i,j,k) = eps + endif + end do + end do + end do + if (present (dqsdT)) then + dqsdT = eps*press*desat/denom**2 + endif + endif ! (present(q)) + else ! (nbad = 0) + qs = -999.0_lkind + if (present (dqsdT)) then + dqsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif ! (nbad = 0) + + + end subroutine COMPUTE_QS_K_3D_ + +!####################################################################### + + subroutine COMPUTE_QS_K_2D_ (temp, press, eps, zvir, qs, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: qs !< specific humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:), optional :: q !< vapor specific humidty + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:), optional :: dqsdT !< d(qs)/dT + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:), optional :: esat ! 0.0_lkind) then + qs(i,j) = eps*esloc(i,j)/denom(i,j) + else + qs(i,j) = eps + endif + end do + end do + if (present (dqsdT)) then + dqsdT = eps*press*desat/denom**2 + endif + endif ! (present(q)) + else ! (nbad = 0) + qs = -999.0_lkind + if (present (dqsdT)) then + dqsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif ! (nbad = 0) + + + end subroutine COMPUTE_QS_K_2D_ + +!####################################################################### + + subroutine COMPUTE_QS_K_1D_ (temp, press, eps, zvir, qs, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: qs !< specific humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), dimension(:), optional :: q !< vapor specific humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), dimension(:), optional :: dqsdT !< d(qs)/dt + real(kind=FMS_SVP_KIND_), intent(out), dimension(:), optional :: esat !< saturation vapor pressure + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer, parameter :: lkind=FMS_SVP_KIND_ + + real(kind=FMS_SVP_KIND_), dimension(size(temp,1)) :: esloc + real(kind=FMS_SVP_KIND_), dimension(size(temp,1)) :: desat + real(kind=FMS_SVP_KIND_), dimension(size(temp,1)) :: denom + integer :: i + real(kind=FMS_SVP_KIND_) :: hc_loc + + if (present(hc)) then + hc_loc = hc + else + hc_loc = 1.0_lkind + endif + + if (present(es_over_liq)) then + if (present (dqsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es2_k (temp, esloc, nbad) + endif + else if (present(es_over_liq_and_ice)) then + if (present (dqsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dqsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc + if (present (esat)) then + esat = esloc + endif + if (nbad == 0) then + if (present (q) .and. use_exact_qs) then + qs = (1.0_lkind + zvir*q)*eps*esloc/press + if (present (dqsdT)) then + dqsdT = (1.0_lkind + zvir*q)*eps*desat/press + endif + else ! (present(q)) + denom = press - (1.0_lkind - eps)*esloc + do i=1,size(qs,1) + if (denom(i) > 0.0_lkind) then + qs(i) = eps*esloc(i)/denom(i) + else + qs(i) = eps + endif + end do + if (present (dqsdT)) then + dqsdT = eps*press*desat/denom**2 + endif + endif ! (present(q)) + else ! (nbad = 0) + qs = -999.0_lkind + if (present (dqsdT)) then + dqsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif ! (nbad = 0) + + + end subroutine COMPUTE_QS_K_1D_ + +!####################################################################### + + subroutine COMPUTE_QS_K_0D_ (temp, press, eps, zvir, qs, nbad, q, hc, & + dqsdT, esat, es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out) :: qs !< specific humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), optional :: q !< vapor specific humidity + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dqsdT !< d(qs)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat !< saturation vapor pressure + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + real(kind=FMS_SVP_KIND_) :: esloc + real(kind=FMS_SVP_KIND_) :: desat + real(kind=FMS_SVP_KIND_) :: denom + real(kind=FMS_SVP_KIND_) :: hc_loc + + if (present(hc)) then + hc_loc = hc + else + hc_loc = 1.0_lkind + endif + + if (present(es_over_liq)) then + if (present (dqsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es2_k (temp, esloc, nbad) + endif + else if (present(es_over_liq_and_ice)) then + if (present (dqsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dqsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc + if (present (esat)) then + esat = esloc + endif + if (nbad == 0) then + if (present (q) .and. use_exact_qs) then + qs = (1.0_lkind + zvir*q)*eps*esloc/press + if (present (dqsdT)) then + dqsdT = (1.0_lkind + zvir*q)*eps*desat/press + endif + else ! (present(q)) + denom = press - (1.0_lkind - eps)*esloc + if (denom > 0.0_lkind) then + qs = eps*esloc/denom + else + qs = eps + endif + if (present (dqsdT)) then + dqsdT = eps*press*desat/denom**2 + endif + endif ! (present(q)) + else ! (nbad = 0) + qs = -999.0_lkind + if (present (dqsdT)) then + dqsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif ! (nbad = 0) + + + end subroutine COMPUTE_QS_K_0D_ + +!####################################################################### + + subroutine COMPUTE_MRS_K_3D_ (temp, press, eps, zvir, mrs, nbad, & + mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: mrs !< mixing ratio at relative humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:), optional :: mr !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:), optional :: dmrsdT !< d(mrs)/dT + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:), optional :: esat !< saturation vapor pressure + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + real(FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: esloc + real(FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: desat + real(FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: denom + + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + integer :: i, j, k + real(FMS_SVP_KIND_) :: hc_loc + + if (present(hc)) then + hc_loc = hc + else + hc_loc = 1.0_lkind + endif + + if (present (es_over_liq)) then + if (present (dmrsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es2_k (temp, esloc, nbad) + endif + else if (present(es_over_liq_and_ice)) then + if (present (dmrsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dmrsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc + if (present (esat)) then + esat = esloc + endif + if (nbad == 0) then + if (present (mr) .and. use_exact_qs) then + mrs = (eps + mr)*esloc/press + if (present (dmrsdT)) then + dmrsdT = (eps + mr)*desat/press + endif + else ! (present (mr)) + denom = press - esloc + do k=1,size(mrs,3) + do j=1,size(mrs,2) + do i=1,size(mrs,1) + if (denom(i,j,k) > 0.0_lkind) then + mrs(i,j,k) = eps*esloc(i,j,k)/denom(i,j,k) + else + mrs(i,j,k) = eps + endif + end do + end do + end do + if (present (dmrsdT)) then + dmrsdT = eps*press*desat/denom**2 + endif + endif !(present (mr)) + else + mrs = -999.0_lkind + if (present (dmrsdT)) then + dmrsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif + + end subroutine COMPUTE_MRS_K_3D_ + +!####################################################################### + + subroutine COMPUTE_MRS_K_2D_ (temp, press, eps, zvir, mrs, nbad, & + mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: mrs !< mixing ratio at relative humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:), optional :: mr !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:), optional :: dmrsdT !< d(mrs)/dT + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:), optional :: esat !< saturation vapor pressure + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + real(kind=FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2)) :: esloc + real(kind=FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2)) :: desat + real(kind=FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2)) :: denom + integer :: i, j + real(kind=FMS_SVP_KIND_) :: hc_loc + + if (present(hc)) then + hc_loc = hc + else + hc_loc = 1.0_lkind + endif + + if (present (es_over_liq)) then + if (present (dmrsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es2_k (temp, esloc, nbad) + endif + else if (present(es_over_liq_and_ice)) then + if (present (dmrsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dmrsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc + if (present (esat)) then + esat = esloc + endif + if (nbad == 0) then + if (present (mr) .and. use_exact_qs) then + mrs = (eps + mr)*esloc/press + if (present (dmrsdT)) then + dmrsdT = (eps + mr)*desat/press + endif + else ! (present (mr)) + denom = press - esloc + do j=1,size(mrs,2) + do i=1,size(mrs,1) + if (denom(i,j) > 0.0_lkind) then + mrs(i,j) = eps*esloc(i,j)/denom(i,j) + else + mrs(i,j) = eps + endif + end do + end do + if (present (dmrsdT)) then + dmrsdT = eps*press*desat/denom**2 + endif + endif !(present (mr)) + else + mrs = -999.0_lkind + if (present (dmrsdT)) then + dmrsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif + + + end subroutine COMPUTE_MRS_K_2D_ + +!####################################################################### + + subroutine COMPUTE_MRS_K_1D_ (temp, press, eps, zvir, mrs, nbad, & + mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: mrs !< mixing ratio at relative humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), dimension(:), optional :: mr !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), dimension(:), optional :: dmrsdT !< d(mrs)/dT + real(kind=FMS_SVP_KIND_), intent(out), dimension(:), optional :: esat !< saturation vapor pressure + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + real(kind=FMS_SVP_KIND_), dimension(size(temp,1)) :: esloc + real(kind=FMS_SVP_KIND_), dimension(size(temp,1)) :: desat + real(kind=FMS_SVP_KIND_), dimension(size(temp,1)) :: denom + integer :: i + real(kind=FMS_SVP_KIND_) :: hc_loc + + if (present(hc)) then + hc_loc = hc + else + hc_loc = 1.0_lkind + endif + + if (present (es_over_liq)) then + if (present (dmrsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es2_k (temp, esloc, nbad) + endif + else if (present(es_over_liq_and_ice)) then + if (present (dmrsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dmrsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc + if (present (esat)) then + esat = esloc + endif + if (nbad == 0) then + if (present (mr) .and. use_exact_qs) then + mrs = (eps + mr)*esloc/press + if (present (dmrsdT)) then + dmrsdT = (eps + mr)*desat/press + endif + else ! (present (mr)) + denom = press - esloc + do i=1,size(mrs,1) + if (denom(i) > 0.0_lkind) then + mrs(i) = eps*esloc(i)/denom(i) + else + mrs(i) = eps + endif + end do + if (present (dmrsdT)) then + dmrsdT = eps*press*desat/denom**2 + endif + endif !(present (mr)) + else + mrs = -999.0_lkind + if (present (dmrsdT)) then + dmrsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif + + + end subroutine COMPUTE_MRS_K_1D_ + +!####################################################################### + + subroutine COMPUTE_MRS_K_0D_ (temp, press, eps, zvir, mrs, nbad, & + mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) + + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(in) :: press !< pressure + real(kind=FMS_SVP_KIND_), intent(in) :: eps !< EPSILO + real(kind=FMS_SVP_KIND_), intent(in) :: zvir !< ZVIR + real(kind=FMS_SVP_KIND_), intent(out) :: mrs !< mixing ratio at relative humidity + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_), intent(in), optional :: mr !< vapor mixing ratio + real(kind=FMS_SVP_KIND_), intent(in), optional :: hc !< relative humidity + real(kind=FMS_SVP_KIND_), intent(out), optional :: dmrsdT !< d(mrs)/dT + real(kind=FMS_SVP_KIND_), intent(out), optional :: esat !< saturation vapor pressure + logical,intent(in), optional :: es_over_liq + logical,intent(in), optional :: es_over_liq_and_ice + + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + real(kind=FMS_SVP_KIND_) :: esloc + real(kind=FMS_SVP_KIND_) :: desat + real(kind=FMS_SVP_KIND_) :: denom + real(kind=FMS_SVP_KIND_) :: hc_loc + + if (present(hc)) then + hc_loc = hc + else + hc_loc = 1.0_lkind + endif + + if (present (es_over_liq)) then + if (present (dmrsdT)) then + call lookup_es2_des2_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es2_k (temp, esloc, nbad) + endif + else if (present(es_over_liq_and_ice)) then + if (present (dmrsdT)) then + call lookup_es3_des3_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es3_k (temp, esloc, nbad) + endif + else + if (present (dmrsdT)) then + call lookup_es_des_k (temp, esloc, desat, nbad) + desat = desat*hc_loc + else + call lookup_es_k (temp, esloc, nbad) + endif + endif + esloc = esloc*hc_loc + if (present (esat)) then + esat = esloc + endif + if (nbad == 0) then + if (present (mr) .and. use_exact_qs) then + mrs = (eps + mr)*esloc/press + if (present (dmrsdT)) then + dmrsdT = (eps + mr)*desat/press + endif + else ! (present (mr)) + denom = press - esloc + if (denom > 0.0_lkind) then + mrs = eps*esloc/denom + else + mrs = eps + endif + if (present (dmrsdT)) then + dmrsdT = eps*press*desat/denom**2 + endif + endif !(present (mr)) + else + mrs = -999.0_lkind + if (present (dmrsdT)) then + dmrsdT = -999.0_lkind + endif + if (present (esat)) then + esat = -999.0_lkind + endif + endif + + + end subroutine COMPUTE_MRS_K_0D_ + + +!####################################################################### + + subroutine LOOKUP_ES_DES_K_3D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: esat ! dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-real(dtresl,FMS_SVP_KIND_)*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j,k) = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j,k) = real(DTABLE(ind+1), FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_ES_DES_K_3D_ + +!####################################################################### + + subroutine LOOKUP_ES_DES_K_2D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: desat !< derivative of the saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j) = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j) = real(DTABLE(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + + end subroutine LOOKUP_ES_DES_K_2D_ + +!####################################################################### + + subroutine LOOKUP_ES_DES_K_1D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: desat !< derivative of the saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i) = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i) = real(DTABLE(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + enddo + + end subroutine LOOKUP_ES_DES_K_1D_ + +!####################################################################### + + subroutine LOOKUP_ES_DES_K_0D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of the saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat = real(DTABLE(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + + end subroutine LOOKUP_ES_DES_K_0D_ + +!####################################################################### + + subroutine LOOKUP_ES_K_3D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: esat !< saturavation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp - TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j,k) = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_ES_K_3D_ + +!####################################################################### + + subroutine LOOKUP_DES_K_3D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j,k) = real(DTABLE(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_DES_K_3D_ + +!####################################################################### + subroutine LOOKUP_DES_K_2D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j) = real(DTABLE(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + + end subroutine LOOKUP_DES_K_2D_ +!####################################################################### + subroutine LOOKUP_ES_K_2D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j) = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*(real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + endif + enddo + enddo + + end subroutine LOOKUP_ES_K_2D_ +!####################################################################### + subroutine LOOKUP_DES_K_1D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i) = real(DTABLE(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + enddo + + end subroutine LOOKUP_DES_K_1D_ +!####################################################################### + subroutine LOOKUP_ES_K_1D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i) = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*(real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + endif + enddo + + end subroutine LOOKUP_ES_K_1D_ +!####################################################################### + subroutine LOOKUP_DES_K_0D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp - TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat = real(DTABLE(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE(ind+1),FMS_SVP_KIND_) + endif + + end subroutine LOOKUP_DES_K_0D_ +!####################################################################### + subroutine LOOKUP_ES_K_0D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp - TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat = real(TABLE(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE(ind+1),FMS_SVP_KIND_) ) + endif + + end subroutine LOOKUP_ES_K_0D_ +!####################################################################### + + subroutine LOOKUP_ES2_DES2_K_3D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j,k) = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j,k) = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_ES2_DES2_K_3D_ + +!####################################################################### + + subroutine LOOKUP_ES2_DES2_K_2D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j) = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j) = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + + end subroutine LOOKUP_ES2_DES2_K_2D_ + +!####################################################################### + + subroutine LOOKUP_ES2_DES2_K_1D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp - TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i) = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + desat(i) = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + enddo + + end subroutine LOOKUP_ES2_DES2_K_1D_ + +!####################################################################### + + subroutine LOOKUP_ES2_DES2_K_0D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + + end subroutine LOOKUP_ES2_DES2_K_0D_ + +!####################################################################### + + subroutine LOOKUP_ES2_K_3D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j,k) = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_ES2_K_3D_ + +!####################################################################### + + subroutine LOOKUP_DES2_K_3D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j,k) = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_DES2_K_3D_ + +!####################################################################### + subroutine LOOKUP_DES2_K_2D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j) = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + + end subroutine LOOKUP_DES2_K_2D_ +!####################################################################### + subroutine LOOKUP_ES2_K_2D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,kind=FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j) = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + endif + enddo + enddo + + end subroutine LOOKUP_ES2_K_2D_ +!####################################################################### + subroutine LOOKUP_DES2_K_1D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i) = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + enddo + + end subroutine LOOKUP_DES2_K_1D_ +!####################################################################### + subroutine LOOKUP_ES2_K_1D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i) = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + endif + enddo + + end subroutine LOOKUP_ES2_K_1D_ +!####################################################################### + subroutine LOOKUP_DES2_K_0D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat = real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) + endif + + end subroutine LOOKUP_DES2_K_0D_ +!####################################################################### + subroutine LOOKUP_ES2_K_0D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat = real(TABLE2(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE2(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE2(ind+1),FMS_SVP_KIND_) ) + endif + + end subroutine LOOKUP_ES2_K_0D_ +!####################################################################### + +!####################################################################### + + subroutine LOOKUP_ES3_DES3_K_3D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: desat !< derivative of esat + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j,k) = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j,k) = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_ES3_DES3_K_3D_ + +!####################################################################### + + subroutine LOOKUP_ES3_DES3_K_2D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: desat !< derivative of desat + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j) = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j) = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + + end subroutine LOOKUP_ES3_DES3_K_2D_ + +!####################################################################### + + subroutine LOOKUP_ES3_DES3_K_1D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: desat !< derivative of esat + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i) = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i) = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + enddo + + end subroutine LOOKUP_ES3_DES3_K_1D_ + +!####################################################################### + + subroutine LOOKUP_ES3_DES3_K_0D_ (temp, esat, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of esat + integer, intent(out) :: nbad !< if temperature is out of range + + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + + end subroutine LOOKUP_ES3_DES3_K_0D_ + +!####################################################################### + + subroutine LOOKUP_ES3_K_3D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j,k) = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_ES3_K_3D_ + +!####################################################################### + + subroutine LOOKUP_DES3_K_3D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:,:) :: desat!< derivatove of saturation vap pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j, k + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do k = 1, size(temp,3) + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j,k)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j,k) = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + enddo + + end subroutine LOOKUP_DES3_K_3D_ + +!####################################################################### + subroutine LOOKUP_DES3_K_2D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i,j) = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + enddo + enddo + + end subroutine LOOKUP_DES3_K_2D_ +!####################################################################### + subroutine LOOKUP_ES3_K_2D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:,:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i, j + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do j = 1, size(temp,2) + do i = 1, size(temp,1) + tmp = temp(i,j)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i,j) = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + endif + enddo + enddo + + end subroutine LOOKUP_ES3_K_2D_ +!####################################################################### + subroutine LOOKUP_DES3_K_1D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat(i) = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + enddo + + end subroutine LOOKUP_DES3_K_1D_ +!####################################################################### + subroutine LOOKUP_ES3_K_1D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in), dimension(:) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out), dimension(:) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind, i + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + do i = 1, size(temp,1) + tmp = temp(i)-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat(i) = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + endif + enddo + + end subroutine LOOKUP_ES3_K_1D_ +!####################################################################### + subroutine LOOKUP_DES3_K_0D_(temp, desat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: desat !< derivative of sat vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + integer, parameter :: lkind=FMS_SVP_KIND_ !< local FMS_SVP_KIND_ + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> desat = DTABLE + 2del*D2TABLE + !! the coded equation below is the commented equation above + desat = real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + 2.0_lkind*del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) + endif + + end subroutine LOOKUP_DES3_K_0D_ +!####################################################################### + subroutine LOOKUP_ES3_K_0D_(temp, esat, nbad) + real(kind=FMS_SVP_KIND_), intent(in) :: temp !< temperature + real(kind=FMS_SVP_KIND_), intent(out) :: esat !< saturation vapor pressure + integer, intent(out) :: nbad !< if temperature is out of range + real(kind=FMS_SVP_KIND_) :: tmp !< temp-TMINLL + real(kind=FMS_SVP_KIND_) :: del !< delta T + integer :: ind + !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision + !! for precision consistency and for code readability, the *ll variables are declared + !! and used + real(kind=FMS_SVP_KIND_) :: dtresl + real(kind=FMS_SVP_KIND_) :: tepsll + real(kind=FMS_SVP_KIND_) :: tminll + real(kind=FMS_SVP_KIND_) :: dtinvll + + dtresl=real(dtres, FMS_SVP_KIND_) + tminll=real(tminl, FMS_SVP_KIND_) + tepsll=real(tepsl, FMS_SVP_KIND_) + dtinvll=real(dtinvl, FMS_SVP_KIND_) + + nbad = 0 + tmp = temp-tminll + ind = int(dtinvll*(tmp+tepsll)) + if (ind < 0 .or. ind >= table_siz) then + nbad = nbad+1 + else + del = tmp-dtresl*real(ind,FMS_SVP_KIND_) + !> esat = TABLE + del*(TABLE + del*D2TABLE) + !! the coded equation below is the commented equation above + esat = real(TABLE3(ind+1),FMS_SVP_KIND_) & + + del*( real(DTABLE3(ind+1),FMS_SVP_KIND_) & + + del*real(D2TABLE3(ind+1),FMS_SVP_KIND_) ) + endif + + end subroutine LOOKUP_ES3_K_0D_ +!####################################################################### +!> @} +! close documentation grouping diff --git a/sat_vapor_pres/include/sat_vapor_pres_k_r4.fh b/sat_vapor_pres/include/sat_vapor_pres_k_r4.fh new file mode 100644 index 0000000000..e58285fc20 --- /dev/null +++ b/sat_vapor_pres/include/sat_vapor_pres_k_r4.fh @@ -0,0 +1,174 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup sat_vapor_pres_k_mod +!> @{ + +#undef FMS_SVP_KIND_ +#define FMS_SVP_KIND_ r4_kind + +#undef SAT_VAPOR_PRES_INIT_K_ +#define SAT_VAPOR_PRES_INIT_K_ sat_vapor_pres_init_k_r4 + +#undef COMPUTE_ES_K_ +#define COMPUTE_ES_K_ compute_es_k_r4 + +#undef COMPUTE_ES_LIQ_K_ +#define COMPUTE_ES_LIQ_K_ compute_es_liq_k_r4 + +#undef COMPUTE_ES_LIQ_ICE_K_ +#define COMPUTE_ES_LIQ_ICE_K_ compute_es_liq_ice_k_r4 + +#undef COMPUTE_QS_K_3D_ +#define COMPUTE_QS_K_3D_ compute_qs_k_3d_r4 + +#undef COMPUTE_QS_K_2D_ +#define COMPUTE_QS_K_2D_ compute_qs_k_2d_r4 + +#undef COMPUTE_QS_K_1D_ +#define COMPUTE_QS_K_1D_ compute_qs_k_1d_r4 + +#undef COMPUTE_QS_K_0D_ +#define COMPUTE_QS_K_0D_ compute_qs_k_0d_r4 + +#undef COMPUTE_MRS_K_3D_ +#define COMPUTE_MRS_K_3D_ compute_mrs_k_3d_r4 + +#undef COMPUTE_MRS_K_2D_ +#define COMPUTE_MRS_K_2D_ compute_mrs_k_2d_r4 + +#undef COMPUTE_MRS_K_1D_ +#define COMPUTE_MRS_K_1D_ compute_mrs_k_1d_r4 + +#undef COMPUTE_MRS_K_0D_ +#define COMPUTE_MRS_K_0D_ compute_mrs_k_0d_r4 + +#undef LOOKUP_ES_DES_K_3D_ +#define LOOKUP_ES_DES_K_3D_ lookup_es_des_k_3d_r4 + +#undef LOOKUP_ES_DES_K_2D_ +#define LOOKUP_ES_DES_K_2D_ lookup_es_des_k_2d_r4 + +#undef LOOKUP_ES_DES_K_1D_ +#define LOOKUP_ES_DES_K_1D_ lookup_es_des_k_1d_r4 + +#undef LOOKUP_ES_DES_K_0D_ +#define LOOKUP_ES_DES_K_0D_ lookup_es_des_k_0d_r4 + +#undef LOOKUP_ES_K_3D_ +#define LOOKUP_ES_K_3D_ lookup_es_k_3d_r4 + +#undef LOOKUP_DES_K_3D_ +#define LOOKUP_DES_K_3D_ lookup_des_k_3d_r4 + +#undef LOOKUP_DES_K_2D_ +#define LOOKUP_DES_K_2D_ lookup_des_k_2d_r4 + +#undef LOOKUP_ES_K_2D_ +#define LOOKUP_ES_K_2D_ lookup_es_k_2d_r4 + +#undef LOOKUP_DES_K_1D_ +#define LOOKUP_DES_K_1D_ lookup_des_k_1d_r4 + +#undef LOOKUP_ES_K_1D_ +#define LOOKUP_ES_K_1D_ lookup_es_k_1d_r4 + +#undef LOOKUP_DES_K_1D_ +#define LOOKUP_DES_K_1D_ lookup_des_k_1d_r4 + +#undef LOOKUP_ES_K_0D_ +#define LOOKUP_ES_K_0D_ lookup_es_k_0d_r4 + +#undef LOOKUP_DES_K_0D_ +#define LOOKUP_DES_K_0D_ lookup_des_k_0d_r4 + +#undef LOOKUP_ES2_DES2_K_3D_ +#define LOOKUP_ES2_DES2_K_3D_ lookup_es2_des2_k_3d_r4 + +#undef LOOKUP_ES2_DES2_K_2D_ +#define LOOKUP_ES2_DES2_K_2D_ lookup_es2_des2_k_2d_r4 + +#undef LOOKUP_ES2_DES2_K_1D_ +#define LOOKUP_ES2_DES2_K_1D_ lookup_es2_des2_k_1d_r4 + +#undef LOOKUP_ES2_DES2_K_0D_ +#define LOOKUP_ES2_DES2_K_0D_ lookup_es2_des2_k_0d_r4 + +#undef LOOKUP_ES2_K_3D_ +#define LOOKUP_ES2_K_3D_ lookup_es2_k_3d_r4 + +#undef LOOKUP_DES2_K_3D_ +#define LOOKUP_DES2_K_3D_ lookup_des2_k_3d_r4 + +#undef LOOKUP_DES2_K_2D_ +#define LOOKUP_DES2_K_2D_ lookup_des2_k_2d_r4 + +#undef LOOKUP_ES2_K_2D_ +#define LOOKUP_ES2_K_2D_ lookup_es2_k_2d_r4 + +#undef LOOKUP_DES2_K_1D_ +#define LOOKUP_DES2_K_1D_ lookup_des2_k_1d_r4 + +#undef LOOKUP_ES2_K_1D_ +#define LOOKUP_ES2_K_1D_ lookup_es2_k_1d_r4 + +#undef LOOKUP_DES2_K_0D_ +#define LOOKUP_DES2_K_0D_ lookup_des2_k_0d_r4 + +#undef LOOKUP_ES2_K_0D_ +#define LOOKUP_ES2_K_0D_ lookup_es2_k_0d_r4 + +#undef LOOKUP_ES3_DES3_K_3D_ +#define LOOKUP_ES3_DES3_K_3D_ lookup_es3_des3_k_3d_r4 + +#undef LOOKUP_ES3_DES3_K_2D_ +#define LOOKUP_ES3_DES3_K_2D_ lookup_es3_des3_k_2d_r4 + +#undef LOOKUP_ES3_DES3_K_1D_ +#define LOOKUP_ES3_DES3_K_1D_ lookup_es3_des3_k_1d_r4 + +#undef LOOKUP_ES3_DES3_K_0D_ +#define LOOKUP_ES3_DES3_K_0D_ lookup_es3_des3_k_0d_r4 + +#undef LOOKUP_ES3_K_3D_ +#define LOOKUP_ES3_K_3D_ lookup_es3_k_3d_r4 + +#undef LOOKUP_DES3_K_3D_ +#define LOOKUP_DES3_K_3D_ lookup_des3_k_3d_r4 + +#undef LOOKUP_DES3_K_2D_ +#define LOOKUP_DES3_K_2D_ lookup_des3_k_2d_r4 + +#undef LOOKUP_ES3_K_2D_ +#define LOOKUP_ES3_K_2D_ lookup_es3_k_2d_r4 + +#undef LOOKUP_DES3_K_1D_ +#define LOOKUP_DES3_K_1D_ lookup_des3_k_1d_r4 + +#undef LOOKUP_ES3_K_1D_ +#define LOOKUP_ES3_K_1D_ lookup_es3_k_1d_r4 + +#undef LOOKUP_DES3_K_0D_ +#define LOOKUP_DES3_K_0D_ lookup_des3_k_0d_r4 + +#undef LOOKUP_ES3_K_0D_ +#define LOOKUP_ES3_K_0D_ lookup_es3_k_0d_r4 + +#include "sat_vapor_pres_k.inc" + +!> @} diff --git a/sat_vapor_pres/include/sat_vapor_pres_k_r8.fh b/sat_vapor_pres/include/sat_vapor_pres_k_r8.fh new file mode 100644 index 0000000000..247dd33d1f --- /dev/null +++ b/sat_vapor_pres/include/sat_vapor_pres_k_r8.fh @@ -0,0 +1,174 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup sat_vapor_pres_k_mod +!> @{ + +#undef FMS_SVP_KIND_ +#define FMS_SVP_KIND_ r8_kind + +#undef SAT_VAPOR_PRES_INIT_K_ +#define SAT_VAPOR_PRES_INIT_K_ sat_vapor_pres_init_k_r8 + +#undef COMPUTE_ES_K_ +#define COMPUTE_ES_K_ compute_es_k_r8 + +#undef COMPUTE_ES_LIQ_K_ +#define COMPUTE_ES_LIQ_K_ compute_es_liq_k_r8 + +#undef COMPUTE_ES_LIQ_ICE_K_ +#define COMPUTE_ES_LIQ_ICE_K_ compute_es_liq_ice_k_r8 + +#undef COMPUTE_QS_K_3D_ +#define COMPUTE_QS_K_3D_ compute_qs_k_3d_r8 + +#undef COMPUTE_QS_K_2D_ +#define COMPUTE_QS_K_2D_ compute_qs_k_2d_r8 + +#undef COMPUTE_QS_K_1D_ +#define COMPUTE_QS_K_1D_ compute_qs_k_1d_r8 + +#undef COMPUTE_QS_K_0D_ +#define COMPUTE_QS_K_0D_ compute_qs_k_0d_r8 + +#undef COMPUTE_MRS_K_3D_ +#define COMPUTE_MRS_K_3D_ compute_mrs_k_3d_r8 + +#undef COMPUTE_MRS_K_2D_ +#define COMPUTE_MRS_K_2D_ compute_mrs_k_2d_r8 + +#undef COMPUTE_MRS_K_1D_ +#define COMPUTE_MRS_K_1D_ compute_mrs_k_1d_r8 + +#undef COMPUTE_MRS_K_0D_ +#define COMPUTE_MRS_K_0D_ compute_mrs_k_0d_r8 + +#undef LOOKUP_ES_DES_K_3D_ +#define LOOKUP_ES_DES_K_3D_ lookup_es_des_k_3d_r8 + +#undef LOOKUP_ES_DES_K_2D_ +#define LOOKUP_ES_DES_K_2D_ lookup_es_des_k_2d_r8 + +#undef LOOKUP_ES_DES_K_1D_ +#define LOOKUP_ES_DES_K_1D_ lookup_es_des_k_1d_r8 + +#undef LOOKUP_ES_DES_K_0D_ +#define LOOKUP_ES_DES_K_0D_ lookup_es_des_k_0d_r8 + +#undef LOOKUP_ES_K_3D_ +#define LOOKUP_ES_K_3D_ lookup_es_k_3d_r8 + +#undef LOOKUP_DES_K_3D_ +#define LOOKUP_DES_K_3D_ lookup_des_k_3d_r8 + +#undef LOOKUP_DES_K_2D_ +#define LOOKUP_DES_K_2D_ lookup_des_k_2d_r8 + +#undef LOOKUP_ES_K_2D_ +#define LOOKUP_ES_K_2D_ lookup_es_k_2d_r8 + +#undef LOOKUP_DES_K_1D_ +#define LOOKUP_DES_K_1D_ lookup_des_k_1d_r8 + +#undef LOOKUP_ES_K_1D_ +#define LOOKUP_ES_K_1D_ lookup_es_k_1d_r8 + +#undef LOOKUP_DES_K_1D_ +#define LOOKUP_DES_K_1D_ lookup_des_k_1d_r8 + +#undef LOOKUP_ES_K_0D_ +#define LOOKUP_ES_K_0D_ lookup_es_k_0d_r8 + +#undef LOOKUP_DES_K_0D_ +#define LOOKUP_DES_K_0D_ lookup_des_k_0d_r8 + +#undef LOOKUP_ES2_DES2_K_3D_ +#define LOOKUP_ES2_DES2_K_3D_ lookup_es2_des2_k_3d_r8 + +#undef LOOKUP_ES2_DES2_K_2D_ +#define LOOKUP_ES2_DES2_K_2D_ lookup_es2_des2_k_2d_r8 + +#undef LOOKUP_ES2_DES2_K_1D_ +#define LOOKUP_ES2_DES2_K_1D_ lookup_es2_des2_k_1d_r8 + +#undef LOOKUP_ES2_DES2_K_0D_ +#define LOOKUP_ES2_DES2_K_0D_ lookup_es2_des2_k_0d_r8 + +#undef LOOKUP_ES2_K_3D_ +#define LOOKUP_ES2_K_3D_ lookup_es2_k_3d_r8 + +#undef LOOKUP_DES2_K_3D_ +#define LOOKUP_DES2_K_3D_ lookup_des2_k_3d_r8 + +#undef LOOKUP_DES2_K_2D_ +#define LOOKUP_DES2_K_2D_ lookup_des2_k_2d_r8 + +#undef LOOKUP_ES2_K_2D_ +#define LOOKUP_ES2_K_2D_ lookup_es2_k_2d_r8 + +#undef LOOKUP_DES2_K_1D_ +#define LOOKUP_DES2_K_1D_ lookup_des2_k_1d_r8 + +#undef LOOKUP_ES2_K_1D_ +#define LOOKUP_ES2_K_1D_ lookup_es2_k_1d_r8 + +#undef LOOKUP_DES2_K_0D_ +#define LOOKUP_DES2_K_0D_ lookup_des2_k_0d_r8 + +#undef LOOKUP_ES2_K_0D_ +#define LOOKUP_ES2_K_0D_ lookup_es2_k_0d_r8 + +#undef LOOKUP_ES3_DES3_K_3D_ +#define LOOKUP_ES3_DES3_K_3D_ lookup_es3_des3_k_3d_r8 + +#undef LOOKUP_ES3_DES3_K_2D_ +#define LOOKUP_ES3_DES3_K_2D_ lookup_es3_des3_k_2d_r8 + +#undef LOOKUP_ES3_DES3_K_1D_ +#define LOOKUP_ES3_DES3_K_1D_ lookup_es3_des3_k_1d_r8 + +#undef LOOKUP_ES3_DES3_K_0D_ +#define LOOKUP_ES3_DES3_K_0D_ lookup_es3_des3_k_0d_r8 + +#undef LOOKUP_ES3_K_3D_ +#define LOOKUP_ES3_K_3D_ lookup_es3_k_3d_r8 + +#undef LOOKUP_DES3_K_3D_ +#define LOOKUP_DES3_K_3D_ lookup_des3_k_3d_r8 + +#undef LOOKUP_DES3_K_2D_ +#define LOOKUP_DES3_K_2D_ lookup_des3_k_2d_r8 + +#undef LOOKUP_ES3_K_2D_ +#define LOOKUP_ES3_K_2D_ lookup_es3_k_2d_r8 + +#undef LOOKUP_DES3_K_1D_ +#define LOOKUP_DES3_K_1D_ lookup_des3_k_1d_r8 + +#undef LOOKUP_ES3_K_1D_ +#define LOOKUP_ES3_K_1D_ lookup_es3_k_1d_r8 + +#undef LOOKUP_DES3_K_0D_ +#define LOOKUP_DES3_K_0D_ lookup_des3_k_0d_r8 + +#undef LOOKUP_ES3_K_0D_ +#define LOOKUP_ES3_K_0D_ lookup_es3_k_0d_r8 + +#include "sat_vapor_pres_k.inc" + +!> @} diff --git a/sat_vapor_pres/include/sat_vapor_pres_r4.fh b/sat_vapor_pres/include/sat_vapor_pres_r4.fh new file mode 100644 index 0000000000..462a131f23 --- /dev/null +++ b/sat_vapor_pres/include/sat_vapor_pres_r4.fh @@ -0,0 +1,186 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup sat_vapor_pres +!> @{ + +#undef FMS_SVP_KIND_ +#define FMS_SVP_KIND_ r4_kind + +#undef LOOKUP_ES_0D_ +#define LOOKUP_ES_0D_ lookup_es_0d_r4 + +#undef LOOKUP_ES_1D_ +#define LOOKUP_ES_1D_ lookup_es_1d_r4 + +#undef LOOKUP_ES_2D_ +#define LOOKUP_ES_2D_ lookup_es_2d_r4 + +#undef LOOKUP_ES_3D_ +#define LOOKUP_ES_3D_ lookup_es_3d_r4 + +#undef LOOKUP_ES2_0D_ +#define LOOKUP_ES2_0D_ lookup_es2_0d_r4 + +#undef LOOKUP_ES2_1D_ +#define LOOKUP_ES2_1D_ lookup_es2_1d_r4 + +#undef LOOKUP_ES2_2D_ +#define LOOKUP_ES2_2D_ lookup_es2_2d_r4 + +#undef LOOKUP_ES2_3D_ +#define LOOKUP_ES2_3D_ lookup_es2_3d_r4 + +#undef LOOKUP_ES3_0D_ +#define LOOKUP_ES3_0D_ lookup_es3_0d_r4 + +#undef LOOKUP_ES3_1D_ +#define LOOKUP_ES3_1D_ lookup_es3_1d_r4 + +#undef LOOKUP_ES3_2D_ +#define LOOKUP_ES3_2D_ lookup_es3_2d_r4 + +#undef LOOKUP_ES3_3D_ +#define LOOKUP_ES3_3D_ lookup_es3_3d_r4 + +#undef LOOKUP_DES_0D_ +#define LOOKUP_DES_0D_ lookup_des_0d_r4 + +#undef LOOKUP_DES_1D_ +#define LOOKUP_DES_1D_ lookup_des_1d_r4 + +#undef LOOKUP_DES_2D_ +#define LOOKUP_DES_2D_ lookup_des_2d_r4 + +#undef LOOKUP_DES_3D_ +#define LOOKUP_DES_3D_ lookup_des_3d_r4 + +#undef LOOKUP_DES2_0D_ +#define LOOKUP_DES2_0D_ lookup_des2_0d_r4 + +#undef LOOKUP_DES2_1D_ +#define LOOKUP_DES2_1D_ lookup_des2_1d_r4 + +#undef LOOKUP_DES2_2D_ +#define LOOKUP_DES2_2D_ lookup_des2_2d_r4 + +#undef LOOKUP_DES2_3D_ +#define LOOKUP_DES2_3D_ lookup_des2_3d_r4 + +#undef LOOKUP_DES3_0D_ +#define LOOKUP_DES3_0D_ lookup_des3_0d_r4 + +#undef LOOKUP_DES3_1D_ +#define LOOKUP_DES3_1D_ lookup_des3_1d_r4 + +#undef LOOKUP_DES3_2D_ +#define LOOKUP_DES3_2D_ lookup_des3_2d_r4 + +#undef LOOKUP_DES3_3D_ +#define LOOKUP_DES3_3D_ lookup_des3_3d_r4 + +#undef LOOKUP_ES_DES_0D_ +#define LOOKUP_ES_DES_0D_ lookup_es_des_0d_r4 + +#undef LOOKUP_ES_DES_1D_ +#define LOOKUP_ES_DES_1D_ lookup_es_des_1d_r4 + +#undef LOOKUP_ES_DES_2D_ +#define LOOKUP_ES_DES_2D_ lookup_es_des_2d_r4 + +#undef LOOKUP_ES_DES_3D_ +#define LOOKUP_ES_DES_3D_ lookup_es_des_3d_r4 + +#undef LOOKUP_ES2_DES2_0D_ +#define LOOKUP_ES2_DES2_0D_ lookup_es2_des2_0d_r4 + +#undef LOOKUP_ES2_DES2_1D_ +#define LOOKUP_ES2_DES2_1D_ lookup_es2_des2_1d_r4 + +#undef LOOKUP_ES2_DES2_2D_ +#define LOOKUP_ES2_DES2_2D_ lookup_es2_des2_2d_r4 + +#undef LOOKUP_ES2_DES2_3D_ +#define LOOKUP_ES2_DES2_3D_ lookup_es2_des2_3d_r4 + +#undef LOOKUP_ES3_DES3_0D_ +#define LOOKUP_ES3_DES3_0D_ lookup_es3_des3_0d_r4 + +#undef LOOKUP_ES3_DES3_1D_ +#define LOOKUP_ES3_DES3_1D_ lookup_es3_des3_1d_r4 + +#undef LOOKUP_ES3_DES3_2D_ +#define LOOKUP_ES3_DES3_2D_ lookup_es3_des3_2d_r4 + +#undef LOOKUP_ES3_DES3_3D_ +#define LOOKUP_ES3_DES3_3D_ lookup_es3_des3_3d_r4 + +#undef COMPUTE_QS_0D_ +#define COMPUTE_QS_0D_ compute_qs_0d_r4 + +#undef COMPUTE_QS_1D_ +#define COMPUTE_QS_1D_ compute_qs_1d_r4 + +#undef COMPUTE_QS_2D_ +#define COMPUTE_QS_2D_ compute_qs_2d_r4 + +#undef COMPUTE_QS_3D_ +#define COMPUTE_QS_3D_ compute_qs_3d_r4 + +#undef COMPUTE_MRS_0D_ +#define COMPUTE_MRS_0D_ compute_mrs_0d_r4 + +#undef COMPUTE_MRS_1D_ +#define COMPUTE_MRS_1D_ compute_mrs_1d_r4 + +#undef COMPUTE_MRS_2D_ +#define COMPUTE_MRS_2D_ compute_mrs_2d_r4 + +#undef COMPUTE_MRS_3D_ +#define COMPUTE_MRS_3D_ compute_mrs_3d_r4 + +#undef CHECK_1D_ +#define CHECK_1D_ check_1d_r4 + +#undef CHECK_2D_ +#define CHECK_2D_ check_2d_r4 + +#undef TEMP_CHECK_1D_ +#define TEMP_CHECK_1D_ temp_check_1d_r4 + +#undef TEMP_CHECK_2D_ +#define TEMP_CHECK_2D_ temp_check_2d_r4 + +#undef TEMP_CHECK_3D_ +#define TEMP_CHECK_3D_ temp_checK_3d_r4 + +#undef SHOW_ALL_BAD_0D_ +#define SHOW_ALL_BAD_0D_ show_all_bad_0d_r4 + +#undef SHOW_ALL_BAD_1D_ +#define SHOW_ALL_BAD_1D_ show_all_bad_1d_r4 + +#undef SHOW_ALL_BAD_2D_ +#define SHOW_ALL_BAD_2D_ show_all_bad_2d_r4 + +#undef SHOW_ALL_BAD_3D_ +#define SHOW_ALL_BAD_3D_ show_all_bad_3d_r4 + +#include "sat_vapor_pres.inc" + +!> @} diff --git a/sat_vapor_pres/include/sat_vapor_pres_r8.fh b/sat_vapor_pres/include/sat_vapor_pres_r8.fh new file mode 100644 index 0000000000..0f2e6a315f --- /dev/null +++ b/sat_vapor_pres/include/sat_vapor_pres_r8.fh @@ -0,0 +1,186 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @addtogroup sat_vapor_pres +!> @{ + +#undef FMS_SVP_KIND_ +#define FMS_SVP_KIND_ r8_kind + +#undef LOOKUP_ES_0D_ +#define LOOKUP_ES_0D_ lookup_es_0d_r8 + +#undef LOOKUP_ES_1D_ +#define LOOKUP_ES_1D_ lookup_es_1d_r8 + +#undef LOOKUP_ES_2D_ +#define LOOKUP_ES_2D_ lookup_es_2d_r8 + +#undef LOOKUP_ES_3D_ +#define LOOKUP_ES_3D_ lookup_es_3d_r8 + +#undef LOOKUP_ES2_0D_ +#define LOOKUP_ES2_0D_ lookup_es2_0d_r8 + +#undef LOOKUP_ES2_1D_ +#define LOOKUP_ES2_1D_ lookup_es2_1d_r8 + +#undef LOOKUP_ES2_2D_ +#define LOOKUP_ES2_2D_ lookup_es2_2d_r8 + +#undef LOOKUP_ES2_3D_ +#define LOOKUP_ES2_3D_ lookup_es2_3d_r8 + +#undef LOOKUP_ES3_0D_ +#define LOOKUP_ES3_0D_ lookup_es3_0d_r8 + +#undef LOOKUP_ES3_1D_ +#define LOOKUP_ES3_1D_ lookup_es3_1d_r8 + +#undef LOOKUP_ES3_2D_ +#define LOOKUP_ES3_2D_ lookup_es3_2d_r8 + +#undef LOOKUP_ES3_3D_ +#define LOOKUP_ES3_3D_ lookup_es3_3d_r8 + +#undef LOOKUP_DES_0D_ +#define LOOKUP_DES_0D_ lookup_des_0d_r8 + +#undef LOOKUP_DES_1D_ +#define LOOKUP_DES_1D_ lookup_des_1d_r8 + +#undef LOOKUP_DES_2D_ +#define LOOKUP_DES_2D_ lookup_des_2d_r8 + +#undef LOOKUP_DES_3D_ +#define LOOKUP_DES_3D_ lookup_des_3d_r8 + +#undef LOOKUP_DES2_0D_ +#define LOOKUP_DES2_0D_ lookup_des2_0d_r8 + +#undef LOOKUP_DES2_1D_ +#define LOOKUP_DES2_1D_ lookup_des2_1d_r8 + +#undef LOOKUP_DES2_2D_ +#define LOOKUP_DES2_2D_ lookup_des2_2d_r8 + +#undef LOOKUP_DES2_3D_ +#define LOOKUP_DES2_3D_ lookup_des2_3d_r8 + +#undef LOOKUP_DES3_0D_ +#define LOOKUP_DES3_0D_ lookup_des3_0d_r8 + +#undef LOOKUP_DES3_1D_ +#define LOOKUP_DES3_1D_ lookup_des3_1d_r8 + +#undef LOOKUP_DES3_2D_ +#define LOOKUP_DES3_2D_ lookup_des3_2d_r8 + +#undef LOOKUP_DES3_3D_ +#define LOOKUP_DES3_3D_ lookup_des3_3d_r8 + +#undef LOOKUP_ES_DES_0D_ +#define LOOKUP_ES_DES_0D_ lookup_es_des_0d_r8 + +#undef LOOKUP_ES_DES_1D_ +#define LOOKUP_ES_DES_1D_ lookup_es_des_1d_r8 + +#undef LOOKUP_ES_DES_2D_ +#define LOOKUP_ES_DES_2D_ lookup_es_des_2d_r8 + +#undef LOOKUP_ES_DES_3D_ +#define LOOKUP_ES_DES_3D_ lookup_es_des_3d_r8 + +#undef LOOKUP_ES2_DES2_0D_ +#define LOOKUP_ES2_DES2_0D_ lookup_es2_des2_0d_r8 + +#undef LOOKUP_ES2_DES2_1D_ +#define LOOKUP_ES2_DES2_1D_ lookup_es2_des2_1d_r8 + +#undef LOOKUP_ES2_DES2_2D_ +#define LOOKUP_ES2_DES2_2D_ lookup_es2_des2_2d_r8 + +#undef LOOKUP_ES2_DES2_3D_ +#define LOOKUP_ES2_DES2_3D_ lookup_es2_des2_3d_r8 + +#undef LOOKUP_ES3_DES3_0D_ +#define LOOKUP_ES3_DES3_0D_ lookup_es3_des3_0d_r8 + +#undef LOOKUP_ES3_DES3_1D_ +#define LOOKUP_ES3_DES3_1D_ lookup_es3_des3_1d_r8 + +#undef LOOKUP_ES3_DES3_2D_ +#define LOOKUP_ES3_DES3_2D_ lookup_es3_des3_2d_r8 + +#undef LOOKUP_ES3_DES3_3D_ +#define LOOKUP_ES3_DES3_3D_ lookup_es3_des3_3d_r8 + +#undef COMPUTE_QS_0D_ +#define COMPUTE_QS_0D_ compute_qs_0d_r8 + +#undef COMPUTE_QS_1D_ +#define COMPUTE_QS_1D_ compute_qs_1d_r8 + +#undef COMPUTE_QS_2D_ +#define COMPUTE_QS_2D_ compute_qs_2d_r8 + +#undef COMPUTE_QS_3D_ +#define COMPUTE_QS_3D_ compute_qs_3d_r8 + +#undef COMPUTE_MRS_0D_ +#define COMPUTE_MRS_0D_ compute_mrs_0d_r8 + +#undef COMPUTE_MRS_1D_ +#define COMPUTE_MRS_1D_ compute_mrs_1d_r8 + +#undef COMPUTE_MRS_2D_ +#define COMPUTE_MRS_2D_ compute_mrs_2d_r8 + +#undef COMPUTE_MRS_3D_ +#define COMPUTE_MRS_3D_ compute_mrs_3d_r8 + +#undef CHECK_1D_ +#define CHECK_1D_ check_1d_r8 + +#undef CHECK_2D_ +#define CHECK_2D_ check_2d_r8 + +#undef TEMP_CHECK_1D_ +#define TEMP_CHECK_1D_ temp_check_1d_r8 + +#undef TEMP_CHECK_2D_ +#define TEMP_CHECK_2D_ temp_check_2d_r8 + +#undef TEMP_CHECK_3D_ +#define TEMP_CHECK_3D_ temp_checK_3d_r8 + +#undef SHOW_ALL_BAD_0D_ +#define SHOW_ALL_BAD_0D_ show_all_bad_0d_r8 + +#undef SHOW_ALL_BAD_1D_ +#define SHOW_ALL_BAD_1D_ show_all_bad_1d_r8 + +#undef SHOW_ALL_BAD_2D_ +#define SHOW_ALL_BAD_2D_ show_all_bad_2d_r8 + +#undef SHOW_ALL_BAD_3D_ +#define SHOW_ALL_BAD_3D_ show_all_bad_3d_r8 + +#include "sat_vapor_pres.inc" + +!> @} diff --git a/sat_vapor_pres/sat_vapor_pres.F90 b/sat_vapor_pres/sat_vapor_pres.F90 index 1e29b8bc38..b5591e99d4 100644 --- a/sat_vapor_pres/sat_vapor_pres.F90 +++ b/sat_vapor_pres/sat_vapor_pres.F90 @@ -190,7 +190,6 @@ module sat_vapor_pres_mod lookup_es3_k, & lookup_des3_k, lookup_es3_des3_k, & compute_qs_k, compute_mrs_k - use platform_mod, only: r4_kind, r8_kind implicit none @@ -264,13 +263,19 @@ module sat_vapor_pres_mod !! then parameters in the module header must be modified. !> @ingroup sat_vapor_pres_mod interface lookup_es - module procedure lookup_es_0d, lookup_es_1d, lookup_es_2d, lookup_es_3d - end interface + module procedure lookup_es_0d_r4, lookup_es_0d_r8 + module procedure lookup_es_1d_r4, lookup_es_1d_r8 + module procedure lookup_es_2d_r4, lookup_es_2d_r8 + module procedure lookup_es_3d_r4, lookup_es_3d_r8 + end interface lookup_es !> Provided for backward compatibility (to be removed soon) !> @ingroup sat_vapor_pres_mod interface escomp - module procedure lookup_es_0d, lookup_es_1d, lookup_es_2d, lookup_es_3d - end interface + module procedure lookup_es_0d_r4, lookup_es_0d_r8 + module procedure lookup_es_1d_r4, lookup_es_1d_r8 + module procedure lookup_es_2d_r4, lookup_es_2d_r8 + module procedure lookup_es_3d_r4, lookup_es_3d_r8 + end interface escomp ! !----------------------------------------------------------------------- ! @@ -335,14 +340,20 @@ module sat_vapor_pres_mod !! @code{.F90} call lookup_des( temp, desat) @endcode !> @ingroup sat_vapor_pres_mod interface lookup_des - module procedure lookup_des_0d, lookup_des_1d, lookup_des_2d, lookup_des_3d - end interface + module procedure lookup_des_0d_r4, lookup_des_0d_r8 + module procedure lookup_des_1d_r4, lookup_des_1d_r8 + module procedure lookup_des_2d_r4, lookup_des_2d_r8 + module procedure lookup_des_3d_r4, lookup_des_3d_r8 + end interface lookup_des ! !> Provided for backward compatibility (to be removed soon) !> @ingroup sat_vapor_pres_mod interface descomp - module procedure lookup_des_0d, lookup_des_1d, lookup_des_2d, lookup_des_3d - end interface + module procedure lookup_des_0d_r4, lookup_des_0d_r8 + module procedure lookup_des_1d_r4, lookup_des_1d_r8 + module procedure lookup_des_2d_r4, lookup_des_2d_r8 + module procedure lookup_des_3d_r4, lookup_des_3d_r8 + end interface descomp !----------------------------------------------------------------------- @@ -419,38 +430,59 @@ module sat_vapor_pres_mod !! then parameters in the module header must be modified. !> @ingroup sat_vapor_pres_mod interface lookup_es_des - module procedure lookup_es_des_0d, lookup_es_des_1d, lookup_es_des_2d, lookup_es_des_3d - end interface + module procedure lookup_es_des_0d_r4, lookup_es_des_0d_r8 + module procedure lookup_es_des_1d_r4, lookup_es_des_1d_r8 + module procedure lookup_es_des_2d_r4, lookup_es_des_2d_r8 + module procedure lookup_es_des_3d_r4, lookup_es_des_3d_r8 + end interface lookup_es_des !> @ingroup sat_vapor_pres_mod interface lookup_es2 - module procedure lookup_es2_0d, lookup_es2_1d, lookup_es2_2d, lookup_es2_3d - end interface + module procedure lookup_es2_0d_r4, lookup_es2_0d_r8 + module procedure lookup_es2_1d_r4, lookup_es2_1d_r8 + module procedure lookup_es2_2d_r4, lookup_es2_2d_r8 + module procedure lookup_es2_3d_r4, lookup_es2_3d_r8 + end interface lookup_es2 !> @ingroup sat_vapor_pres_mod interface lookup_des2 - module procedure lookup_des2_0d, lookup_des2_1d, lookup_des2_2d, lookup_des2_3d - end interface + module procedure lookup_des2_0d_r4, lookup_des2_0d_r8 + module procedure lookup_des2_1d_r4, lookup_des2_1d_r8 + module procedure lookup_des2_2d_r4, lookup_des2_2d_r8 + module procedure lookup_des2_3d_r4, lookup_des2_3d_r8 + end interface lookup_des2 !> @ingroup sat_vapor_pres_mod interface lookup_es2_des2 - module procedure lookup_es2_des2_0d, lookup_es2_des2_1d, lookup_es2_des2_2d, lookup_es2_des2_3d - end interface + module procedure lookup_es2_des2_0d_r4, lookup_es2_des2_0d_r8 + module procedure lookup_es2_des2_1d_r4, lookup_es2_des2_1d_r8 + module procedure lookup_es2_des2_2d_r4, lookup_es2_des2_2d_r8 + module procedure lookup_es2_des2_3d_r4, lookup_es2_des2_3d_r8 + end interface lookup_es2_des2 !> @ingroup sat_vapor_pres_mod interface lookup_es3 - module procedure lookup_es3_0d, lookup_es3_1d, lookup_es3_2d, lookup_es3_3d - end interface + module procedure lookup_es3_0d_r4, lookup_es3_0d_r8 + module procedure lookup_es3_1d_r4, lookup_es3_1d_r8 + module procedure lookup_es3_2d_r4, lookup_es3_2d_r8 + module procedure lookup_es3_3d_r4, lookup_es3_3d_r8 + end interface lookup_es3 !> @ingroup sat_vapor_pres_mod interface lookup_des3 - module procedure lookup_des3_0d, lookup_des3_1d, lookup_des3_2d, lookup_des3_3d - end interface + module procedure lookup_des3_0d_r4, lookup_des3_0d_r8 + module procedure lookup_des3_1d_r4, lookup_des3_1d_r8 + module procedure lookup_des3_2d_r4, lookup_des3_2d_r8 + module procedure lookup_des3_3d_r4, lookup_des3_3d_r8 + end interface lookup_des3 !> @ingroup sat_vapor_pres_mod interface lookup_es3_des3 - module procedure lookup_es3_des3_0d, lookup_es3_des3_1d, lookup_es3_des3_2d, lookup_es3_des3_3d - end interface + module procedure lookup_es3_des3_0d_r4, lookup_es3_des3_0d_r8 + module procedure lookup_es3_des3_1d_r4, lookup_es3_des3_1d_r8 + module procedure lookup_es3_des3_2d_r4, lookup_es3_des3_2d_r8 + module procedure lookup_es3_des3_3d_r4, lookup_es3_des3_3d_r8 + end interface lookup_es3_des3 !----------------------------------------------------------------------- @@ -547,8 +579,11 @@ module sat_vapor_pres_mod !! !> @ingroup sat_vapor_pres_mod interface compute_qs - module procedure compute_qs_0d, compute_qs_1d, compute_qs_2d, compute_qs_3d - end interface + module procedure compute_qs_0d_r4, compute_qs_0d_r8 + module procedure compute_qs_1d_r4, compute_qs_1d_r8 + module procedure compute_qs_2d_r4, compute_qs_2d_r8 + module procedure compute_qs_3d_r4, compute_qs_3d_r8 + end interface compute_qs !----------------------------------------------------------------------- @@ -646,8 +681,11 @@ module sat_vapor_pres_mod !! err_msg ) @endcode !> @ingroup sat_vapor_pres_mod interface compute_mrs - module procedure compute_mrs_0d, compute_mrs_1d, compute_mrs_2d, compute_mrs_3d - end interface + module procedure compute_mrs_0d_r4, compute_mrs_0d_r8 + module procedure compute_mrs_1d_r4, compute_mrs_1d_r8 + module procedure compute_mrs_2d_r4, compute_mrs_2d_r8 + module procedure compute_mrs_3d_r4, compute_mrs_3d_r8 + end interface compute_mrs !----------------------------------------------------------------------- ! @@ -677,15 +715,29 @@ module sat_vapor_pres_mod !end interface ! !----------------------------------------------------------------------- + !> @ingroup sat_vapor_pres_mod + interface check_1d + module procedure check_1d_r4, check_1d_r8 + end interface check_1d + + interface check_2d + module procedure check_2d_r4, check_2d_r8 + end interface check_2d + !> @ingroup sat_vapor_pres_mod interface temp_check - module procedure temp_check_1d, temp_check_2d, temp_check_3d - end interface + module procedure temp_check_1d_r4, temp_check_1d_r8 + module procedure temp_check_2d_r4, temp_check_2d_r8 + module procedure temp_check_3d_r4, temp_check_3d_r8 + end interface temp_check !> @ingroup sat_vapor_pres_mod interface show_all_bad - module procedure show_all_bad_0d, show_all_bad_1d, show_all_bad_2d, show_all_bad_3d - end interface + module procedure show_all_bad_0d_r4, show_all_bad_0d_r8 + module procedure show_all_bad_1d_r4, show_all_bad_1d_r8 + module procedure show_all_bad_2d_r4, show_all_bad_2d_r8 + module procedure show_all_bad_3d_r4, show_all_bad_3d_r8 + end interface show_all_bad !> @addtogroup sat_vapor_pres_mod !> @{ @@ -698,8 +750,8 @@ module sat_vapor_pres_mod !----------------------------------------------------------------------- ! parameters for use in computing qs and mrs - real, parameter :: EPSILO = RDGAS/RVGAS - real, parameter :: ZVIR = RVGAS/RDGAS - 1.0 + real(r8_kind), parameter :: EPSILO = real(RDGAS,r8_kind)/real(RVGAS, r8_kind) + real(r8_kind), parameter :: ZVIR = real(RVGAS,r8_kind)/real(RDGAS,r8_kind) - 1.0_r8_kind !----------------------------------------------------------------------- ! parameters for table size and resolution @@ -713,7 +765,7 @@ module sat_vapor_pres_mod integer :: stdoutunit=0 !----------------------------------------------------------------------- ! variables needed by temp_check - real :: tmin, dtinv, teps + real(r8_kind) :: tmin, dtinv, teps ! The default values below preserve the behavior of omsk and earlier revisions. logical :: show_bad_value_count_by_slice=.true. @@ -730,1747 +782,6 @@ module sat_vapor_pres_mod contains -!####################################################################### -! -! -! -! -! - subroutine lookup_es_0d ( temp, esat, err_msg ) - - class(*), intent(in) :: temp - class(*), intent(out) :: esat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es_0d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es_1d ( temp, esat, err_msg ) - - class(*), intent(in) :: temp(:) - class(*), intent(out) :: esat(:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif - -!----------------------------------------------- - - end subroutine lookup_es_1d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es_2d ( temp, esat, err_msg ) - - class(*), intent(in) :: temp(:,:) - class(*), intent(out) :: esat(:,:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif - -!----------------------------------------------- - - end subroutine lookup_es_2d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es_3d ( temp, esat, err_msg ) - - class(*), intent(in) :: temp(:,:,:) - class(*), intent(out) :: esat(:,:,:) - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_tmp,err_msg)) return - endif - - end subroutine lookup_es_3d - - -!####################################################################### -! -! -! -! -! - subroutine lookup_es2_0d ( temp, esat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: esat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es2_0d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es2_1d ( temp, esat, err_msg ) - - real, intent(in) :: temp(:) - real, intent(out) :: esat(:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return - endif - -!----------------------------------------------- - - end subroutine lookup_es2_1d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es2_2d ( temp, esat, err_msg ) - - real, intent(in) :: temp(:,:) - real, intent(out) :: esat(:,:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2',err_msg_local,err_msg)) return - endif - -!----------------------------------------------- - - end subroutine lookup_es2_2d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es2_3d ( temp, esat, err_msg ) - - real, intent(in) :: temp(:,:,:) - real, intent(out) :: esat(:,:,:) - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2',err_msg_tmp,err_msg)) return - endif - - end subroutine lookup_es2_3d - - -!####################################################################### -! -! -! -! -! - subroutine lookup_es3_0d ( temp, esat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: esat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es3_0d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es3_1d ( temp, esat, err_msg ) - - real, intent(in) :: temp(:) - real, intent(out) :: esat(:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return - endif - -!----------------------------------------------- - - end subroutine lookup_es3_1d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es3_2d ( temp, esat, err_msg ) - - real, intent(in) :: temp(:,:) - real, intent(out) :: esat(:,:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3',err_msg_local,err_msg)) return - endif - -!----------------------------------------------- - - end subroutine lookup_es3_2d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_es3_3d ( temp, esat, err_msg ) - - real, intent(in) :: temp(:,:,:) - real, intent(out) :: esat(:,:,:) - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_k(temp, esat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3',err_msg_tmp,err_msg)) return - endif - - end subroutine lookup_es3_3d - - -!####################################################################### -! routines for computing derivative of es -!####################################################################### - -! -! -! -! -! - subroutine lookup_des_0d ( temp, desat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des_k( temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des',err_msg_local,err_msg)) return - endif - - end subroutine lookup_des_0d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_des_1d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:) - real, intent(out) :: desat(:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if(present(err_msg)) err_msg='' - - call lookup_des_k(temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif -!----------------------------------------------- - - end subroutine lookup_des_1d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_des_2d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:,:) - real, intent(out) :: desat(:,:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des_k(temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif -!----------------------------------------------- - - end subroutine lookup_des_2d - -!####################################################################### -! -! -! -! -! - subroutine lookup_des_3d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:,:,:) - real, intent(out) :: desat(:,:,:) - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des_k( temp, desat, nbad ) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg='' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des',err_msg_tmp,err_msg)) return - endif - - end subroutine lookup_des_3d - - -! -! -! -! -! - subroutine lookup_des2_0d ( temp, desat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des2_k( temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return - endif - - end subroutine lookup_des2_0d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_des2_1d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:) - real, intent(out) :: desat(:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if(present(err_msg)) err_msg='' - - call lookup_des2_k(temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return - endif -!----------------------------------------------- - - end subroutine lookup_des2_1d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_des2_2d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:,:) - real, intent(out) :: desat(:,:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des2_k(temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des2',err_msg_local,err_msg)) return - endif -!----------------------------------------------- - - end subroutine lookup_des2_2d - -!####################################################################### -! -! -! -! -! - subroutine lookup_des2_3d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:,:,:) - real, intent(out) :: desat(:,:,:) - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des2_k( temp, desat, nbad ) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg='' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des2',err_msg_tmp,err_msg)) return - endif - - end subroutine lookup_des2_3d - - -! -! -! -! -! - subroutine lookup_des3_0d ( temp, desat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des3_k( temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return - endif - - end subroutine lookup_des3_0d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_des3_1d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:) - real, intent(out) :: desat(:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if(present(err_msg)) err_msg='' - - call lookup_des3_k(temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return - endif -!----------------------------------------------- - - end subroutine lookup_des3_1d - -!####################################################################### - -! -! -! -! -! - subroutine lookup_des3_2d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:,:) - real, intent(out) :: desat(:,:) - character(len=*), intent(out), optional :: err_msg - - character(len=54) :: err_msg_local - integer :: nbad -!----------------------------------------------- - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des3_k(temp, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des3',err_msg_local,err_msg)) return - endif -!----------------------------------------------- - - end subroutine lookup_des3_2d - -!####################################################################### -! -! -! -! -! - subroutine lookup_des3_3d ( temp, desat, err_msg ) - - real, intent(in) :: temp (:,:,:) - real, intent(out) :: desat(:,:,:) - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_des3_k( temp, desat, nbad ) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg='' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_des3',err_msg_tmp,err_msg)) return - endif - - end subroutine lookup_des3_3d - -!======================================================================================================== - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es_des_0d ( temp, esat, desat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_des_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es_des_0d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es_des_1d ( temp, esat, desat, err_msg ) - - real, dimension(:), intent(in) :: temp - real, dimension(:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_des_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es_des_1d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es_des_2d ( temp, esat, desat, err_msg ) - - real, dimension(:,:), intent(in) :: temp - real, dimension(:,:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_des_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es_des_2d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es_des_3d ( temp, esat, desat, err_msg ) - - real, dimension(:,:,:), intent(in) :: temp - real, dimension(:,:,:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es_des_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es_des_3d - -!####################################################################### -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es2_des2_0d ( temp, esat, desat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_des2_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es2_des2_0d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es2_des2_1d ( temp, esat, desat, err_msg ) - - real, dimension(:), intent(in) :: temp - real, dimension(:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_des2_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es2_des2_1d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es2_des2_2d ( temp, esat, desat, err_msg ) - - real, dimension(:,:), intent(in) :: temp - real, dimension(:,:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_des2_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es2_des2_2d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es2_des2_3d ( temp, esat, desat, err_msg ) - - real, dimension(:,:,:), intent(in) :: temp - real, dimension(:,:,:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es2_des2_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es2_des2',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es2_des2_3d - - -!####################################################################### -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es3_des3_0d ( temp, esat, desat, err_msg ) - - real, intent(in) :: temp - real, intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_des3_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es3_des3_0d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es3_des3_1d ( temp, esat, desat, err_msg ) - - real, dimension(:), intent(in) :: temp - real, dimension(:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_des3_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es3_des3_1d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es3_des3_2d ( temp, esat, desat, err_msg ) - - real, dimension(:,:), intent(in) :: temp - real, dimension(:,:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_des3_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es3_des3_2d - -!####################################################################### - -! -! -! -! -! -! - subroutine lookup_es3_des3_3d ( temp, esat, desat, err_msg ) - - real, dimension(:,:,:), intent(in) :: temp - real, dimension(:,:,:), intent(out) :: esat, desat - character(len=*), intent(out), optional :: err_msg - - integer :: nbad - character(len=128) :: err_msg_local - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - call lookup_es3_des3_k(temp, esat, desat, nbad) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_local,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('lookup_es3_des3',err_msg_local,err_msg)) return - endif - - end subroutine lookup_es3_des3_3d - -!####################################################################### - -! -! -! -! -! -! -! -! -! -! - subroutine compute_qs_0d ( temp, press, qsat, q, hc, dqsdT, esat, & - err_msg, es_over_liq, es_over_liq_and_ice ) - - class(*), intent(in) :: temp, press - class(*), intent(out) :: qsat - class(*), intent(in), optional :: q, hc - class(*), intent(out), optional :: dqsdT, esat - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - - call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_qs_0d - -!####################################################################### - -! -! -! -! -! -! -! -! -! -! - subroutine compute_qs_1d ( temp, press, qsat, q, hc, dqsdT, esat, & - err_msg, es_over_liq, es_over_liq_and_ice ) - - class(*), intent(in) :: temp(:), press(:) - class(*), intent(out) :: qsat(:) - class(*), intent(in), optional :: q(:) - class(*), intent(in), optional :: hc - class(*), intent(out), optional :: dqsdT(:), esat(:) - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - -! call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, dqsdT) - call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_qs_1d - - -!####################################################################### - -! -! -! -! -! -! -! -! -! -! - subroutine compute_qs_2d ( temp, press, qsat, q, hc, dqsdT, esat, & - err_msg, es_over_liq, es_over_liq_and_ice ) - - class(*), intent(in) :: temp(:,:), press(:,:) - class(*), intent(out) :: qsat(:,:) - class(*), intent(in), optional :: q(:,:) - class(*), intent(in), optional :: hc - class(*), intent(out), optional :: dqsdT(:,:), esat(:,:) - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - -! call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, dqsdT) - call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_qs_2d - -!####################################################################### - -! -! -! -! -! -! -! -! -! -! - subroutine compute_qs_3d ( temp, press, qsat, q, hc, dqsdT, esat, & - err_msg, es_over_liq, es_over_liq_and_ice ) - - class(*), intent(in) :: temp(:,:,:), press(:,:,:) - class(*), intent(out) :: qsat(:,:,:) - class(*), intent(in), optional :: q(:,:,:) - class(*), intent(in), optional :: hc - class(*), intent(out), optional :: dqsdT(:,:,:), esat(:,:,:) - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - -! call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, dqsdT) - call compute_qs_k (temp, press, EPSILO, ZVIR, qsat, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_qs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_qs_3d - -!####################################################################### -!####################################################################### - -! -! -! -! -! -! -! -! -! - subroutine compute_mrs_0d ( temp, press, mrsat, mr, hc, dmrsdT, esat, & - err_msg, es_over_liq, es_over_liq_and_ice ) - - real, intent(in) :: temp, press - real, intent(out) :: mrsat - real, intent(in), optional :: mr, hc - real, intent(out), optional :: dmrsdT, esat - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_mrs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - - call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, nbad, mr, & - hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_mrs_0d - -!####################################################################### -!####################################################################### - -! -! -! -! -! -! -! -! -! -! - subroutine compute_mrs_1d ( temp, press, mrsat, mr, hc, dmrsdT, esat,& - err_msg, es_over_liq, es_over_liq_and_ice ) - - real, intent(in) :: temp(:), press(:) - real, intent(out) :: mrsat(:) - real, intent(in), optional :: mr(:) - real, intent(in), optional :: hc - real, intent(out), optional :: dmrsdT(:), esat(:) - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_mrs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - -! call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, & -! nbad, mr, dmrsdT) - call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, nbad, mr, & - hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_mrs_1d - -!####################################################################### - -! -! -! -! -! -! -! -! -! -! - subroutine compute_mrs_2d ( temp, press, mrsat, mr, hc, dmrsdT, esat,& - err_msg, es_over_liq, es_over_liq_and_ice ) - - real, intent(in) :: temp(:,:), press(:,:) - real, intent(out) :: mrsat(:,:) - real, intent(in), optional :: mr(:,:) - real, intent(in), optional :: hc - real, intent(out), optional :: dmrsdT(:,:), esat(:,:) - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_mrs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - -! call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, & -! nbad, mr, dmrsdT) - call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, nbad, mr, & - hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_mrs_2d - -!####################################################################### - -! -! -! -! -! -! -! -! -! -! - subroutine compute_mrs_3d ( temp, press, mrsat, mr, hc, dmrsdT, esat,& - err_msg, es_over_liq, es_over_liq_and_ice ) - - real, intent(in) :: temp(:,:,:), press(:,:,:) - real, intent(out) :: mrsat(:,:,:) - real, intent(in), optional :: mr(:,:,:) - real, intent(in), optional :: hc - real, intent(out), optional :: dmrsdT(:,:,:), esat(:,:,:) - character(len=*), intent(out), optional :: err_msg - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - integer :: nbad - character(len=128) :: err_msg_tmp - - if (.not.module_is_initialized) then - if(fms_error_handler('lookup_es','sat_vapor_pres_init is not called' ,err_msg)) return - endif - - if (present(es_over_liq)) then - if (.not. (construct_table_wrt_liq)) then - call error_mesg ('compute_mrs', & - 'requesting es wrt liq, but that table not constructed', & - FATAL) - endif - endif - if (present(es_over_liq_and_ice)) then - if (.not. (construct_table_wrt_liq_and_ice)) then - call error_mesg ('compute_qs', & - 'requesting es wrt liq and ice, but that table not constructed', & - FATAL) - endif - endif - -! call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, & -! nbad, mr, dmrsdT) - call compute_mrs_k (temp, press, EPSILO, ZVIR, mrsat, nbad, mr, & - hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice) - - if ( nbad == 0 ) then - if(present(err_msg)) err_msg = '' - else - if(show_bad_value_count_by_slice) call temp_check ( temp ) - if(show_all_bad_values) call show_all_bad ( temp ) - write(err_msg_tmp,'(a47,i7)') 'saturation vapor pressure table overflow, nbad=', nbad - if(fms_error_handler('compute_mrs',err_msg_tmp,err_msg)) return - endif - - end subroutine compute_mrs_3d - - -!####################################################################### - -!####################################################################### - -! - -! -! Initializes the lookup tables for saturation vapor pressure. -! -! -! Initializes the lookup tables for saturation vapor pressure. -! This routine will be called automatically the first time -! lookup_es or lookup_des is called, -! the user does not need to call this routine. -! There are no arguments. -! -! -! - -! subroutine sat_vapor_pres_init(err_msg) ! ================================================================= @@ -2511,8 +822,9 @@ subroutine sat_vapor_pres_init(err_msg) endif nsize = (tcmax-tcmin)*esres+1 nlim = nsize-1 - call sat_vapor_pres_init_k(nsize, real(tcmin), real(tcmax), TFREEZE, HLV, & - RVGAS, ES0, err_msg_local, use_exact_qs, do_simple, & + call sat_vapor_pres_init_k(nsize, real(tcmin,r8_kind), real(tcmax,r8_kind), & + real(TFREEZE,r8_kind), real(HLV,r8_kind),& + real(RVGAS,r8_kind), real(ES0,r8_kind), err_msg_local, use_exact_qs, do_simple,& construct_table_wrt_liq, & construct_table_wrt_liq_and_ice, & teps, tmin, dtinv) @@ -2526,6 +838,9 @@ subroutine sat_vapor_pres_init(err_msg) end subroutine sat_vapor_pres_init +#include "sat_vapor_pres_r4.fh" +#include "sat_vapor_pres_r8.fh" + !####################################################################### !####################################################################### !------------------------------------------------------------------- @@ -2604,253 +919,6 @@ end subroutine sat_vapor_pres_init !end function compute_es_3d -!####################################################################### - - function check_1d ( temp ) result ( nbad ) - class(*), intent(in) :: temp(:) - integer :: nbad, ind, i - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - ind = int(dtinv*(temp(i)-tmin+teps)) - if (ind < 0 .or. ind > nlim) nbad = nbad+1 - enddo - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - ind = int(dtinv*(temp(i)-tmin+teps)) - if (ind < 0 .or. ind > nlim) nbad = nbad+1 - enddo - class default - call error_mesg ('sat_vapor_pres_mod::check_1d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end function check_1d - -!------------------------------------------------ - - function check_2d ( temp ) result ( nbad ) - class(*), intent(in) :: temp(:,:) - integer :: nbad - integer :: j - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - nbad = nbad + check_1d ( temp(:,j) ) - enddo - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - nbad = nbad + check_1d ( temp(:,j) ) - enddo - class default - call error_mesg ('sat_vapor_pres_mod::check_2d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end function check_2d - -!####################################################################### - - subroutine temp_check_1d ( temp ) - class(*), intent(in) :: temp(:) - integer :: i, unit - - unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1)) - type is (real(kind=r8_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1)) - class default - call error_mesg ('sat_vapor_pres_mod::temp_check_1d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end subroutine temp_check_1d - -!-------------------------------------------------------------- - - subroutine temp_check_2d ( temp ) - class(*), intent(in) :: temp(:,:) - integer :: i, j, unit - - unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1)) - write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2)) - type is (real(kind=r8_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1)) - write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2)) - class default - call error_mesg ('sat_vapor_pres_mod::temp_check_2d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end subroutine temp_check_2d - -!-------------------------------------------------------------- - - subroutine temp_check_3d ( temp ) - class(*), intent(in) :: temp(:,:,:) - integer :: i, j, k, unit - - unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1)) - write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2)) - write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3)) - type is (real(kind=r8_kind)) - write(unit,*) 'Bad temperatures (dimension 1): ', (check_2d(temp(i,:,:)),i=1,size(temp,1)) - write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2)) - write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3)) - class default - call error_mesg ('sat_vapor_pres_mod::temp_check_3d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end subroutine temp_check_3d - -!####################################################################### - -subroutine show_all_bad_0d ( temp ) - class(*), intent(in) :: temp - integer :: ind, unit - - unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - ind = int(dtinv*(temp-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe() - endif - type is (real(kind=r8_kind)) - ind = int(dtinv*(temp-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe() - endif - class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_0d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end subroutine show_all_bad_0d - -!-------------------------------------------------------------- - - subroutine show_all_bad_1d ( temp ) - class(*), intent(in) :: temp(:) - integer :: i, ind, unit - - unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - do i=1,size(temp) - ind = int(dtinv*(temp(i)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe() - endif - enddo - type is (real(kind=r8_kind)) - do i=1,size(temp) - ind = int(dtinv*(temp(i)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i6)') 'Bad temperature=',temp(i),' at i=',i,' pe=',mpp_pe() - endif - enddo - class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_1d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end subroutine show_all_bad_1d - -!-------------------------------------------------------------- - - subroutine show_all_bad_2d ( temp ) - class(*), intent(in) :: temp(:,:) - integer :: i, j, ind, unit - - unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - do j=1,size(temp,2) - do i=1,size(temp,1) - ind = int(dtinv*(temp(i,j)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe() - endif - enddo - enddo - type is (real(kind=r8_kind)) - do j=1,size(temp,2) - do i=1,size(temp,1) - ind = int(dtinv*(temp(i,j)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j),' at i=',i,' j=',j,' pe=',mpp_pe() - endif - enddo - enddo - class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_2d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end subroutine show_all_bad_2d - -!-------------------------------------------------------------- - - subroutine show_all_bad_3d ( temp ) - class(*), intent(in) :: temp(:,:,:) - integer :: i, j, k, ind, unit - - unit = stdoutunit - - select type (temp) - type is (real(kind=r4_kind)) - do k=1,size(temp,3) - do j=1,size(temp,2) - do i=1,size(temp,1) - ind = int(dtinv*(temp(i,j,k)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),& - &' at i=',i,' j=',j,' k=',k,' pe=',mpp_pe() - endif - enddo - enddo - enddo - type is (real(kind=r8_kind)) - do k=1,size(temp,3) - do j=1,size(temp,2) - do i=1,size(temp,1) - ind = int(dtinv*(temp(i,j,k)-tmin+teps)) - if (ind < 0 .or. ind > nlim) then - write(unit,'(a,e10.3,a,i4,a,i4,a,i4,a,i6)') 'Bad temperature=',temp(i,j,k),& - &' at i=',i,' j=',j,' k=',k,' pe=',mpp_pe() - endif - enddo - enddo - enddo - class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_3d',& - & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - end subroutine show_all_bad_3d - !####################################################################### end module sat_vapor_pres_mod !####################################################################### diff --git a/sat_vapor_pres/sat_vapor_pres_k.F90 b/sat_vapor_pres/sat_vapor_pres_k.F90 index a9b7a4aee2..03e3c72d12 100644 --- a/sat_vapor_pres/sat_vapor_pres_k.F90 +++ b/sat_vapor_pres/sat_vapor_pres_k.F90 @@ -69,4356 +69,185 @@ module sat_vapor_pres_k_mod public :: compute_qs_k public :: compute_mrs_k + !> @ingroup sat_vapor_pres_k_mod + interface sat_vapor_pres_init_k + module procedure sat_vapor_pres_init_k_r4 + module procedure sat_vapor_pres_init_k_r8 + end interface sat_vapor_pres_init_k + + !> @ingroup sat_vapor_pres_k_mod + interface compute_es_k + module procedure compute_es_k_r4 + module procedure compute_es_k_r8 + end interface compute_es_k + + interface compute_es_liq_k + module procedure compute_es_liq_k_r4 + module procedure compute_es_liq_k_r8 + end interface compute_es_liq_k + + interface compute_es_liq_ice_k + module procedure compute_es_liq_ice_k_r4 + module procedure compute_es_liq_ice_k_r8 + end interface compute_es_liq_ice_k + !> @ingroup sat_vapor_pres_k_mod interface lookup_es_k - module procedure lookup_es_k_0d - module procedure lookup_es_k_1d - module procedure lookup_es_k_2d - module procedure lookup_es_k_3d + module procedure lookup_es_k_0d_r4 + module procedure lookup_es_k_0d_r8 + module procedure lookup_es_k_1d_r4 + module procedure lookup_es_k_1d_r8 + module procedure lookup_es_k_2d_r4 + module procedure lookup_es_k_2d_r8 + module procedure lookup_es_k_3d_r4 + module procedure lookup_es_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_des_k - module procedure lookup_des_k_0d - module procedure lookup_des_k_1d - module procedure lookup_des_k_2d - module procedure lookup_des_k_3d + module procedure lookup_des_k_0d_r4 + module procedure lookup_des_k_0d_r8 + module procedure lookup_des_k_1d_r4 + module procedure lookup_des_k_1d_r8 + module procedure lookup_des_k_2d_r4 + module procedure lookup_des_k_2d_r8 + module procedure lookup_des_k_3d_r4 + module procedure lookup_des_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_es_des_k - module procedure lookup_es_des_k_0d - module procedure lookup_es_des_k_1d - module procedure lookup_es_des_k_2d - module procedure lookup_es_des_k_3d + module procedure lookup_es_des_k_0d_r4 + module procedure lookup_es_des_k_0d_r8 + module procedure lookup_es_des_k_1d_r4 + module procedure lookup_es_des_k_1d_r8 + module procedure lookup_es_des_k_2d_r4 + module procedure lookup_es_des_k_2d_r8 + module procedure lookup_es_des_k_3d_r4 + module procedure lookup_es_des_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_es2_k - module procedure lookup_es2_k_0d - module procedure lookup_es2_k_1d - module procedure lookup_es2_k_2d - module procedure lookup_es2_k_3d + module procedure lookup_es2_k_0d_r4 + module procedure lookup_es2_k_0d_r8 + module procedure lookup_es2_k_1d_r4 + module procedure lookup_es2_k_1d_r8 + module procedure lookup_es2_k_2d_r4 + module procedure lookup_es2_k_2d_r8 + module procedure lookup_es2_k_3d_r4 + module procedure lookup_es2_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_des2_k - module procedure lookup_des2_k_0d - module procedure lookup_des2_k_1d - module procedure lookup_des2_k_2d - module procedure lookup_des2_k_3d + module procedure lookup_des2_k_0d_r4 + module procedure lookup_des2_k_0d_r8 + module procedure lookup_des2_k_1d_r4 + module procedure lookup_des2_k_1d_r8 + module procedure lookup_des2_k_2d_r4 + module procedure lookup_des2_k_2d_r8 + module procedure lookup_des2_k_3d_r4 + module procedure lookup_des2_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_es2_des2_k - module procedure lookup_es2_des2_k_0d - module procedure lookup_es2_des2_k_1d - module procedure lookup_es2_des2_k_2d - module procedure lookup_es2_des2_k_3d + module procedure lookup_es2_des2_k_0d_r4 + module procedure lookup_es2_des2_k_0d_r8 + module procedure lookup_es2_des2_k_1d_r4 + module procedure lookup_es2_des2_k_1d_r8 + module procedure lookup_es2_des2_k_2d_r4 + module procedure lookup_es2_des2_k_2d_r8 + module procedure lookup_es2_des2_k_3d_r4 + module procedure lookup_es2_des2_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_es3_k - module procedure lookup_es3_k_0d - module procedure lookup_es3_k_1d - module procedure lookup_es3_k_2d - module procedure lookup_es3_k_3d + module procedure lookup_es3_k_0d_r4 + module procedure lookup_es3_k_0d_r8 + module procedure lookup_es3_k_1d_r4 + module procedure lookup_es3_k_1d_r8 + module procedure lookup_es3_k_2d_r4 + module procedure lookup_es3_k_2d_r8 + module procedure lookup_es3_k_3d_r4 + module procedure lookup_es3_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_des3_k - module procedure lookup_des3_k_0d - module procedure lookup_des3_k_1d - module procedure lookup_des3_k_2d - module procedure lookup_des3_k_3d + module procedure lookup_des3_k_0d_r4 + module procedure lookup_des3_k_0d_r8 + module procedure lookup_des3_k_1d_r4 + module procedure lookup_des3_k_1d_r8 + module procedure lookup_des3_k_2d_r4 + module procedure lookup_des3_k_2d_r8 + module procedure lookup_des3_k_3d_r4 + module procedure lookup_des3_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface lookup_es3_des3_k - module procedure lookup_es3_des3_k_0d - module procedure lookup_es3_des3_k_1d - module procedure lookup_es3_des3_k_2d - module procedure lookup_es3_des3_k_3d + module procedure lookup_es3_des3_k_0d_r4 + module procedure lookup_es3_des3_k_0d_r8 + module procedure lookup_es3_des3_k_1d_r4 + module procedure lookup_es3_des3_k_1d_r8 + module procedure lookup_es3_des3_k_2d_r4 + module procedure lookup_es3_des3_k_2d_r8 + module procedure lookup_es3_des3_k_3d_r4 + module procedure lookup_es3_des3_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface compute_qs_k - module procedure compute_qs_k_0d - module procedure compute_qs_k_1d - module procedure compute_qs_k_2d - module procedure compute_qs_k_3d + module procedure compute_qs_k_0d_r4 + module procedure compute_qs_k_0d_r8 + module procedure compute_qs_k_1d_r4 + module procedure compute_qs_k_1d_r8 + module procedure compute_qs_k_2d_r4 + module procedure compute_qs_k_2d_r8 + module procedure compute_qs_k_3d_r4 + module procedure compute_qs_k_3d_r8 end interface !> @ingroup sat_vapor_pres_k_mod interface compute_mrs_k - module procedure compute_mrs_k_0d - module procedure compute_mrs_k_1d - module procedure compute_mrs_k_2d - module procedure compute_mrs_k_3d - end interface + module procedure compute_mrs_k_0d_r4 + module procedure compute_mrs_k_0d_r8 + module procedure compute_mrs_k_1d_r4 + module procedure compute_mrs_k_1d_r8 + module procedure compute_mrs_k_2d_r4 + module procedure compute_mrs_k_2d_r8 + module procedure compute_mrs_k_3d_r4 + module procedure compute_mrs_k_3d_r8 + end interface compute_mrs_k !> @addtogroup sat_vapor_pres_k_mod !> @{ - real :: dtres, tepsl, tminl, dtinvl + real(kind=r8_kind) :: dtres, tepsl, tminl, dtinvl integer :: table_siz - real, dimension(:), allocatable :: TABLE ! sat vapor pres (es) - real, dimension(:), allocatable :: DTABLE ! first derivative of es - real, dimension(:), allocatable :: D2TABLE ! second derivative of es - real, dimension(:), allocatable :: TABLE2 ! sat vapor pres (es) - real, dimension(:), allocatable :: DTABLE2 ! first derivative of es - real, dimension(:), allocatable :: D2TABLE2 ! second derivative of es - real, dimension(:), allocatable :: TABLE3 ! sat vapor pres (es) - real, dimension(:), allocatable :: DTABLE3 ! first derivative of es - real, dimension(:), allocatable :: D2TABLE3 ! second derivative of es + real(kind=r8_kind), dimension(:), allocatable :: TABLE ! sat vapor pres (es) + real(kind=r8_kind), dimension(:), allocatable :: DTABLE ! first derivative of es + real(kind=r8_kind), dimension(:), allocatable :: D2TABLE ! second derivative of es + real(kind=r8_kind), dimension(:), allocatable :: TABLE2 ! sat vapor pres (es) + real(kind=r8_kind), dimension(:), allocatable :: DTABLE2 ! first derivative of es + real(kind=r8_kind), dimension(:), allocatable :: D2TABLE2 ! second derivative of es + real(kind=r8_kind), dimension(:), allocatable :: TABLE3 ! sat vapor pres (es) + real(kind=r8_kind), dimension(:), allocatable :: DTABLE3 ! first derivative of es + real(kind=r8_kind), dimension(:), allocatable :: D2TABLE3 ! second derivative of es logical :: use_exact_qs logical :: module_is_initialized = .false. contains - subroutine sat_vapor_pres_init_k(table_size, tcmin, tcmax, TFREEZE, HLV, RVGAS, ES0, err_msg, & - use_exact_qs_input, do_simple, & - construct_table_wrt_liq, & - construct_table_wrt_liq_and_ice, & - teps, tmin, dtinv) - -! This routine has been generalized to return tables for any temperature range and resolution - - integer, intent(in) :: table_size - real, intent(in) :: tcmin ! TABLE(1) = sat vapor pressure at temperature tcmin (deg C) - real, intent(in) :: tcmax ! TABLE(table_size) = sat vapor pressure at temperature tcmax (deg C) - real, intent(in) :: TFREEZE, HLV, RVGAS, ES0 - logical, intent(in) :: use_exact_qs_input, do_simple - logical, intent(in) :: construct_table_wrt_liq - logical, intent(in) :: construct_table_wrt_liq_and_ice - character(len=*), intent(out) :: err_msg - real, intent(out), optional :: teps, tmin, dtinv - -! increment used to generate derivative table - real, dimension(3) :: tem(3), es(3) - real :: hdtinv, tinrc, tfact - integer :: i - - err_msg = '' - - if (module_is_initialized) return - - if(allocated(TABLE) .or. allocated(DTABLE) .or. allocated(D2TABLE)) then - err_msg = 'Attempt to allocate sat vapor pressure tables when already allocated' - return - else - allocate(TABLE(table_size), DTABLE(table_size), D2TABLE(table_size)) - endif - - if (construct_table_wrt_liq) then - if(allocated(TABLE2) .or. allocated(DTABLE2) .or. allocated(D2TABLE2)) then - err_msg = 'Attempt to allocate sat vapor pressure table2s when already allocated' - return - else - allocate(TABLE2(table_size), DTABLE2(table_size), D2TABLE2(table_size)) - endif - endif - - if (construct_table_wrt_liq_and_ice) then - if(allocated(TABLE3) .or. allocated(DTABLE3) .or. allocated(D2TABLE3)) then - err_msg = 'Attempt to allocate sat vapor pressure table2s when already allocated' - return - else - allocate(TABLE3(table_size), DTABLE3(table_size), D2TABLE3(table_size)) - endif - endif - - table_siz = table_size - dtres = (tcmax - tcmin)/real(table_size-1) - tminl = real(tcmin)+TFREEZE ! minimum valid temp in table - dtinvl = 1./dtres - tepsl = .5*dtres - tinrc = .1*dtres - if(present(teps )) teps =tepsl - if(present(tmin )) tmin =tminl - if(present(dtinv)) dtinv=dtinvl - -! To be able to compute tables for any temperature range and resolution, -! and at the same time exactly reproduce answers from memphis revision, -! it is necessary to compute ftact differently than it is in memphis. - tfact = 5.0*dtinvl - - hdtinv = dtinvl*0.5 - -! compute es tables from tcmin to tcmax -! estimate es derivative with small +/- difference - - if (do_simple) then - - do i = 1, table_size - tem(1) = tminl + dtres*real(i-1) - TABLE(i) = ES0*610.78*exp(-hlv/rvgas*(1./tem(1) - 1./tfreeze)) - DTABLE(i) = hlv*TABLE(i)/rvgas/tem(1)**2. - enddo - - else - - do i = 1, table_size - tem(1) = tminl + dtres*real(i-1) - tem(2) = tem(1)-tinrc - tem(3) = tem(1)+tinrc - es = compute_es_k (tem, TFREEZE) - TABLE(i) = es(1) - DTABLE(i) = (es(3)-es(2))*tfact - enddo - - endif !if (do_simple) - -! compute one-half second derivative using centered differences -! differencing des values in the table - - do i = 2, table_size-1 - D2TABLE(i) = 0.25*dtinvl*(DTABLE(i+1)-DTABLE(i-1)) - enddo - ! one-sided derivatives at boundaries - - D2TABLE(1) = 0.50*dtinvl*(DTABLE(2)-DTABLE(1)) - - D2TABLE(table_size) = 0.50*dtinvl*& - (DTABLE(table_size)-DTABLE(table_size-1)) - - if (construct_table_wrt_liq) then -! compute es tables from tcmin to tcmax -! estimate es derivative with small +/- difference - - do i = 1, table_size - tem(1) = tminl + dtres*real(i-1) - tem(2) = tem(1)-tinrc - tem(3) = tem(1)+tinrc -! pass in flag to force all values to be wrt liquid - es = compute_es_liq_k (tem, TFREEZE) - TABLE2(i) = es(1) - DTABLE2(i) = (es(3)-es(2))*tfact - enddo - -! compute one-half second derivative using centered differences -! differencing des values in the table - - do i = 2, table_size-1 - D2TABLE2(i) = 0.25*dtinvl*(DTABLE2(i+1)-DTABLE2(i-1)) - enddo -! one-sided derivatives at boundaries - - D2TABLE2(1) = 0.50*dtinvl*(DTABLE2(2)-DTABLE2(1)) - - D2TABLE2(table_size) = 0.50*dtinvl*& - (DTABLE2(table_size)-DTABLE2(table_size-1)) - endif - - - if (construct_table_wrt_liq_and_ice) then -! compute es tables from tcmin to tcmax -! estimate es derivative with small +/- difference - - do i = 1, table_size - tem(1) = tminl + dtres*real(i-1) - tem(2) = tem(1)-tinrc - tem(3) = tem(1)+tinrc -! pass in flag to force all values to be wrt liquid - es = compute_es_liq_ice_k (tem, TFREEZE) - TABLE3(i) = es(1) - DTABLE3(i) = (es(3)-es(2))*tfact - enddo - -! compute one-half second derivative using centered differences -! differencing des values in the table - - do i = 2, table_size-1 - D2TABLE3(i) = 0.25*dtinvl*(DTABLE3(i+1)-DTABLE3(i-1)) - enddo -! one-sided derivatives at boundaries - - D2TABLE3(1) = 0.50*dtinvl*(DTABLE3(2)-DTABLE3(1)) - - D2TABLE3(table_size) = 0.50*dtinvl*& - (DTABLE3(table_size)-DTABLE3(table_size-1)) - endif - - use_exact_qs = use_exact_qs_input - module_is_initialized = .true. - - end subroutine sat_vapor_pres_init_k - -!####################################################################### - - function compute_es_k(tem, TFREEZE) result (es) - real, intent(in) :: tem(:), TFREEZE - real :: es(size(tem,1)) - - real :: x, esice, esh2o, TBASW, TBASI - integer :: i - real, parameter :: ESBASW = 101324.60 - real, parameter :: ESBASI = 610.71 - - TBASW = TFREEZE+100. - TBASI = TFREEZE - - do i = 1, size(tem) - -! compute es over ice - - if (tem(i) < TBASI) then - x = -9.09718*(TBASI/tem(i)-1.0) - 3.56654*log10(TBASI/tem(i)) & - +0.876793*(1.0-tem(i)/TBASI) + log10(ESBASI) - esice =10.**(x) - else - esice = 0. - endif - -! compute es over water greater than -20 c. -! values over 100 c may not be valid -! see smithsonian meteorological tables page 350. - - if (tem(i) > -20.+TBASI) then - x = -7.90298*(TBASW/tem(i)-1.0) + 5.02808*log10(TBASW/tem(i)) & - -1.3816e-07*(10.0**((1.0-tem(i)/TBASW)*11.344)-1.0) & - +8.1328e-03*(10.0**((TBASW/tem(i)-1.0)*(-3.49149))-1.0) & - +log10(ESBASW) - esh2o = 10.**(x) - else - esh2o = 0. - endif - -! derive blended es over ice and supercooled water between -20c and 0c - - if (tem(i) <= -20.+TBASI) then - es(i) = esice - else if (tem(i) >= TBASI) then - es(i) = esh2o - else - es(i) = 0.05*((TBASI-tem(i))*esice + (tem(i)-TBASI+20.)*esh2o) - endif - - enddo - - end function compute_es_k - -!####################################################################### - - function compute_es_liq_k(tem, TFREEZE) result (es) - real, intent(in) :: tem(:), TFREEZE - real :: es(size(tem,1)) - - real :: x, esh2o, TBASW - integer :: i - real, parameter :: ESBASW = 101324.60 - - TBASW = TFREEZE+100. - - do i = 1, size(tem) - - -! compute es over water for all temps. -! values over 100 c may not be valid -! see smithsonian meteorological tables page 350. - - x = -7.90298*(TBASW/tem(i)-1.0) + 5.02808*log10(TBASW/tem(i)) & - -1.3816e-07*(10.0**((1.0-tem(i)/TBASW)*11.344)-1.0) & - +8.1328e-03*(10.0**((TBASW/tem(i)-1.0)*(-3.49149))-1.0) & - +log10(ESBASW) - esh2o = 10.**(x) - - - es(i) = esh2o - - enddo - - end function compute_es_liq_k - -!####################################################################### - - function compute_es_liq_ice_k(tem, TFREEZE) result (es) - real, intent(in) :: tem(:), TFREEZE - real :: es(size(tem,1)) - - real :: x, TBASW, TBASI - integer :: i - real, parameter :: ESBASW = 101324.60 - real, parameter :: ESBASI = 610.71 - - TBASW = TFREEZE+100. - TBASI = TFREEZE - - do i = 1, size(tem) - - if (tem(i) < TBASI) then - -! compute es over ice - - x = -9.09718*(TBASI/tem(i)-1.0) - 3.56654*log10(TBASI/tem(i)) & - +0.876793*(1.0-tem(i)/TBASI) + log10(ESBASI) - es(i) =10.**(x) - else - -! compute es over water -! values over 100 c may not be valid -! see smithsonian meteorological tables page 350. - - x = -7.90298*(TBASW/tem(i)-1.0) + 5.02808*log10(TBASW/tem(i)) & - -1.3816e-07*(10.0**((1.0-tem(i)/TBASW)*11.344)-1.0) & - +8.1328e-03*(10.0**((TBASW/tem(i)-1.0)*(-3.49149))-1.0) & - +log10(ESBASW) - es(i) = 10.**(x) - endif - - enddo - - end function compute_es_liq_ice_k - -!####################################################################### - - subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - class(*), intent(in), dimension(:,:,:) :: temp, press - real, intent(in) :: eps, zvir - class(*), intent(out), dimension(:,:,:) :: qs - integer, intent(out) :: nbad - class(*), intent(in), dimension(:,:,:), optional :: q - class(*), intent(in), optional :: hc - class(*), intent(out), dimension(:,:,:), optional :: dqsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real(kind=r4_kind), allocatable, dimension(:,:,:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use - !! when called with r4 arguments - real(kind=r8_kind), allocatable, dimension(:,:,:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use - !! when called with r8 arguments - integer :: i, j, k - real :: hc_loc - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (press) - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, press and qs types do not match', FATAL) - end if - - if (present(q)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (q) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (q) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and q types do not match', FATAL) - end if - - if (present(hc)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (hc) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (hc) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and hc types do not match', FATAL) - end if - - if (present(dqsdT)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (dqsdT) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (dqsdT) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and dqsdT types do not match', FATAL) - end if - - if (present(esat)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - select type (temp) - type is (real(kind=r4_kind)) - allocate(esloc_r4(size(temp,1), size(temp,2), size(temp,3))) - allocate(desat_r4(size(temp,1), size(temp,2), size(temp,3))) - allocate(denom_r4(size(temp,1), size(temp,2), size(temp,3))) - type is (real(kind=r8_kind)) - allocate(esloc_r8(size(temp,1), size(temp,2), size(temp,3))) - allocate(desat_r8(size(temp,1), size(temp,2), size(temp,3))) - allocate(denom_r8(size(temp,1), size(temp,2), size(temp,3))) - end select - - if (present(hc)) then - select type (hc) - type is (real(kind=r4_kind)) - hc_loc = hc - type is (real(kind=r8_kind)) - hc_loc = real(hc) - end select - else - hc_loc = 1.0 - endif - - if (present(es_over_liq)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es2_k (temp, esloc_r8, nbad) - end select - endif - else if (present(es_over_liq_and_ice)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es3_k (temp, esloc_r8, nbad) - end select - endif - else - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es_k (temp, esloc_r8, nbad) - end select - endif - endif - - select type (temp) - type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - esloc_r8 = esloc_r8*hc_loc - end select - - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = esloc_r4 - type is (real(kind=r8_kind)) - esat = esloc_r8 - end select - endif - - if (nbad == 0) then - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r4_kind)) - qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press - end select - endif - end select - else ! (present(q)) - denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 - do k=1,size(qs,3) - do j=1,size(qs,2) - do i=1,size(qs,1) - if (denom_r4(i,j,k) > 0.0_r4_kind) then - qs(i,j,k) = real(eps, kind=r4_kind)*esloc_r4(i,j,k)/denom_r4(i,j,k) - else - qs(i,j,k) = real(eps, kind=r4_kind) - endif - end do - end do - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 - end select - endif - endif ! (present(q)) - end select - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r8_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r8/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r8/press - end select - endif - end select - else ! (present(q)) - denom_r8 = press - (1.0 - eps)*esloc_r8 - do k=1,size(qs,3) - do j=1,size(qs,2) - do i=1,size(qs,1) - if (denom_r8(i,j,k) > 0.0) then - qs(i,j,k) = eps*esloc_r8(i,j,k)/denom_r8(i,j,k) - else - qs(i,j,k) = eps - endif - end do - end do - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = eps*press*desat_r8/denom_r8**2 - end select - endif - endif ! (present(q)) - end select - end select - else ! (nbad = 0) - select type (qs) - type is (real(kind=r4_kind)) - qs = -999.0_r4_kind - type is (real(kind=r8_kind)) - qs = -999. - end select - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = -999.0_r4_kind - type is (real(kind=r8_kind)) - dqsdT = -999. - end select - endif - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = -999.0_r4_kind - type is (real(kind=r8_kind)) - esat = -999. - end select - endif - endif ! (nbad = 0) - - select type (temp) - type is (real(kind=r4_kind)) - deallocate(esloc_r4, desat_r4, denom_r4) - type is (real(kind=r8_kind)) - deallocate(esloc_r8, desat_r8, denom_r8) - end select - - end subroutine compute_qs_k_3d - -!####################################################################### - - subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - class(*), intent(in), dimension(:,:) :: temp, press - real, intent(in) :: eps, zvir - class(*), intent(out), dimension(:,:) :: qs - integer, intent(out) :: nbad - class(*), intent(in), dimension(:,:), optional :: q - class(*), intent(in), optional :: hc - class(*), intent(out), dimension(:,:), optional :: dqsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real(kind=r4_kind), allocatable, dimension(:,:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use - !! when called with r4 arguments - real(kind=r8_kind), allocatable, dimension(:,:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use - !! when called with r8 arguments - integer :: i, j - real :: hc_loc - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (press) - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, press and qs types do not match', FATAL) - end if - - if (present(q)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (q) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (q) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and q types do not match', FATAL) - end if - - if (present(hc)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (hc) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (hc) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and hc types do not match', FATAL) - end if - - if (present(dqsdT)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (dqsdT) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (dqsdT) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and dqsdT types do not match', FATAL) - end if - - if (present(esat)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - select type (temp) - type is (real(kind=r4_kind)) - allocate(esloc_r4(size(temp,1), size(temp,2))) - allocate(desat_r4(size(temp,1), size(temp,2))) - allocate(denom_r4(size(temp,1), size(temp,2))) - type is (real(kind=r8_kind)) - allocate(esloc_r8(size(temp,1), size(temp,2))) - allocate(desat_r8(size(temp,1), size(temp,2))) - allocate(denom_r8(size(temp,1), size(temp,2))) - end select - - if (present(hc)) then - select type (hc) - type is (real(kind=r4_kind)) - hc_loc = hc - type is (real(kind=r8_kind)) - hc_loc = real(hc) - end select - else - hc_loc = 1.0 - endif - - if (present(es_over_liq)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es2_k (temp, esloc_r8, nbad) - end select - endif - else if (present(es_over_liq_and_ice)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es3_k (temp, esloc_r8, nbad) - end select - endif - else - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es_k (temp, esloc_r8, nbad) - end select - endif - endif - - select type (temp) - type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - esloc_r8 = esloc_r8*hc_loc - end select - - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = esloc_r4 - type is (real(kind=r8_kind)) - esat = esloc_r8 - end select - endif - - if (nbad == 0) then - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r4_kind)) - qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press - end select - endif - end select - else ! (present(q)) - denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 - do j=1,size(qs,2) - do i=1,size(qs,1) - if (denom_r4(i,j) > 0.0_r4_kind) then - qs(i,j) = real(eps, kind=r4_kind)*esloc_r4(i,j)/denom_r4(i,j) - else - qs(i,j) = real(eps, kind=r4_kind) - endif - end do - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 - end select - endif - endif ! (present(q)) - end select - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r8_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r8/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r8/press - end select - endif - end select - else ! (present(q)) - denom_r8 = press - (1.0 - eps)*esloc_r8 - do j=1,size(qs,2) - do i=1,size(qs,1) - if (denom_r8(i,j) > 0.0) then - qs(i,j) = eps*esloc_r8(i,j)/denom_r8(i,j) - else - qs(i,j) = eps - endif - end do - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = eps*press*desat_r8/denom_r8**2 - end select - endif - endif ! (present(q)) - end select - end select - else ! (nbad = 0) - select type (qs) - type is (real(kind=r4_kind)) - qs = -999.0_r4_kind - type is (real(kind=r8_kind)) - qs = -999. - end select - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = -999.0_r4_kind - type is (real(kind=r8_kind)) - dqsdT = -999. - end select - endif - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = -999.0_r4_kind - type is (real(kind=r8_kind)) - esat = -999. - end select - endif - endif ! (nbad = 0) - - select type (temp) - type is (real(kind=r4_kind)) - deallocate(esloc_r4, desat_r4, denom_r4) - type is (real(kind=r8_kind)) - deallocate(esloc_r8, desat_r8, denom_r8) - end select - - end subroutine compute_qs_k_2d - -!####################################################################### - - subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - class(*), intent(in), dimension(:) :: temp, press - real, intent(in) :: eps, zvir - class(*), intent(out),dimension(:) :: qs - integer, intent(out) :: nbad - class(*), intent(in), dimension(:), optional :: q - class(*), intent(in), optional :: hc - class(*), intent(out), dimension(:),optional :: dqsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real(kind=r4_kind), allocatable, dimension(:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use - !! when called with r4 arguments - real(kind=r8_kind), allocatable, dimension(:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use - !! when called with r8 arguments - integer :: i - real :: hc_loc - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (press) - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, press and qs types do not match', FATAL) - end if - - if (present(q)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (q) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (q) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and q types do not match', FATAL) - end if - - if (present(hc)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (hc) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (hc) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and hc types do not match', FATAL) - end if - - if (present(dqsdT)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (dqsdT) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (dqsdT) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and dqsdT types do not match', FATAL) - end if - - if (present(esat)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - select type (temp) - type is (real(kind=r4_kind)) - allocate(esloc_r4(size(temp,1))) - allocate(desat_r4(size(temp,1))) - allocate(denom_r4(size(temp,1))) - type is (real(kind=r8_kind)) - allocate(esloc_r8(size(temp,1))) - allocate(desat_r8(size(temp,1))) - allocate(denom_r8(size(temp,1))) - end select - - if (present(hc)) then - select type (hc) - type is (real(kind=r4_kind)) - hc_loc = hc - type is (real(kind=r8_kind)) - hc_loc = real(hc) - end select - else - hc_loc = 1.0 - endif - - if (present(es_over_liq)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es2_k (temp, esloc_r8, nbad) - end select - endif - else if (present(es_over_liq_and_ice)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es3_k (temp, esloc_r8, nbad) - end select - endif - else - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es_k (temp, esloc_r8, nbad) - end select - endif - endif - - select type (temp) - type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - esloc_r8 = esloc_r8*hc_loc - end select - - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = esloc_r4 - type is (real(kind=r8_kind)) - esat = esloc_r8 - end select - endif - - if (nbad == 0) then - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r4_kind)) - qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press - end select - endif - end select - else ! (present(q)) - denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 - do i=1,size(qs,1) - if (denom_r4(i) > 0.0_r4_kind) then - qs(i) = real(eps, kind=r4_kind)*esloc_r4(i)/denom_r4(i) - else - qs(i) = real(eps, kind=r4_kind) - endif - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 - end select - endif - endif ! (present(q)) - end select - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r8_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r8/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r8/press - end select - endif - end select - else ! (present(q)) - denom_r8 = press - (1.0 - eps)*esloc_r8 - do i=1,size(qs,1) - if (denom_r8(i) > 0.0) then - qs(i) = eps*esloc_r8(i)/denom_r8(i) - else - qs(i) = eps - endif - end do - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = eps*press*desat_r8/denom_r8**2 - end select - endif - endif ! (present(q)) - end select - end select - else ! (nbad = 0) - select type (qs) - type is (real(kind=r4_kind)) - qs = -999.0_r4_kind - type is (real(kind=r8_kind)) - qs = -999. - end select - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = -999.0_r4_kind - type is (real(kind=r8_kind)) - dqsdT = -999. - end select - endif - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = -999.0_r4_kind - type is (real(kind=r8_kind)) - esat = -999. - end select - endif - endif ! (nbad = 0) - - select type (temp) - type is (real(kind=r4_kind)) - deallocate(esloc_r4, desat_r4, denom_r4) - type is (real(kind=r8_kind)) - deallocate(esloc_r8, desat_r8, denom_r8) - end select - - end subroutine compute_qs_k_1d - -!####################################################################### - - subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & - dqsdT, esat, es_over_liq, es_over_liq_and_ice) - - class(*), intent(in) :: temp, press - real, intent(in) :: eps, zvir - class(*), intent(out) :: qs - integer, intent(out) :: nbad - class(*), intent(in), optional :: q - class(*), intent(in), optional :: hc - class(*), intent(out), optional :: dqsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real(kind=r4_kind) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments - real(kind=r8_kind) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments - real :: hc_loc - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (press) - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, press and qs types do not match', FATAL) - end if - - if (present(q)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (q) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (q) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and q types do not match', FATAL) - end if - - if (present(hc)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (hc) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (hc) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and hc types do not match', FATAL) - end if - - if (present(dqsdT)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (dqsdT) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (dqsdT) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and dqsdT types do not match', FATAL) - end if - - if (present(esat)) then - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end if - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - if (present(hc)) then - select type (hc) - type is (real(kind=r4_kind)) - hc_loc = hc - type is (real(kind=r8_kind)) - hc_loc = real(hc) - end select - else - hc_loc = 1.0 - endif - - if (present(es_over_liq)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es2_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es2_k (temp, esloc_r8, nbad) - end select - endif - else if (present(es_over_liq_and_ice)) then - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es3_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es3_k (temp, esloc_r8, nbad) - end select - endif - else - if (present (dqsdT)) then - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) - desat_r8 = desat_r8*hc_loc - end select - else - select type (temp) - type is (real(kind=r4_kind)) - call lookup_es_k (temp, esloc_r4, nbad) - type is (real(kind=r8_kind)) - call lookup_es_k (temp, esloc_r8, nbad) - end select - endif - endif - - select type (temp) - type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) - type is (real(kind=r8_kind)) - esloc_r8 = esloc_r8*hc_loc - end select - - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = esloc_r4 - type is (real(kind=r8_kind)) - esat = esloc_r8 - end select - endif - - if (nbad == 0) then - select type (press) - type is (real(kind=r4_kind)) - select type (qs) - type is (real(kind=r4_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r4_kind)) - qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press - end select - endif - end select - else ! (present(q)) - denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 - if (denom_r4 > 0.0_r4_kind) then - qs = real(eps, kind=r4_kind)*esloc_r4/denom_r4 - else - qs = real(eps, kind=r4_kind) - endif - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 - end select - endif - endif ! (present(q)) - end select - type is (real(kind=r8_kind)) - select type (qs) - type is (real(kind=r8_kind)) - if (present (q) .and. use_exact_qs) then - select type (q) - type is (real(kind=r8_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r8/press - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r8/press - end select - endif - end select - else ! (present(q)) - denom_r8 = press - (1.0 - eps)*esloc_r8 - if (denom_r8 > 0.0) then - qs = eps*esloc_r8/denom_r8 - else - qs = eps - endif - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r8_kind)) - dqsdT = eps*press*desat_r8/denom_r8**2 - end select - endif - endif ! (present(q)) - end select - end select - else ! (nbad = 0) - select type (qs) - type is (real(kind=r4_kind)) - qs = -999.0_r4_kind - type is (real(kind=r8_kind)) - qs = -999. - end select - if (present (dqsdT)) then - select type (dqsdT) - type is (real(kind=r4_kind)) - dqsdT = -999.0_r4_kind - type is (real(kind=r8_kind)) - dqsdT = -999. - end select - endif - if (present (esat)) then - select type (esat) - type is (real(kind=r4_kind)) - esat = -999.0_r4_kind - type is (real(kind=r8_kind)) - esat = -999. - end select - endif - endif ! (nbad = 0) - - end subroutine compute_qs_k_0d - -!####################################################################### - -!####################################################################### - - subroutine compute_mrs_k_3d (temp, press, eps, zvir, mrs, nbad, & - mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) - - real, intent(in), dimension(:,:,:) :: temp, press - real, intent(in) :: eps, zvir - real, intent(out), dimension(:,:,:) :: mrs - integer, intent(out) :: nbad - real, intent(in), dimension(:,:,:), optional :: mr - real, intent(in), optional :: hc - real, intent(out), dimension(:,:,:), optional :: dmrsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real, dimension(size(temp,1), size(temp,2), size(temp,3)) :: & - esloc, desat, denom - integer :: i, j, k - real :: hc_loc - - if (present(hc)) then - hc_loc = hc - else - hc_loc = 1.0 - endif - - if (present (es_over_liq)) then - if (present (dmrsdT)) then - call lookup_es2_des2_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es2_k (temp, esloc, nbad) - endif - else if (present(es_over_liq_and_ice)) then - if (present (dmrsdT)) then - call lookup_es3_des3_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es3_k (temp, esloc, nbad) - endif - else - if (present (dmrsdT)) then - call lookup_es_des_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es_k (temp, esloc, nbad) - endif - endif - esloc = esloc*hc_loc - if (present (esat)) then - esat = esloc - endif - if (nbad == 0) then - if (present (mr) .and. use_exact_qs) then - mrs = (eps + mr)*esloc/press - if (present (dmrsdT)) then - dmrsdT = (eps + mr)*desat/press - endif - else ! (present (mr)) - denom = press - esloc - do k=1,size(mrs,3) - do j=1,size(mrs,2) - do i=1,size(mrs,1) - if (denom(i,j,k) > 0.0) then - mrs(i,j,k) = eps*esloc(i,j,k)/denom(i,j,k) - else - mrs(i,j,k) = eps - endif - end do - end do - end do - if (present (dmrsdT)) then - dmrsdT = eps*press*desat/denom**2 - endif - endif !(present (mr)) - else - mrs = -999. - if (present (dmrsdT)) then - dmrsdT = -999. - endif - if (present (esat)) then - esat = -999. - endif - endif - - - end subroutine compute_mrs_k_3d - -!####################################################################### - - subroutine compute_mrs_k_2d (temp, press, eps, zvir, mrs, nbad, & - mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) - - real, intent(in), dimension(:,:) :: temp, press - real, intent(in) :: eps, zvir - real, intent(out), dimension(:,:) :: mrs - integer, intent(out) :: nbad - real, intent(in), dimension(:,:), optional :: mr - real, intent(in), optional :: hc - real, intent(out), dimension(:,:), optional :: dmrsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real, dimension(size(temp,1), size(temp,2)) :: esloc, desat, denom - integer :: i, j - real :: hc_loc - - if (present(hc)) then - hc_loc = hc - else - hc_loc = 1.0 - endif - - if (present (es_over_liq)) then - if (present (dmrsdT)) then - call lookup_es2_des2_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es2_k (temp, esloc, nbad) - endif - else if (present(es_over_liq_and_ice)) then - if (present (dmrsdT)) then - call lookup_es3_des3_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es3_k (temp, esloc, nbad) - endif - else - if (present (dmrsdT)) then - call lookup_es_des_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es_k (temp, esloc, nbad) - endif - endif - esloc = esloc*hc_loc - if (present (esat)) then - esat = esloc - endif - if (nbad == 0) then - if (present (mr) .and. use_exact_qs) then - mrs = (eps + mr)*esloc/press - if (present (dmrsdT)) then - dmrsdT = (eps + mr)*desat/press - endif - else ! (present (mr)) - denom = press - esloc - do j=1,size(mrs,2) - do i=1,size(mrs,1) - if (denom(i,j) > 0.0) then - mrs(i,j) = eps*esloc(i,j)/denom(i,j) - else - mrs(i,j) = eps - endif - end do - end do - if (present (dmrsdT)) then - dmrsdT = eps*press*desat/denom**2 - endif - endif !(present (mr)) - else - mrs = -999. - if (present (dmrsdT)) then - dmrsdT = -999. - endif - if (present (esat)) then - esat = -999. - endif - endif - - - end subroutine compute_mrs_k_2d - -!####################################################################### - - subroutine compute_mrs_k_1d (temp, press, eps, zvir, mrs, nbad, & - mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) - - real, intent(in), dimension(:) :: temp, press - real, intent(in) :: eps, zvir - real, intent(out), dimension(:) :: mrs - integer, intent(out) :: nbad - real, intent(in), dimension(:), optional :: mr - real, intent(in), optional :: hc - real, intent(out), dimension(:), optional :: dmrsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real, dimension(size(temp,1)) :: esloc, desat, denom - integer :: i - real :: hc_loc - - if (present(hc)) then - hc_loc = hc - else - hc_loc = 1.0 - endif - - if (present (es_over_liq)) then - if (present (dmrsdT)) then - call lookup_es2_des2_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es2_k (temp, esloc, nbad) - endif - else if (present(es_over_liq_and_ice)) then - if (present (dmrsdT)) then - call lookup_es3_des3_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es3_k (temp, esloc, nbad) - endif - else - if (present (dmrsdT)) then - call lookup_es_des_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es_k (temp, esloc, nbad) - endif - endif - esloc = esloc*hc_loc - if (present (esat)) then - esat = esloc - endif - if (nbad == 0) then - if (present (mr) .and. use_exact_qs) then - mrs = (eps + mr)*esloc/press - if (present (dmrsdT)) then - dmrsdT = (eps + mr)*desat/press - endif - else ! (present (mr)) - denom = press - esloc - do i=1,size(mrs,1) - if (denom(i) > 0.0) then - mrs(i) = eps*esloc(i)/denom(i) - else - mrs(i) = eps - endif - end do - if (present (dmrsdT)) then - dmrsdT = eps*press*desat/denom**2 - endif - endif !(present (mr)) - else - mrs = -999. - if (present (dmrsdT)) then - dmrsdT = -999. - endif - if (present (esat)) then - esat = -999. - endif - endif - - - end subroutine compute_mrs_k_1d - -!####################################################################### - - subroutine compute_mrs_k_0d (temp, press, eps, zvir, mrs, nbad, & - mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice) - - real, intent(in) :: temp, press - real, intent(in) :: eps, zvir - real, intent(out) :: mrs - integer, intent(out) :: nbad - real, intent(in), optional :: mr - real, intent(in), optional :: hc - real, intent(out), optional :: dmrsdT, esat - logical,intent(in), optional :: es_over_liq - logical,intent(in), optional :: es_over_liq_and_ice - - real :: esloc, desat, denom - real :: hc_loc - - if (present(hc)) then - hc_loc = hc - else - hc_loc = 1.0 - endif - - if (present (es_over_liq)) then - if (present (dmrsdT)) then - call lookup_es2_des2_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es2_k (temp, esloc, nbad) - endif - else if (present(es_over_liq_and_ice)) then - if (present (dmrsdT)) then - call lookup_es3_des3_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es3_k (temp, esloc, nbad) - endif - else - if (present (dmrsdT)) then - call lookup_es_des_k (temp, esloc, desat, nbad) - desat = desat*hc_loc - else - call lookup_es_k (temp, esloc, nbad) - endif - endif - esloc = esloc*hc_loc - if (present (esat)) then - esat = esloc - endif - if (nbad == 0) then - if (present (mr) .and. use_exact_qs) then - mrs = (eps + mr)*esloc/press - if (present (dmrsdT)) then - dmrsdT = (eps + mr)*desat/press - endif - else ! (present (mr)) - denom = press - esloc - if (denom > 0.0) then - mrs = eps*esloc/denom - else - mrs = eps - endif - if (present (dmrsdT)) then - dmrsdT = eps*press*desat/denom**2 - endif - endif !(present (mr)) - else - mrs = -999. - if (present (dmrsdT)) then - dmrsdT = -999. - endif - if (present (esat)) then - esat = -999. - endif - endif - - - end subroutine compute_mrs_k_0d - - - -!####################################################################### - - subroutine lookup_es_des_k_3d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - desat(i,j,k) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - enddo - enddo - end select - end select - end select - - end subroutine lookup_es_des_k_3d - -!####################################################################### - - subroutine lookup_es_des_k_2d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - desat(i,j) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - enddo - end select - end select - end select - - end subroutine lookup_es_des_k_2d - -!####################################################################### - - subroutine lookup_es_des_k_1d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - desat(i) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - end select - end select - end select - - end subroutine lookup_es_des_k_1d - -!####################################################################### - - subroutine lookup_es_des_k_0d (temp, esat, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_es_des_k_0d - -!####################################################################### - - subroutine lookup_es_k_3d(temp, esat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - endif - enddo - enddo - enddo - end select - end select - - end subroutine lookup_es_k_3d - -!####################################################################### - - subroutine lookup_des_k_3d(temp, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - enddo - enddo - end select - end select - - end subroutine lookup_des_k_3d - -!####################################################################### - subroutine lookup_des_k_2d(temp, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - enddo - end select - end select - - end subroutine lookup_des_k_2d -!####################################################################### - subroutine lookup_es_k_2d(temp, esat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - endif - enddo - enddo - end select - end select - - end subroutine lookup_es_k_2d -!####################################################################### - subroutine lookup_des_k_1d(temp, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - endif - enddo - end select - end select - - end subroutine lookup_des_k_1d -!####################################################################### - subroutine lookup_es_k_1d(temp, esat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) - endif - enddo - end select - end select - - end subroutine lookup_es_k_1d -!####################################################################### - subroutine lookup_des_k_0d(temp, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_des_k_0d -!####################################################################### - subroutine lookup_es_k_0d(temp, esat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) ), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_es_k_0d -!####################################################################### - - subroutine lookup_es2_des2_k_3d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - desat(i,j,k) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - enddo - enddo - end select - end select - end select - - end subroutine lookup_es2_des2_k_3d - -!####################################################################### - - subroutine lookup_es2_des2_k_2d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - desat(i,j) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - enddo - end select - end select - end select - - end subroutine lookup_es2_des2_k_2d - -!####################################################################### - - subroutine lookup_es2_des2_k_1d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - desat(i) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - end select - end select - end select - - end subroutine lookup_es2_des2_k_1d - -!####################################################################### - - subroutine lookup_es2_des2_k_0d (temp, esat, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_es2_des2_k_0d - -!####################################################################### - - subroutine lookup_es2_k_3d(temp, esat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - endif - enddo - enddo - enddo - end select - end select - - end subroutine lookup_es2_k_3d - -!####################################################################### - - subroutine lookup_des2_k_3d(temp, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - enddo - enddo - end select - end select - - end subroutine lookup_des2_k_3d - !####################################################################### - subroutine lookup_des2_k_2d(temp, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - enddo - end select - end select - - end subroutine lookup_des2_k_2d -!####################################################################### - subroutine lookup_es2_k_2d(temp, esat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - endif - enddo - enddo - end select - end select - - end subroutine lookup_es2_k_2d -!####################################################################### - subroutine lookup_des2_k_1d(temp, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - endif - enddo - end select - end select - - end subroutine lookup_des2_k_1d -!####################################################################### - subroutine lookup_es2_k_1d(temp, esat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) - endif - enddo - end select - end select - - end subroutine lookup_es2_k_1d -!####################################################################### - subroutine lookup_des2_k_0d(temp, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_des2_k_0d -!####################################################################### - subroutine lookup_es2_k_0d(temp, esat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_es2_k_0d -!####################################################################### - -!####################################################################### - - subroutine lookup_es3_des3_k_3d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - desat(i,j,k) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - enddo - enddo - end select - end select - end select - - end subroutine lookup_es3_des3_k_3d - -!####################################################################### - - subroutine lookup_es3_des3_k_2d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - desat(i,j) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - enddo - end select - end select - end select - - end subroutine lookup_es3_des3_k_2d - -!####################################################################### - - subroutine lookup_es3_des3_k_1d (temp, esat, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp, esat and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - desat(i) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - end select - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - end select - end select - end select - - end subroutine lookup_es3_des3_k_1d - -!####################################################################### - - subroutine lookup_es3_des3_k_0d (temp, esat, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat, desat - integer, intent(out) :: nbad - - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_es3_des3_k_0d - !####################################################################### - subroutine lookup_es3_k_3d(temp, esat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = real(( TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - endif - enddo - enddo - enddo - end select - end select - - end subroutine lookup_es3_k_3d - -!####################################################################### - - subroutine lookup_des3_k_3d(temp, desat, nbad) - class(*), intent(in), dimension(:,:,:) :: temp - class(*), intent(out), dimension(:,:,:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j, k - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_3d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do k = 1, size(temp,3) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j,k))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - enddo - enddo - end select - end select - - end subroutine lookup_des3_k_3d - -!####################################################################### - subroutine lookup_des3_k_2d(temp, desat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - enddo - end select - end select +#include "sat_vapor_pres_k_r4.fh" +#include "sat_vapor_pres_k_r8.fh" - end subroutine lookup_des3_k_2d -!####################################################################### - subroutine lookup_es3_k_2d(temp, esat, nbad) - class(*), intent(in), dimension(:,:) :: temp - class(*), intent(out), dimension(:,:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i, j - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_2d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = temp(i,j)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = real(( TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) - endif - enddo - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do j = 1, size(temp,2) - do i = 1, size(temp,1) - tmp = real(temp(i,j))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i,j) = TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - endif - enddo - enddo - end select - end select - - end subroutine lookup_es3_k_2d -!####################################################################### - subroutine lookup_des3_k_1d(temp, desat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and desat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (desat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (desat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - endif - enddo - end select - end select - - end subroutine lookup_des3_k_1d -!####################################################################### - subroutine lookup_es3_k_1d(temp, esat, nbad) - class(*), intent(in), dimension(:) :: temp - class(*), intent(out), dimension(:) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind, i - logical :: valid_types !< For checking if variable types match - - valid_types = .false. - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - valid_types = .true. - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - valid_types = .true. - end select - end select - if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_1d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR' & - //' temp and esat types do not match', FATAL) - end if - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - select type (esat) - type is (real(kind=r4_kind)) - do i = 1, size(temp,1) - tmp = temp(i)-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) ), kind=r4_kind) - endif - enddo - end select - type is (real(kind=r8_kind)) - select type (esat) - type is (real(kind=r8_kind)) - do i = 1, size(temp,1) - tmp = real(temp(i))-tminl - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - esat(i) = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) - endif - enddo - end select - end select - - end subroutine lookup_es3_k_1d -!####################################################################### - subroutine lookup_des3_k_0d(temp, desat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: desat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (desat) - type is (real(kind=r4_kind)) - desat = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) - type is (real(kind=r8_kind)) - desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_0d',& - & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_des3_k_0d -!####################################################################### - subroutine lookup_es3_k_0d(temp, esat, nbad) - class(*), intent(in) :: temp - class(*), intent(out) :: esat - integer, intent(out) :: nbad - real :: tmp, del - integer :: ind - - nbad = 0 - - select type (temp) - type is (real(kind=r4_kind)) - tmp = temp-tminl - type is (real(kind=r8_kind)) - tmp = real(temp)-tminl - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_0d',& - & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - - ind = int(dtinvl*(tmp+tepsl)) - if (ind < 0 .or. ind >= table_siz) then - nbad = nbad+1 - else - del = tmp-dtres*real(ind) - select type (esat) - type is (real(kind=r4_kind)) - esat = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))), kind=r4_kind) - type is (real(kind=r8_kind)) - esat = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) - class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_0d',& - & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - end select - endif - - end subroutine lookup_es3_k_0d -!####################################################################### end module sat_vapor_pres_k_mod !> @} ! close documentation grouping diff --git a/test_fms/Makefile.am b/test_fms/Makefile.am index 4472863ad2..f37c4f984a 100644 --- a/test_fms/Makefile.am +++ b/test_fms/Makefile.am @@ -26,7 +26,7 @@ ACLOCAL_AMFLAGS = -I m4 # Make targets will be run in each subdirectory. Order is significant. SUBDIRS = coupler diag_manager data_override exchange monin_obukhov drifters \ mosaic interpolator fms mpp mpp_io time_interp time_manager \ -horiz_interp field_manager axis_utils affinity fms2_io parser string_utils +horiz_interp field_manager axis_utils affinity fms2_io parser string_utils sat_vapor_pres # testing utility scripts to distribute EXTRA_DIST = test-lib.sh.in intel_coverage.sh.in tap-driver.sh diff --git a/test_fms/axis_utils/Makefile.am b/test_fms/axis_utils/Makefile.am index ffaa77421d..3db495ecd6 100644 --- a/test_fms/axis_utils/Makefile.am +++ b/test_fms/axis_utils/Makefile.am @@ -29,10 +29,16 @@ AM_CPPFLAGS = -I$(MODDIR) LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. -check_PROGRAMS = test_axis_utils +check_PROGRAMS = \ + test_axis_utils_r4 \ + test_axis_utils_r8 # This is the source code for the test. -test_axis_utils_SOURCES = test_axis_utils.F90 +test_axis_utils_r4_SOURCES = test_axis_utils.F90 +test_axis_utils_r8_SOURCES = test_axis_utils.F90 + +test_axis_utils_r4_CPPFLAGS = $(AM_CPPFLAGS) -DAU_TEST_KIND_=r4_kind +test_axis_utils_r8_CPPFLAGS = $(AM_CPPFLAGS) -DAU_TEST_KIND_=r8_kind TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ diff --git a/test_fms/axis_utils/test_axis_utils.F90 b/test_fms/axis_utils/test_axis_utils.F90 index d9e9c8477f..aac74de010 100644 --- a/test_fms/axis_utils/test_axis_utils.F90 +++ b/test_fms/axis_utils/test_axis_utils.F90 @@ -19,148 +19,776 @@ program test_axis_utils -use fms_mod, only : fms_init, fms_end, check_nml_error -use mpp_mod, only : mpp_sync, mpp_pe, mpp_root_pe, mpp_error, FATAL, stdout, & - mpp_get_current_pelist, mpp_npes -use mpp_mod, only : input_nml_file -use axis_utils2_mod, only : axis_edges -use fms2_io_mod, only : open_file, close_file, write_data, register_axis, register_field, & - FmsNetcdfFile_t, register_variable_attribute -use platform_mod, only : r8_kind +use fms_mod, only : fms_init, fms_end, lowercase +use fms2_io_mod, only: FmsNetcdfFile_t, open_file, close_file, register_axis, register_field, & + & register_variable_attribute, write_data +use platform_mod, only: r4_kind, r8_kind +use mpp_mod, only: mpp_error, fatal, stderr +use fms_string_utils_mod, only: string, stringify +use axis_utils2_mod implicit none -type data_type - real(kind=r8_kind) :: var(10) !< Axis data - real(kind=r8_kind) :: var_edges(2,10) !< The boundaries of the axis data - real(kind=r8_kind) :: answers(11) !< The expected result -end type data_type +type GetAxisCartTest_t + type(FmsNetcdfFile_t) :: fileobj + type(GetAxisCartTestCase_t), pointer :: test0, test1 +end type -type(data_type) :: data_in !< Data used to create the netcdf file -integer, allocatable :: pes(:) !< List of pes -type(FmsNetcdfFile_t) :: fileobj !< FMS2_io fileobj +type GetAxisCartTestCase_t + character(:), allocatable :: var + character(1) :: cart + type(GetAxisCartTestCase_t), pointer :: next => NULL() +end type -real(kind=r8_kind) :: answers(11) !< Results obtained from the axis_edges call +integer, parameter :: k = AU_TEST_KIND_ +real(k), parameter :: pi = 4._k * atan(1._k) + +integer :: i +character(100) :: arg call fms_init -!< Get the current pelist -allocate(pes(mpp_npes())) -call mpp_get_current_pelist(pes) +do i=1,command_argument_count() + call get_command_argument(i, arg) -call set_data(data_in) -call create_input_files(data_in) + select case (arg) + case ('--get-axis-modulo') + print "(A)", "Testing get_axis_modulo" + call test_get_axis_modulo -!< Test calls to axis_edges -if ( .not. open_file(fileobj, "test_axis_utils.nc", "read", pelist=pes)) then - call mpp_error(FATAL, "Error opening test_axis_utils.nc to read") -endif - -!< Case 1: Here the variable "axis" in the file does not have the attribute "bounds" or "edges", so -!! it calculates them from the data in "axis" -answers = 0.0 -call axis_edges(fileobj, "axis", answers) -call compare_answers(answers, data_in%answers, "1") - -!< Case 2: Here the variable "axis_with_bounds" in the file has the attribute -!! "bounds", so the data is read from the variable "bounds" -answers = 0.0 -call axis_edges(fileobj, "axis_with_bounds", answers) -call compare_answers(answers, data_in%answers, "2") - -!< Case 3: Here the variable "axis_with_edges" in the file has the attribute -!"edges", so the data is read from the variable "edges" -answers = 0.0 -call axis_edges(fileobj, "axis_with_edges", answers) -call compare_answers(answers, data_in%answers, "3") - -!< Case 4: Here the flag "reproduce_null_char_bug_flag" is turned on, so the -!! edges are calculated from the data in axis because edges has a null character -!! in the end -answers = 0.0 -call axis_edges(fileobj, "axis_with_edges", answers, reproduce_null_char_bug_flag=.true.) -call compare_answers(answers, data_in%answers, "4") - -call close_file(fileobj) -deallocate(pes) + case ('--get-axis-modulo-times') + print "(A)", "Testing get_axis_modulo_times" + call test_get_axis_modulo_times + + case ('--get-axis-cart') + print "(A)", "Testing get_axis_cart" + call test_get_axis_cart + + case ('--lon-in-range') + print "(A)", "Testing lon_in_range" + call test_lon_in_range + + case ('--frac-index') + print "(A)", "Testing frac_index" + call test_frac_index + + case ('--frac-index-fail') + print "(A)", "Testing frac_index (FAILURE)" + call test_frac_index_fail + + case ('--nearest-index') + print "(A)", "Testing nearest_index" + call test_nearest_index + + case ('--nearest-index-fail') + print "(A)", "Testing nearest_index (FAILURE)" + call test_nearest_index_fail + + case ('--axis-edges') + print "(A)", "Testing axis_edges" + call test_axis_edges + + case ('--tranlon') + print "(A)", "Testing tranlon" + call test_tranlon + + case ('--interp-1d-1d') + print "(A)", "Testing interp_1d_1d" + call test_interp_1d_1d + + case ('--interp-1d-2d') + print "(A)", "Testing interp_1d_2d" + call test_interp_1d_2d + + case ('--interp-1d-3d') + print "(A)", "Testing interp_1d_3d" + call test_interp_1d_3d + + case default + write(stderr(),"(A)") "Unrecognized command line option: " // trim(arg) + end select +enddo call fms_end contains -!> @brief Compares the values of two arrays -subroutine compare_answers(answers_in, answers_expected, test_case) -real(kind=r8_kind), intent(in) :: answers_in(:) !< Answer calculated -real(kind=r8_kind), intent(in) :: answers_expected(:) !< Answer expected -character(1), intent(in) :: test_case !< String indicating the case number +! Status: TODO +! function get_axis_modulo(fileobj, axisname) +subroutine test_get_axis_modulo + type(FmsNetcdfFile_t) :: fileobj + + write(stderr(), "(A)") "Warning: get_axis_modulo unit test not yet implemented" +end subroutine -integer :: i !< For do loop +! Status: TODO +! function get_axis_modulo_times(fileobj, axisname, tbeg, tend) +subroutine test_get_axis_modulo_times + type(FmsNetcdfFile_t) :: fileobj -do i = 1, size(answers_expected,1) - if(answers_in(i) .ne. answers_expected(i)) then - print *, "i=", i, " Answer in: ", answers_in(i), " Answer expected ", answers_expected(i) - call mpp_error(FATAL, "axis_edges case"//trim(test_case)//": Answers are not correct") - endif -enddo -end subroutine compare_answers + write(stderr(), "(A)") "Warning: get_axis_modulo_times unit test not yet implemented" +end subroutine + +subroutine test_get_axis_cart + type(GetAxisCartTest_t) :: test + type(GetAxisCartTestCase_t), pointer :: test_nonexistent_var + character(:), allocatable :: var_name, attr_name, attr_value + integer :: i, j + + character(*), parameter, dimension(*) :: & + & special_axis_names_x = [character(12) :: "lon", "x", "degrees_e", "degrees_east", "degreese"], & + & special_axis_names_y = [character(13) :: "lat", "y", "degrees_n", "degrees_north", "degreesn"], & + & special_axis_names_z = [character(6) :: "depth", "height", "z", "cm", "m", "pa", "hpa"], & + & special_axis_names_t = [character(4) :: "time", "t", "sec", "min", "hou", "day", "mon", "yea"], & + & attr_names = [character(14) :: "cartesian_axis", "axis"], & + & xyzt_uc = ["X", "Y", "Z", "T"] + + call open_netcdf_w(test%fileobj) + call register_axis(test%fileobj, "dim1", 1) + + ! Check a variable which does not exist + + allocate(test_nonexistent_var) + test_nonexistent_var%var = "does_not_exist" + test_nonexistent_var%cart = "N" + + test%test0 => test_nonexistent_var + test%test1 => test_nonexistent_var + + ! Check a variable which exists, but which has neither a "cartesian_axis" nor an "axis" attribute. + var_name = "exists_no_attributes" + call get_axis_cart_test_add(test, var_name, "N") + + do i=1,size(attr_names) + attr_name = trim(attr_names(i)) + + ! Check an unknown value on a "cartesian_axis" or "axis" attribute. + ! TODO: This test fails. It should be uncommented if/when get_axis_cart's behavior is fixed. + + !attr_value = "unexpected" + !var_name = attr_name // "_attr_value_" // attr_value + !call get_axis_cart_test_add(test, var_name, "N") + !call register_variable_attribute(test%fileobj, var_name, attr_name, attr_value, str_len=len(attr_value)) + + do j=1,size(xyzt_uc) + ! Check upper-case "axis" attributes" + attr_value = xyzt_uc(j) + var_name = attr_name // "_attr_value_" // attr_value + call get_axis_cart_test_add(test, var_name, xyzt_uc(j)) + call register_variable_attribute(test%fileobj, var_name, attr_name, attr_value, str_len=len(attr_value)) + + ! Check lower-case "axis" attributes" + attr_value = lowercase(xyzt_uc(j)) + var_name = attr_name // "_attr_value_" // attr_value + call get_axis_cart_test_add(test, var_name, xyzt_uc(j)) + call register_variable_attribute(test%fileobj, var_name, attr_name, attr_value, str_len=len(attr_value)) + enddo + enddo + + call test_special_axis_names(test, special_axis_names_x, "X") + call test_special_axis_names(test, special_axis_names_y, "Y") + call test_special_axis_names(test, special_axis_names_z, "Z") + call test_special_axis_names(test, special_axis_names_t, "T") + + call close_file(test%fileobj) + + call get_axis_cart_tests_run(test) +end subroutine -!> @brief Sets the values of the data_type to be use to write the file, and to -!! compare answers -subroutine set_data(data_in) -type(data_type), intent(out) :: data_in !< data_type to set the expected values to +subroutine get_axis_cart_test_add(test, var_name, cart) + type(GetAxisCartTest_t), intent(inout) :: test + type(GetAxisCartTestCase_t), pointer :: test_case + character(*), intent(in) :: var_name + character(1), intent(in) :: cart + character(:), allocatable :: kind_str -integer :: i !< For do loop + if (k .eq. r4_kind) then + kind_str = "float" + else + kind_str = "double" + endif -do i=1,10 - data_in%var(i) = real(i, kind=r8_kind)-0.5_r8_kind + call register_field(test%fileobj, var_name, kind_str, dimensions=["dim1"]) - data_in%var_edges(1,i) = real(i-1, kind=r8_kind) - data_in%var_edges(2,i) = real(i, kind=r8_kind) + allocate(test_case) + test_case%var = var_name + test_case%cart = cart - data_in%answers(i) = real(i-1, kind=r8_kind) -enddo + test%test1%next => test_case + test%test1 => test_case +end subroutine + +subroutine get_axis_cart_tests_run(test) + type(GetAxisCartTest_t), intent(inout) :: test + type(GetAxisCartTestCase_t), pointer :: test_case, next + character(1) :: cart_test + integer :: i -data_in%answers(11) = real(10, kind=r8_kind) + call open_netcdf_r(test%fileobj) + test_case => test%test0 + + do while (associated(test_case)) + cart_test = " " + call get_axis_cart(test%fileobj, test_case%var, cart_test) + + if (cart_test .ne. test_case%cart) then + write(stderr(), "(A)") "get_axis_cart result for variable '" // test_case%var // "': " // cart_test + write(stderr(), "(A)") "Expected result: " // test_case%cart + call mpp_error(FATAL, "get_axis_cart unit test failed") + endif + + next => test_case%next + deallocate(test_case) + test_case => next + enddo + + call close_file(test%fileobj) end subroutine -!> @brief Creates a netcdf file to test the different test cases of -!!"axis_edges" -subroutine create_input_files(data_in) -type(data_type), intent(in) :: data_in !< data_type containing the values to be added to the file +subroutine test_special_axis_names(test, special_axis_names, ret_expected) + type(GetAxisCartTest_t), intent(inout) :: test + character(*), intent(in) :: special_axis_names(:), ret_expected + character(:), allocatable :: var_name + integer :: i + + do i=1,size(special_axis_names) + var_name = trim(special_axis_names(i)) + call get_axis_cart_test_add(test, var_name, ret_expected) + enddo +end subroutine + +subroutine test_lon_in_range + real(k), parameter :: eps_big = 1e-3_k, eps_tiny = 1e-5_k + real(k), parameter :: pi_plus_360 = 360._k + pi + + ! Test some cases where no translation is needed + call lon_in_range_assert(0._k, 0._k, 0._k) + call lon_in_range_assert(1._k, 0._k, 1._k) + call lon_in_range_assert(350._k, 0._k, 350._k) + call lon_in_range_assert(1._k, 1._k, 1._k) + call lon_in_range_assert(350._k, 1._k, 350._k) + call lon_in_range_assert(359._k, 0._k, 359._k) + call lon_in_range_assert(359._k, 1._k, 359._k) + call lon_in_range_assert(pi, 0._k, pi) + + ! Test up-translation + call lon_in_range_assert(-2._k, -1._k, 358._k) + call lon_in_range_assert(-2._k, 0._k, 358._k) + call lon_in_range_assert(-2._k, 5._k, 358._k) + call lon_in_range_assert(-1._k, 0._k, 359._k) + call lon_in_range_assert(-1._k, 5._k, 359._k) + call lon_in_range_assert(0._k, 5._k, 360._k) + call lon_in_range_assert(1._k, 5._k, 361._k) + call lon_in_range_assert(-pi, 0._k, 360._k - pi) + + ! Test down-translation + call lon_in_range_assert(359._k, -1._k, -1._k) + call lon_in_range_assert(360._k, -1._k, 0._k) + call lon_in_range_assert(360._k, 0._k, 0._k) + call lon_in_range_assert(361._k, -1._k, 1._k) + call lon_in_range_assert(361._k, 0._k, 1._k) + call lon_in_range_assert(362._k, -1._k, 2._k) + call lon_in_range_assert(362._k, 0._k, 2._k) + call lon_in_range_assert(pi_plus_360, 0._k, pi_plus_360 - 360._k) + + ! Test rounding behavior + call lon_in_range_assert(eps_tiny, 0._k, 0._k) + call lon_in_range_assert(eps_big, 0._k, eps_big) + call lon_in_range_assert(360._k - eps_tiny, 0._k, 0._k) + call lon_in_range_assert(360._k - eps_big, 0._k, 360._k - eps_big) +end subroutine + +subroutine lon_in_range_assert(lon, l_start, ret_expected) + real(k), intent(in) :: lon, l_start, ret_expected + real(k) :: ret_test + + ret_test = lon_in_range(lon, l_start) + + if (ret_test /= ret_expected) then + write(stderr(), "(A)") "lon_in_range(" // string(lon) // ", " // string(l_start) // & + & ") returned erroneous value: " // string(ret_test) + write(stderr(), "(A)") "Expected return value: " // string(ret_expected) + call mpp_error(FATAL, "lon_in_range unit test failed") + endif +end subroutine + +#define CALC_FRAC_INDEX_(i, v, values) real(i, k) + (v - values(i)) / (values(i + 1) - values(i)) + +subroutine test_frac_index + real(k) :: values(6), v, fi + integer :: i, n + real(k), parameter :: f10=.1_k, f25=.25_k, f50=.5_k, f99=.99_k + + values = [1._k, 2._k, 3._k, 5._k, 10._k, 11._k] + n = size(values) + + ! Test values outside of the input array + call frac_index_assert(real(values(1), k) - f50, values, -1._k) + call frac_index_assert(real(values(n), k) + f50, values, -1._k) + + ! Test the actual indices + do i=1,n + v = values(i) + call frac_index_assert(v, values, real(i, k)) + enddo + + ! Test the 10% point + do i=1,n-1 + v = values(i) + f10*(values(i+1) - values(i)) + fi = CALC_FRAC_INDEX_(i, v, values) + call frac_index_assert(v, values, fi) + enddo + + ! Test the 25% point + do i=1,n-1 + v = values(i) + f25*(values(i+1) - values(i)) + fi = CALC_FRAC_INDEX_(i, v, values) + call frac_index_assert(v, values, fi) + enddo + + ! Test the mid-point + do i=1,n-1 + v = values(i) + f50*(values(i+1) - values(i)) + fi = CALC_FRAC_INDEX_(i, v, values) + call frac_index_assert(v, values, fi) + enddo + + ! Test the 99% point + do i=1,n-1 + v = values(i) + f99*(values(i+1) - values(i)) + fi = CALC_FRAC_INDEX_(i, v, values) + call frac_index_assert(v, values, fi) + enddo +end subroutine + +subroutine frac_index_assert(fval, arr, ret_expected) + real(k), intent(in) :: fval, arr(:), ret_expected + real(k) :: ret_test + + ret_test = frac_index(fval, arr) + + if (ret_test /= ret_expected) then + write(stderr(), "(A)") "frac_index(" // string(fval) // ", " // stringify(arr) // & + & ") returned erroneous value: " // string(ret_test) + write(stderr(), "(A)") "Expected return value: " // string(ret_expected) + call mpp_error(FATAL, "frac_index unit test failed") + endif +end subroutine + +! Test that frac_index fails with a non-monotonic array +subroutine test_frac_index_fail + real(k) :: values(5) + real(k) :: ret_test + + values = [1._k, 2._k, 4._k, 3._k, 5._k] + ret_test = frac_index(1.5_k, values) +end subroutine + +subroutine test_nearest_index + real(k) :: arr(5) + + arr = [5._k, 12._k, 20._k, 40._k, 100._k] + + ! Test values beyond array boundaries + call nearest_index_assert(4._k, arr, 1) + call nearest_index_assert(1000._k, arr, size(arr)) + + ! Test values actually in the array + call nearest_index_assert(5._k, arr, 1) + call nearest_index_assert(12._k, arr, 2) + call nearest_index_assert(20._k, arr, 3) + call nearest_index_assert(40._k, arr, 4) + call nearest_index_assert(100._k, arr, 5) + + ! Test the intervals between array values + call nearest_index_assert(6._k, arr, 1) + call nearest_index_assert(11._k, arr, 2) + call nearest_index_assert(15._k, arr, 2) + call nearest_index_assert(18._k, arr, 3) + call nearest_index_assert(29._k, arr, 3) +end subroutine + +subroutine nearest_index_assert(val, arr, ret_expected) + real(k), intent(in) :: val, arr(:) + integer, intent(in) :: ret_expected + integer :: ret_test + + ret_test = nearest_index(val, arr) + + if (ret_test /= ret_expected) then + write(stderr(), "(A)") "nearest_index(" // string(val) // ", " // stringify(arr) // & + & ") returned erroneous value: " // string(ret_test) + write(stderr(), "(A)") "Expected return value: " // string(ret_expected) + call mpp_error(FATAL, "nearest_index unit test failed") + endif +end subroutine + +! Test that nearest_index fails with a non-monotonic array +subroutine test_nearest_index_fail + real(k) :: arr(5) + integer :: ret_test + + arr=[5._k, 12._k, 40._k, 20._k, 100._k] + ret_test = nearest_index(5._k, arr) +end subroutine + +subroutine test_axis_edges + real(k) :: data_in_var(10) + real(k) :: data_in_var_edges(2,10) + real(k) :: data_in_answers(11) + type(FmsNetcdfFile_t) :: fileobj + real(k) :: answers(11) + integer :: i + + do i=1,10 + data_in_var(i) = real(i, k) - 0.5_k + + data_in_var_edges(1,i) = real(i-1, k) + data_in_var_edges(2,i) = real(i, k) + + data_in_answers(i) = real(i-1, k) + enddo + + data_in_answers(11) = 10._k -type(FmsNetcdfFile_t) :: fileobj !< FMS2_io fileobj + call open_netcdf_w(fileobj) -if (mpp_pe() .eq. mpp_root_pe()) then - if ( .not. open_file(fileobj, "test_axis_utils.nc", "overwrite")) then - call mpp_error(FATAL, "Error opening test_axis_utils.nc to write") - endif + call register_axis(fileobj, "dim1", 10) + call register_axis(fileobj, "dim2", 2) - call register_axis(fileobj, "dim1", 10) - call register_axis(fileobj, "dim2", 2) + call register_field(fileobj, "axis", "double", dimensions=["dim1"]) - call register_field(fileobj, "axis", "double", dimensions=(/"dim1"/)) + call register_field(fileobj, "axis_with_bounds", "double", dimensions=["dim1"]) + call register_variable_attribute(fileobj, "axis_with_bounds", "bounds", "bounds", str_len=6) + call register_field(fileobj, "bounds", "double", dimensions=["dim2", "dim1"]) - call register_field(fileobj, "axis_with_bounds", "double", dimensions=(/"dim1"/)) - call register_variable_attribute(fileobj, "axis_with_bounds", "bounds", "bounds", str_len=6) - call register_field(fileobj, "bounds", "double", dimensions=(/"dim2", "dim1"/)) + call register_field(fileobj, "axis_with_edges", "double", dimensions=["dim1"]) + call register_variable_attribute(fileobj, "axis_with_edges", "edges", "edges"//char(0), str_len=6) + call register_field(fileobj, "edges", "double", dimensions=["dim2", "dim1"]) - call register_field(fileobj, "axis_with_edges", "double", dimensions=(/"dim1"/)) - call register_variable_attribute(fileobj, "axis_with_edges", "edges", "edges"//char(0), str_len=6) - call register_field(fileobj, "edges", "double", dimensions=(/"dim2", "dim1"/)) + call write_data(fileobj, "axis", data_in_var) + call write_data(fileobj, "axis_with_bounds", data_in_var) + call write_data(fileobj, "axis_with_edges", data_in_var) + call write_data(fileobj, "bounds", data_in_var_edges) + call write_data(fileobj, "edges", data_in_var_edges) - call write_data(fileobj, "axis", data_in%var) - call write_data(fileobj, "axis_with_bounds", data_in%var) - call write_data(fileobj, "axis_with_edges", data_in%var) - call write_data(fileobj, "bounds", data_in%var_edges) - call write_data(fileobj, "edges", data_in%var_edges) + call close_file(fileobj) - call close_file(fileobj) -endif + call open_netcdf_r(fileobj) -!< Wait for root_pe to catch up! -call mpp_sync() + !< Case 1: Here the variable "axis" in the file does not have the attribute "bounds" or "edges", so + !! it calculates them from the data in "axis" + answers = 0._k + call axis_edges(fileobj, "axis", answers) + call array_compare_1d(answers, data_in_answers, "axis_edges unit test failed (case 1)") -end subroutine create_input_files + !< Case 2: Here the variable "axis_with_bounds" in the file has the attribute + !! "bounds", so the data is read from the variable "bounds" + answers = 0._k + call axis_edges(fileobj, "axis_with_bounds", answers) + call array_compare_1d(answers, data_in_answers, "axis_edges unit test failed (case 2)") + + !< Case 3: Here the variable "axis_with_edges" in the file has the attribute + !"edges", so the data is read from the variable "edges" + answers = 0._k + call axis_edges(fileobj, "axis_with_edges", answers) + call array_compare_1d(answers, data_in_answers, "axis_edges unit test failed (case 3)") + + !< Case 4: Here the flag "reproduce_null_char_bug_flag" is turned on, so the + !! edges are calculated from the data in axis because edges has a null character + !! in the end + answers = 0._k + call axis_edges(fileobj, "axis_with_edges", answers, reproduce_null_char_bug_flag=.true.) + call array_compare_1d(answers, data_in_answers, "axis_edges unit test failed (case 4)") + + call close_file(fileobj) +end subroutine + +subroutine test_tranlon + real(k), dimension(5) :: lon1, lon2, lon3 + + lon1 = [1._k, 2._k, 3._k, 4._k, 5._k] + lon2 = [2._k, 3._k, 4._k, 5._k, 361._k] + lon3 = [3._k, 4._k, 5._k, 361._k, 362._k] + + ! The first two cases fail due to tranlon's unexpected behavior when no elements are translated. + ! TODO: Uncomment these tests if/when tranlon's behavior is fixed. + + !call tranlon_assert(lon1, lon1, 0.0_k, 1) + !call tranlon_assert(lon1, lon1, 1.0_k, 1) + + call tranlon_assert(lon1, lon2, 1.5_k, 2) + call tranlon_assert(lon1, lon2, 2.0_k, 2) + call tranlon_assert(lon1, lon3, 2.001_k, 3) +end subroutine + +subroutine tranlon_assert(lon0, lon_expected, lon_start, istrt_expected) + real(k), intent(in) :: lon0(:), lon_expected(:), lon_start + integer, intent(in) :: istrt_expected + integer :: istrt_test, i + real(k) :: lon_test(size(lon0)) + character(:), allocatable :: test_name + + test_name = "tranlon(" // stringify(lon0) // ", " // string(lon_start) // ", istrt)" + + lon_test = lon0 + call tranlon(lon_test, lon_start, istrt_test) + call array_compare_1d(lon_test, lon_expected, test_name // " unit test failed") + + if (istrt_test.ne.istrt_expected) then + write(stderr(), "(A)") test_name // " returned erroneous istrt value: " // string(istrt_test) + write(stderr(), "(A)") "Expected istrt value: " // string(istrt_expected) + call mpp_error(FATAL, "tranlon unit test failed") + endif +end subroutine + +! Status: SKELETAL +! TODO: More comprehensive interp_1d_1d test +subroutine test_interp_1d_1d + real(k) :: grid1(8), grid2(5), data1(8), data2(5) + + grid1 = [1._k, 2._k, 3._k, 4._k, 5._k, 6._k, 7._k, 8._k] + grid2 = [2._k, 3._k, 4._k, 5._k, 6._k] + data1 = [101._k, 102._k, 103._k, 104._k, 105._k, 106._k, 107._k, 108._k] + data2 = [102._k, 103._k, 104._k, 105._k, 106._k] + + call interp_1d_1d_assert(grid1, grid2, data1, data2, "linear") + call interp_1d_1d_assert(grid1, grid2, data1, data2, "cubic_spline") +end subroutine + +subroutine interp_1d_1d_assert(grid1, grid2, data1, data2_expected, method, yp1, yp2) + real(k), intent(in), dimension(:) :: grid1, grid2, data1, data2_expected + character(*), intent(in), optional :: method + real(k), intent(in), optional :: yp1, yp2 + real(k) :: data2_test(size(data2_expected)) + character(:), allocatable :: test_name + + test_name = "interp_1d_1d(" // & + stringify(grid1) // ", " // & + stringify(grid2) // ", " // & + stringify(data1) // ", data2" + + if (present(method)) then + test_name = test_name // ", method=" // method + endif + + if (present(yp1)) then + test_name = test_name // ", yp1=" // string(yp1) + endif + + if (present(yp2)) then + test_name = test_name // ", yp2=" // string(yp2) + endif + + test_name = test_name // ")" + + call interp_1d(grid1, grid2, data1, data2_test, method, yp1, yp2) + call array_compare_1d(data2_test, data2_expected, test_name // " unit test failed") +end subroutine + +! Status: SKELETAL +! TODO: More comprehensive interp_1d_2d test +subroutine test_interp_1d_2d + real(k) :: grid1(2,4), grid2(2,2), data1(2,4), data2(2,2) + + grid1(1,:) = [1._k, 2._k, 3._k, 4._k] + grid1(2,:) = [5._k, 6._k, 7._k, 8._k] + + grid2(1,:) = [2._k, 3._k] + grid2(2,:) = [6._k, 7._k] + + data1(1,:) = [101._k, 102._k, 103._k, 104._k] + data1(2,:) = [105._k, 106._k, 107._k, 108._k] + + data2(1,:) = [102._k, 103._k] + data2(2,:) = [106._k, 107._k] + + call interp_1d_2d_assert(grid1, grid2, data1, data2) +end subroutine + +subroutine interp_1d_2d_assert(grid1, grid2, data1, data2_expected) + real(k), intent(in), dimension(:,:) :: grid1, grid2, data1, data2_expected + real(k) :: data2_test(size(data2_expected,1), size(data2_expected,2)) + character(:), allocatable :: test_name + + test_name = "interp_1d_2d(" // & + stringify(grid1) // ", " // & + stringify(grid2) // ", " // & + stringify(data1) // ", data2)" + + call interp_1d(grid1, grid2, data1, data2_test) + call array_compare_2d(data2_test, data2_expected, test_name // " unit test failed") +end subroutine + +! Status: SKELETAL +! TODO: More comprehensive interp_1d_3d test +subroutine test_interp_1d_3d + real(k) :: grid1(2,2,4), grid2(2,2,2), data1(2,2,4), data2(2,2,2) + + grid1(1,1,:) = [1._k, 2._k, 3._k, 4._k] + grid1(1,2,:) = [5._k, 6._k, 7._k, 8._k] + grid1(2,1,:) = [21._k, 22._k, 23._k, 24._k] + grid1(2,2,:) = [25._k, 26._k, 27._k, 28._k] + + grid2(1,1,:) = [2._k, 3._k] + grid2(1,2,:) = [6._k, 7._k] + grid2(2,1,:) = [22._k, 23._k] + grid2(2,2,:) = [26._k, 27._k] + + data1(1,1,:) = [101._k, 102._k, 103._k, 104._k] + data1(1,2,:) = [105._k, 106._k, 107._k, 108._k] + data1(2,1,:) = [201._k, 202._k, 203._k, 204._k] + data1(2,2,:) = [205._k, 206._k, 207._k, 208._k] + + data2(1,1,:) = [102._k, 103._k] + data2(1,2,:) = [106._k, 107._k] + data2(2,1,:) = [202._k, 203._k] + data2(2,2,:) = [206._k, 207._k] + + call interp_1d_3d_assert(grid1, grid2, data1, data2) + call interp_1d_3d_assert(grid1, grid2, data1, data2, "linear") + call interp_1d_3d_assert(grid1, grid2, data1, data2, "cubic_spline") +end subroutine + +subroutine interp_1d_3d_assert(grid1, grid2, data1, data2_expected, method, yp1, yp2) + real(k), intent(in), dimension(:,:,:) :: grid1, grid2, data1, data2_expected + character(*), intent(in), optional :: method + real(k), intent(in), optional :: yp1, yp2 + real(k) :: data2_test(size(data2_expected,1), size(data2_expected,2), size(data2_expected,3)) + integer :: i,i2,i3 + character(:), allocatable :: test_name + + test_name = "interp_1d_3d(" // & + stringify(grid1) // ", " // & + stringify(grid2) // ", " // & + stringify(data1) // ", data2" + + if (present(method)) then + test_name = test_name // ", method=" // method + endif + + if (present(yp1)) then + test_name = test_name // ", yp1=" // string(yp1) + endif + + if (present(yp2)) then + test_name = test_name // ", yp2=" // string(yp2) + endif + + test_name = test_name // ")" + + call interp_1d(grid1, grid2, data1, data2_test, method, yp1, yp2) + call array_compare_3d(data2_test, data2_expected, test_name // " unit test failed") +end subroutine + +! +! Supporting utilities +! + +subroutine open_netcdf_w(fileobj) + type(FmsNetcdfFile_t), intent(out) :: fileobj + + if (.not.open_file(fileobj, "test_axis_utils.nc", "overwrite")) then + call mpp_error(FATAL, "Error opening test_axis_utils.nc to write") + endif +end subroutine + +subroutine open_netcdf_r(fileobj) + type(FmsNetcdfFile_t), intent(out) :: fileobj + + if (.not.open_file(fileobj, "test_axis_utils.nc", "read")) then + call mpp_error(FATAL, "Error opening test_axis_utils.nc to read") + endif +end subroutine + +subroutine array_compare_1d(arr1, arr2, msg) + real(k), intent(in), dimension(:) :: arr1, arr2 + character(*), intent(in) :: msg + integer :: i, m, n + + m = size(arr1) + n = size(arr2) + + if (m.ne.n) then + write(stderr(), "(A)") "1D array comparison failed due to incompatible array sizes" + write(stderr(), "(A)") "Array 1 has size " // string(m) // " and array 2 has size " // string(n) + call mpp_error(FATAL, msg) + endif + + do i=1,m + if (arr1(i).ne.arr2(i)) then + write(stderr(), "(A)") "1D array comparison failed due to element " // string(i) + write(stderr(), "(A)") "Array 1 has value " // string(arr1(i)) // & + & " and array 2 has value " // string(arr2(i)) + call mpp_error(FATAL, msg) + endif + enddo +end subroutine + +subroutine array_compare_2d(arr1, arr2, msg) + real(k), intent(in), dimension(:,:) :: arr1, arr2 + character(*), intent(in) :: msg + integer :: i1, i2, m1, m2, n1, n2 + + m1 = size(arr1, 1) + m2 = size(arr1, 2) + + n1 = size(arr2, 1) + n2 = size(arr2, 2) + + if (m1.ne.n1 .or. m2.ne.n2) then + write(stderr(), "(A)") "2D array comparison failed due to incompatible array sizes" + write(stderr(), "(A)") "Array 1 has size " // string(m1) // "x" // string(m2) // & + & " and array 2 has size " // string(n1) // "x" // string(n2) + call mpp_error(FATAL, msg) + endif + + do i2=1,m2 + do i1=1,m1 + if (arr1(i1,i2).ne.arr2(i1,i2)) then + write(stderr(), "(A)") "2D array comparison failed due to element " // string(i1) // "," // string(i2) + write(stderr(), "(A)") "Array 1 has value " // string(arr1(i1,i2)) // & + & " and array 2 has value " // string(arr2(i1,i2)) + call mpp_error(FATAL, msg) + endif + enddo + enddo +end subroutine + +subroutine array_compare_3d(arr1, arr2, msg) + real(k), intent(in), dimension(:,:,:) :: arr1, arr2 + character(*), intent(in) :: msg + integer :: i1, i2, i3, m1, m2, m3, n1, n2, n3 + + m1 = size(arr1, 1) + m2 = size(arr1, 2) + m3 = size(arr1, 3) + + n1 = size(arr2, 1) + n2 = size(arr2, 2) + n3 = size(arr2, 3) + + if (m1.ne.n1 .or. m2.ne.n2 .or. m3.ne.n3) then + write(stderr(), "(A)") "3D array comparison failed due to incompatible array sizes" + write(stderr(), "(A)") "Array 1 has size " // string(m1) // "x" // string(m2) // "x" // string(m3) // & + & " and array 2 has size " // string(n1) // "x" // string(n2) // "x" // string(n3) + call mpp_error(FATAL, msg) + endif + + do i3=1,m3 + do i2=1,m2 + do i1=1,m1 + if (arr1(i1,i2,i3).ne.arr2(i1,i2,i3)) then + write(stderr(), "(A)") "3D array comparison failed due to element " // & + & string(i1) // "," // string(i2) // "," // string(i3) + write(stderr(), "(A)") "Array 1 has value " // string(arr1(i1,i2,i3)) // & + & " and array 2 has value " // string(arr2(i1,i2,i3)) + call mpp_error(FATAL, msg) + endif + enddo + enddo + enddo +end subroutine end program test_axis_utils diff --git a/test_fms/axis_utils/test_axis_utils2.sh b/test_fms/axis_utils/test_axis_utils2.sh index f06e39ff6a..1288822481 100755 --- a/test_fms/axis_utils/test_axis_utils2.sh +++ b/test_fms/axis_utils/test_axis_utils2.sh @@ -27,9 +27,30 @@ # Prepare the directory to run the tests. touch input.nml -# Run the test. -test_expect_success "Test AXIS utils" ' - mpirun -n 2 ./test_axis_utils -' +TESTS_SUCCESS='--get-axis-modulo --get-axis-modulo-times --get-axis-cart --lon-in-range --frac-index --nearest-index --axis-edges --tranlon --interp-1d-1d --interp-1d-2d --interp-1d-3d' +TESTS_FAIL='--frac-index-fail --nearest-index-fail' + +# TODO: Enable these tests after tranlon's memory corruption bug is fixed. +SKIP_TESTS="test_axis_utils2.15 test_axis_utils2.16" + +# Run the tests + +for t in $TESTS_SUCCESS +do + r4cmd="./test_axis_utils_r4 $t" + r8cmd="./test_axis_utils_r8 $t" + + test_expect_success "Testing axis utils: $r4cmd" "mpirun -n 1 $r4cmd" + test_expect_success "Testing axis utils: $r8cmd" "mpirun -n 1 $r8cmd" +done + +for t in $TESTS_FAIL +do + r4cmd="./test_axis_utils_r4 $t" + r8cmd="./test_axis_utils_r8 $t" + + test_expect_failure "Testing axis utils: $r4cmd" "mpirun -n 1 $r4cmd" + test_expect_failure "Testing axis utils: $r8cmd" "mpirun -n 1 $r8cmd" +done test_done diff --git a/test_fms/fms/Makefile.am b/test_fms/fms/Makefile.am index 80e7a06264..f1ceef9ed9 100644 --- a/test_fms/fms/Makefile.am +++ b/test_fms/fms/Makefile.am @@ -23,7 +23,7 @@ # uramirez, Ed Hartnett # Find the fms_mod.mod file. -AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/test_fms/fms/include -I$(MODDIR) # Link to the FMS library. LDADD = $(top_builddir)/libFMS/libFMS.la @@ -32,7 +32,12 @@ LDADD = $(top_builddir)/libFMS/libFMS.la check_PROGRAMS = test_fms # These are the sources for the tests. -test_fms_SOURCES = test_fmsC.c test_fms.F90 +test_fms_SOURCES = \ + test_fmsC.c \ + test_fms.F90 \ + include/test_fms.inc \ + include/test_fms_r4.fh \ + include/test_fms_r8.fh TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ diff --git a/test_fms/fms/include/test_fms.inc b/test_fms/fms/include/test_fms.inc new file mode 100644 index 0000000000..388a9279c3 --- /dev/null +++ b/test_fms/fms/include/test_fms.inc @@ -0,0 +1,111 @@ +subroutine TEST_MONOTONIC_ARRAY_ + integer, parameter :: k = FMS_MOD_TEST_KIND_ + real(FMS_MOD_TEST_KIND_) :: arr1(1), arr2(2), arr5(5) + + ! monotonic_array should return false when size=1 + + arr1 = [1._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr1, .false.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr1, .false., 0) + + arr1 = [-1._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr1, .false.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr1, .false., 0) + + ! size=2, increasing + arr2 = [-1._k, 1._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true., 1) + + ! size=2, decreasing + arr2 = [1._k, -1._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true., -1) + + ! size=2, very large numbers, increasing + arr2 = [1e10_k, 1e20_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true., 1) + + ! size=2, very large numbers, decreasing + arr2 = [1e10_k, 1e-20_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr2, .true., -1) + + ! Monotonically increasing, size=5 + arr5 = [-2._k, -1._k, 0._k, 1._k, 2._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true., 1) + + ! Monotonically decreasing, size=5 + arr5 = [2._k, 1._k, 0._k, -1._k, -2._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true., -1) + + ! Non-monotonic array, size=5 + arr5 = [1._k, 2._k, 3._k, 4._k, -5._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false., 0) + + ! Another permutation of non-monotonic array, size=5 + arr5 = [-5._k, 4._k, 3._k, 2._k, 1._k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false., 0) + + ! Monotonically increasing, size=5, small numbers + arr5 = [1e-8_k, 1e-6_k, 1e-4_k, 1e-2_k, 1e0_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true., 1) + + ! Monotonically decreasing, size=5, small numbers + arr5 = [1e0_k, 1e-2_k, 1e-4_k, 1e-6_k, 1e-8_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true., -1) + + ! Non-monotonic array, size=5, small numbers + arr5 = [1e0_k, 1e-8_k, 1e-2_k, 1e-4_k, 1e-6_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false., 0) + + ! Monotonically increasing, size=5, positive large numbers + arr5 = [1e10_k, 1e20_k, 1e30_k, 1e35_k, 9.99e37_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true., 1) + + ! Monotonically decreasing, size=5, negative large numbers + arr5 = [-1e10_k, -1e20_k, -1e30_k, -1e35_k, -9.99e37_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .true., -1) + + ! Non-monotonic array, size=5, negative large numbers + arr5 = [-1e10_k, -1e20_k, -1e30_k, -9.99e37_k, -1e30_k] + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false.) + call TEST_MONOTONIC_ARRAY_ASSERT_(arr5, .false., 0) +end subroutine + +subroutine TEST_MONOTONIC_ARRAY_ASSERT_(arr, monotonic_expected, direction_expected) + real(FMS_MOD_TEST_KIND_), intent(in) :: arr(:) + logical, intent(in) :: monotonic_expected + integer, intent(in), optional :: direction_expected + integer :: direction_test + logical :: monotonic_test + + if (present(direction_expected)) then + monotonic_test = monotonic_array(arr, direction_test) + if (direction_test .ne. direction_expected) then + write(stderr(), "(A)") "monotonic_array(" // stringify(arr) // & + & ", direction) returned incorrect direction: " // string(direction_test) + write(stderr(), "(A)") "Expected direction: " // string(direction_expected) + call mpp_error(FATAL, "monotonic_array unit test failed") + endif + else + monotonic_test = monotonic_array(arr) + endif + + if (monotonic_test .neqv. monotonic_expected) then + write(stderr(), "(A)") "monotonic_array(" // stringify(arr) // & + & ") returned incorrect value: " // string(monotonic_test) + write(stderr(), "(A)") "Expected return value: " // string(monotonic_expected) + call mpp_error(FATAL, "monotonic_array unit test failed") + endif +end subroutine diff --git a/test_fms/fms/include/test_fms_r4.fh b/test_fms/fms/include/test_fms_r4.fh new file mode 100644 index 0000000000..92649727af --- /dev/null +++ b/test_fms/fms/include/test_fms_r4.fh @@ -0,0 +1,13 @@ +#undef FMS_MOD_TEST_KIND_ +#undef TEST_MONOTONIC_ARRAY_ +#undef TEST_MONOTONIC_ARRAY_ASSERT_ + +#define FMS_MOD_TEST_KIND_ r4_kind +#define TEST_MONOTONIC_ARRAY_ test_monotonic_array_r4 +#define TEST_MONOTONIC_ARRAY_ASSERT_ test_monotonic_array_assert_r4 + +#include "test_fms.inc" + +#undef FMS_MOD_TEST_KIND_ +#undef TEST_MONOTONIC_ARRAY_ +#undef TEST_MONOTONIC_ARRAY_ASSERT_ diff --git a/test_fms/fms/include/test_fms_r8.fh b/test_fms/fms/include/test_fms_r8.fh new file mode 100644 index 0000000000..170cebca85 --- /dev/null +++ b/test_fms/fms/include/test_fms_r8.fh @@ -0,0 +1,13 @@ +#undef FMS_MOD_TEST_KIND_ +#undef TEST_MONOTONIC_ARRAY_ +#undef TEST_MONOTONIC_ARRAY_ASSERT_ + +#define FMS_MOD_TEST_KIND_ r8_kind +#define TEST_MONOTONIC_ARRAY_ test_monotonic_array_r8 +#define TEST_MONOTONIC_ARRAY_ASSERT_ test_monotonic_array_assert_r8 + +#include "test_fms.inc" + +#undef FMS_MOD_TEST_KIND_ +#undef TEST_MONOTONIC_ARRAY_ +#undef TEST_MONOTONIC_ARRAY_ASSERT_ diff --git a/test_fms/fms/test_fms.F90 b/test_fms/fms/test_fms.F90 index 24918e849e..faffd998eb 100644 --- a/test_fms/fms/test_fms.F90 +++ b/test_fms/fms/test_fms.F90 @@ -11,10 +11,13 @@ end function strPoint end module test_fms_mod program test_fms - use mpp_mod, only : mpp_error, fatal, note, mpp_init - use fms_mod, only : fms_init, string, fms_end + use mpp_mod, only : mpp_error, fatal, note, mpp_init, stderr + use fms_mod, only : fms_init, fms_end use fms_mod, only : fms_c2f_string use fms_mod, only : fms_cstring2cpointer + use fms_mod, only : monotonic_array + use platform_mod, only : r4_kind, r8_kind + use fms_string_utils_mod, only : string, stringify use test_fms_mod use, intrinsic :: iso_c_binding @@ -69,9 +72,14 @@ program test_fms call mpp_error(FATAL, trim(test)//" does not match "//trim(answer)) endif + call test_monotonic_array_r4 + call test_monotonic_array_r8 + call fms_end() +contains - call fms_end() +#include "test_fms_r4.fh" +#include "test_fms_r8.fh" end program test_fms diff --git a/test_fms/horiz_interp/Makefile.am b/test_fms/horiz_interp/Makefile.am index 038549a87e..812ab6cccb 100644 --- a/test_fms/horiz_interp/Makefile.am +++ b/test_fms/horiz_interp/Makefile.am @@ -29,10 +29,14 @@ AM_CPPFLAGS = -I$(MODDIR) LDADD = $(top_builddir)/libFMS/libFMS.la # Build these test programs. -check_PROGRAMS = test_horiz_interp +check_PROGRAMS = test_horiz_interp_r4 test_horiz_interp_r8 # These are the sources for the tests. -test_horiz_interp_SOURCES = test_horiz_interp.F90 +test_horiz_interp_r4_SOURCES = test_horiz_interp.F90 +test_horiz_interp_r8_SOURCES = test_horiz_interp.F90 + +test_horiz_interp_r4_CPPFLAGS=-DHI_TEST_KIND=4 -I$(MODDIR) +test_horiz_interp_r8_CPPFLAGS=-DHI_TEST_KIND=8 -I$(MODDIR) TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ diff --git a/test_fms/horiz_interp/test_horiz_interp.F90 b/test_fms/horiz_interp/test_horiz_interp.F90 index 34f8e76aed..c4e333b786 100644 --- a/test_fms/horiz_interp/test_horiz_interp.F90 +++ b/test_fms/horiz_interp/test_horiz_interp.F90 @@ -16,45 +16,56 @@ !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** +!> @author Ryan Mulhall 2023 +!> Original test is in test_conserve, modified to test the other 3 interp_method option and mixed precision reals +!! tests are split up by interp_method (same way the modules are broken up) and enabled via the nml flags. +!! Assignment test checks that the override is copying the data type properly +!! TODO some larger tests with different data sets + +!! defaults to 8 real kind, make check will compile with both 4 and 8 +#ifndef HI_TEST_KIND_ +#define HI_TEST_KIND_ 8 +#endif program horiz_interp_test -use mpp_mod, only : mpp_init, mpp_exit, mpp_error, FATAL, stdout, mpp_npes +use mpp_mod, only : mpp_init, mpp_exit, mpp_error, FATAL, stdout, mpp_npes, WARNING use mpp_mod, only : mpp_clock_id, mpp_clock_begin, mpp_clock_end use mpp_mod, only : mpp_pe, mpp_root_pe, NOTE, MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED -use mpp_mod, only : input_nml_file +use mpp_mod, only : input_nml_file, mpp_sync use mpp_domains_mod, only : mpp_define_layout, mpp_define_domains, mpp_get_compute_domain use mpp_domains_mod, only : mpp_domains_init, domain2d use fms_mod, only : check_nml_error, fms_init use horiz_interp_mod, only : horiz_interp_init, horiz_interp_new, horiz_interp_del use horiz_interp_mod, only : horiz_interp, horiz_interp_type +use horiz_interp_spherical_mod, only: horiz_interp_spherical_wght +use horiz_interp_type_mod, only: SPHERICA use constants_mod, only : constants_init, PI +use platform_mod implicit none + logical :: test_conserve = .false. , test_bicubic = .false. , test_spherical =.false. , test_bilinear =.false. + logical :: test_assign = .false. + logical :: test_solo = .false.!< test with the 'solo' wrappers that hide the _new and _del calls for the derived type integer :: ni_src = 360, nj_src = 180 integer :: ni_dst = 144, nj_dst = 72 + integer, parameter :: max_neighbors = 400 !! took this from spherical mod + !! max amount found neighbors to loop through in spherical search + - namelist /test_horiz_interp_nml/ ni_src, nj_src, ni_dst, nj_dst + namelist /test_horiz_interp_nml/ test_conserve, test_bicubic, test_spherical, test_bilinear, test_assign, test_solo,& + ni_src, nj_src, ni_dst,nj_dst - real :: lon_src_beg = 0, lon_src_end = 360 - real :: lat_src_beg = -90, lat_src_end = 90 - real :: lon_dst_beg = -280, lon_dst_end = 80 - real :: lat_dst_beg = -90, lat_dst_end = 90 - real :: D2R = PI/180. - real, parameter :: SMALL = 1.0e-10 type(domain2d) :: domain - type(horiz_interp_type) :: Interp integer :: id1, id2, id3, id4 integer :: isc, iec, jsc, jec, i, j integer :: io, ierr, layout(2) - real :: dlon_src, dlat_src, dlon_dst, dlat_dst - real, allocatable, dimension(:) :: lon1D_src, lat1D_src, lon1D_dst, lat1D_dst - real, allocatable, dimension(:,:) :: lon2D_src, lat2D_src, lon2D_dst, lat2D_dst - real, allocatable, dimension(:,:) :: data_src, data1_dst, data2_dst, data3_dst, data4_dst + integer, parameter :: lkind = HI_TEST_KIND_ call fms_init + call mpp_init call constants_init call horiz_interp_init @@ -71,142 +82,1312 @@ program horiz_interp_test ! (0:360,-90:90) with grid size ni_src, nj_src ( default 360X180). and the destination ! is the region (-280:80, -90:90) with grid size ni_dstXnj_dst( default 144X72). ! integer checksum and global sum will be printed out for both the 1D and 2D version. - - allocate(lon2D_src(ni_src+1, nj_src+1), lat2D_src(ni_src+1, nj_src+1) ) - allocate(lon1D_src(ni_src+1), lat1D_src(nj_src+1), data_src(ni_src, nj_src) ) - - allocate(lon2D_dst(isc:iec+1, jsc:jec+1), lat2D_dst(isc:iec+1, jsc:jec+1) ) - allocate(lon1D_dst(isc:iec+1), lat1D_dst(jsc:jec+1) ) - allocate(data1_dst(isc:iec, jsc:jec), data2_dst(isc:iec, jsc:jec) ) - allocate(data3_dst(isc:iec, jsc:jec), data4_dst(isc:iec, jsc:jec) ) - - ! set up longitude and latitude of source/destination grid. - dlon_src = (lon_src_end-lon_src_beg)/ni_src - dlat_src = (lat_src_end-lat_src_beg)/nj_src - dlon_dst = (lon_dst_end-lon_dst_beg)/ni_dst - dlat_dst = (lat_dst_end-lat_dst_beg)/nj_dst - - do i = 1, ni_src+1 - lon1D_src(i) = lon_src_beg + (i-1)*dlon_src - end do - - do j = 1, nj_src+1 - lat1D_src(j) = lat_src_beg + (j-1)*dlat_src - end do - - do i = isc, iec+1 - lon1D_dst(i) = lon_dst_beg + (i-1)*dlon_dst - end do - - do j = jsc, jec+1 - lat1D_dst(j) = lat_dst_beg + (j-1)*dlat_dst - end do - - ! scale grid to radians. - lon1D_src = lon1D_src * D2R - lat1D_src = lat1D_src * D2R - lon1D_dst = lon1D_dst * D2R - lat1D_dst = lat1D_dst * D2R - - do i = 1, ni_src+1 - lon2D_src(i,:) = lon1D_src(i) - end do - - do j = 1, nj_src+1 - lat2D_src(:,j) = lat1D_src(j) - end do - - do i = isc, iec+1 - lon2D_dst(i,:) = lon1D_dst(i) - end do - - do j = jsc, jec+1 - lat2D_dst(:,j) = lat1D_dst(j) - end do - - !--- set up the source data - do j = 1, nj_src - do i = 1, ni_src - data_src(i,j) = i + j*0.001 - end do - end do - - id1 = mpp_clock_id( 'horiz_interp_1dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - id2 = mpp_clock_id( 'horiz_interp_1dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - id3 = mpp_clock_id( 'horiz_interp_2dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - id4 = mpp_clock_id( 'horiz_interp_2dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - - ! --- 1dx1d version conservative interpolation - call mpp_clock_begin(id1) - call horiz_interp_new(Interp, lon1D_src, lat1D_src, lon1D_dst, lat1D_dst, interp_method = "conservative") - call horiz_interp(Interp, data_src, data1_dst) - call horiz_interp_del(Interp) - call mpp_clock_end(id1) - - ! --- 1dx2d version conservative interpolation - call mpp_clock_begin(id2) - call horiz_interp_new(Interp, lon1D_src, lat1D_src, lon2D_dst, lat2D_dst, interp_method = "conservative") - call horiz_interp(Interp, data_src, data2_dst) - call horiz_interp_del(Interp) - call mpp_clock_end(id2) - - ! --- 2dx1d version conservative interpolation - call mpp_clock_begin(id3) - call horiz_interp_new(Interp, lon2D_src, lat2D_src, lon1D_dst, lat1D_dst, interp_method = "conservative") - call horiz_interp(Interp, data_src, data3_dst) - call horiz_interp_del(Interp) - call mpp_clock_end(id3) - - ! --- 2dx2d version conservative interpolation - call mpp_clock_begin(id4) - call horiz_interp_new(Interp, lon2D_src, lat2D_src, lon2D_dst, lat2D_dst, interp_method = "conservative") - call horiz_interp(Interp, data_src, data4_dst) - call horiz_interp_del(Interp) - call mpp_clock_end(id4) - - !--- compare the data after interpolation between 1-D and 2-D version interpolation - do j = jsc, jsc - do i = isc, iec - - if( abs(data1_dst(i,j)-data2_dst(i,j)) > SMALL ) then - print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), & - ", data2 = ", data2_dst(i,j), ", data1-data2 = ", data1_dst(i,j) - data2_dst(i,j) - call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data2_dst") - end if - end do - end do - - if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE, & - "The test that verify 1dx2d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") - - do j = jsc, jsc - do i = isc, iec - - if( abs(data1_dst(i,j)-data3_dst(i,j)) > SMALL ) then - print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), & - ", data2 = ", data3_dst(i,j), ", data1-data2 = ", data1_dst(i,j) - data3_dst(i,j) - call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data3_dst") - end if - end do - end do - - if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE, & - "The test that verify 2dx1d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") - - do j = jsc, jsc - do i = isc, iec - - if( abs(data1_dst(i,j)-data4_dst(i,j)) > SMALL ) then - print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), & - ", data2 = ", data4_dst(i,j), ", data1-data2 = ", data1_dst(i,j) - data4_dst(i,j) - call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data4_dst") - end if - end do - end do - - if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE, & - "The test that verify 2dx2d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") + if (test_conserve) then + call test_horiz_interp_conserve + else if(test_bicubic) then + call test_horiz_interp_bicubic + else if(test_bilinear) then + call test_horiz_interp_bilinear + else if(test_spherical) then + call test_horiz_interp_spherical + else if(test_assign) then + call test_assignment + else + call mpp_error(FATAL, "test_horiz_interp: no unit test enabled in namelist") + endif call mpp_exit + contains + + !> Tests spherical module interpolation with each dimension conversion + !! test without passing in the type when test_solo is true + !! The spherical module has a nml option for whether using a full or radially bounded search + !! for finding the nearest points and distances so this gets run for both + subroutine test_horiz_interp_spherical + !! grid data + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_in_2D, lon_in_2D + type(horiz_interp_type) :: interp_t + !! input data + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: data_src, data_dst + !! output data + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_out_2D, lon_out_2D + real(HI_TEST_KIND_), allocatable, dimension(:,:,:) :: wghts + !! array sizes and number of lat/lon per index + real(HI_TEST_KIND_) :: dlon_src, dlat_src, dlon_dst, dlat_dst + !! parameters for lon/lat setup + real(HI_TEST_KIND_) :: lon_src_beg = 0._lkind, lon_src_end = 360._lkind + real(HI_TEST_KIND_) :: lat_src_beg = -90._lkind, lat_src_end = 90._lkind + real(HI_TEST_KIND_) :: lon_dst_beg = -280._lkind, lon_dst_end = 80._lkind + real(HI_TEST_KIND_) :: lat_dst_beg = -90._lkind, lat_dst_end = 90._lkind + real(HI_TEST_KIND_) :: D2R = real(PI,HI_TEST_KIND_)/180._lkind + real(HI_TEST_KIND_) :: R2D = 180._lkind/real(PI,HI_TEST_KIND_) + real(HI_TEST_KIND_), parameter :: SMALL = 1.0e-10_lkind + + ! set up longitude and latitude of source/destination grid. + dlon_src = (lon_src_end-lon_src_beg)/real(ni_src, HI_TEST_KIND_) + dlat_src = (lat_src_end-lat_src_beg)/real(nj_src, HI_TEST_KIND_) + dlon_dst = (lon_dst_end-lon_dst_beg)/real(ni_dst, HI_TEST_KIND_) + dlat_dst = (lat_dst_end-lat_dst_beg)/real(nj_dst, HI_TEST_KIND_) + + ! set up 2d lon/lat + allocate(lon_in_2D(ni_src, nj_src), lat_in_2D(ni_src, nj_src)) + do i = 1, ni_src + lon_in_2D(i,:) = lon_src_beg + real(i-1, HI_TEST_KIND_)*dlon_src + end do + do j = 1, nj_src + lat_in_2D(:,j) = lat_src_beg + real(j-1, HI_TEST_KIND_)*dlat_src + end do + allocate(lon_out_2D(ni_dst, nj_dst), lat_out_2D(ni_dst, nj_dst)) + do i = 1, ni_dst + lon_out_2D(i,:) = lon_dst_beg + real(i-1, HI_TEST_KIND_)*dlon_dst + end do + do j = 1, nj_dst + lat_out_2D(:,j) = lat_src_beg + real(j-1, HI_TEST_KIND_)*dlat_dst + end do + + ! scale to radians + lat_in_2D = lat_in_2D * D2R + lon_in_2D = lon_in_2D * D2R + lat_out_2D = lat_out_2D * D2R + lon_out_2D = lon_out_2D * D2R + + + allocate(data_src(ni_src, nj_src)) + allocate(data_dst(ni_dst, nj_dst)) + allocate(wghts(ni_dst, nj_dst, max_neighbors)) + data_dst = 0.0_lkind ; data_src = 1.0_lkind + + id1 = mpp_clock_id( 'horiz_interp_spherical_2dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + + ! 2D x 2D (only one supported for spherical) + call mpp_clock_begin(id1) + if(.not. test_solo) then + call horiz_interp_new(interp_t, lon_in_2d, lat_in_2d, lon_out_2d, lon_out_2d, interp_method="spherical") + call horiz_interp(interp_t, data_src, data_dst) + call horiz_interp_spherical_wght(interp_t, wghts, verbose=1) + else + call horiz_interp(data_src, lon_in_2D, lat_in_2D, lon_out_2D, lat_out_2D, data_dst, interp_method="spherical") + endif + call mpp_clock_end(id1) + do i=1, ni_dst-1 + do j=1, nj_dst-1 + if(data_dst(i,j) - 1.0_lkind .gt. SMALL) then + print *, 'data_dst(i=', i, ', j=', j, ')=', data_dst(i,j), ' Expected value: 1.0' + call mpp_error(FATAL, "test_horiz_interp_spherical: "// & + "invalid output data after interpolation") + endif + enddo + enddo + if(.not. test_solo) then + call horiz_interp_del(interp_t) + call check_dealloc(interp_t) + endif + deallocate(data_src, data_dst) + deallocate(lat_in_2D, lon_in_2D) + deallocate(lat_out_2D, lon_out_2D) + + end subroutine + + !> Tests bilinear module interpolation with each dimension conversion + !! test without passing in the type when test_solo is true + subroutine test_horiz_interp_bilinear + real(HI_TEST_KIND_) :: dlon_src, dlat_src, dlon_dst, dlat_dst + real(HI_TEST_KIND_), allocatable, dimension(:) :: lon1D_src, lat1D_src, lon1D_dst, lat1D_dst + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lon2D_src, lat2d_src, lon2D_dst, lat2D_dst + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: data_src, data_dst + real(HI_TEST_KIND_), parameter :: lon_src_beg = 0._lkind, lon_src_end = 360.0_lkind + real(HI_TEST_KIND_), parameter :: lat_src_beg = -90._lkind, lat_src_end = 90._lkind + real(HI_TEST_KIND_), parameter :: D2R = real(PI,lkind)/180._lkind + + type(horiz_interp_type) :: interp + + allocate( lon1D_src(ni_src+1), lat1D_src(nj_src+1) ) + allocate( lon1D_dst(ni_src+1), lat1D_dst(nj_src+1) ) + allocate( lon2d_src(ni_src,nj_src), lat2d_src(ni_src,nj_src) ) + allocate( lon2d_dst(ni_src,nj_src), lat2d_dst(ni_src,nj_src) ) + allocate( data_src(ni_src, nj_src) ) + allocate( data_dst(ni_src,nj_src) ) + + ! set up longitude and latitude of source/destination grid. + dlon_src = (lon_src_end-lon_src_beg)/real(ni_src,HI_TEST_KIND_) ; dlon_dst = dlon_src + dlat_src = (lat_src_end-lat_src_beg)/real(nj_src,HI_TEST_KIND_) ; dlat_dst = dlat_src + + ! set up 1d source grid + do i = 1, ni_src + lon1D_src(i) = ( lon_src_beg + real(i-1,HI_TEST_KIND_)*dlon_src ) * D2R + end do + lon1D_src(ni_src+1) = ( lon_src_beg + real(ni_src,HI_TEST_KIND_)*dlon_src ) * D2R + + do j = 1, nj_src + lat1D_src(j) = ( lat_src_beg + real(j-1,HI_TEST_KIND_)*dlat_src ) * D2R + end do + lat1D_src(nj_src+1) = ( lat_src_beg + real(nj_src,HI_TEST_KIND_)*dlat_src ) * D2R + + !--- set up the source data + do j = 1, nj_src + do i = 1, ni_src + data_src(i,j) = real(i,HI_TEST_KIND_) + real(j,HI_TEST_KIND_)*0.001_lkind + end do + end do + + id1 = mpp_clock_id( 'horiz_interp_1dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + id2 = mpp_clock_id( 'horiz_interp_1dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + id3 = mpp_clock_id( 'horiz_interp_2dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + id4 = mpp_clock_id( 'horiz_interp_2dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + + ! --- 1dx1d version bilinear interpolation + data_dst = 0.0_lkind + lon1d_dst = lon1d_src + lat1d_dst = lat1d_src + call mpp_clock_begin(id1) + if (.not. test_solo) then + call horiz_interp_new(interp, lon1D_src, lat1D_src, lon1D_dst, lat1D_dst, interp_method = "bilinear") + call horiz_interp(interp, data_src, data_dst) + else + call horiz_interp(data_src, lon1D_src, lat1D_src, lon1D_dst, lat1D_dst, data_dst, interp_method = "bilinear") + endif + ! check weights + if( .not. test_solo) then + do j=1, nj_src-1 + do i=1, ni_src-1 + if(interp%horizInterpReals8_type%is_allocated) then + if( interp%horizInterpReals8_type%wtj(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wtj1") + end if + if( interp%horizInterpReals8_type%wtj(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wtj2") + end if + if( interp%horizInterpReals8_type%wti(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wti1") + end if + if( interp%horizInterpReals8_type%wti(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wtj2") + end if + else + if( interp%horizInterpReals4_type%wtj(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wtj1") + end if + if( interp%horizInterpReals4_type%wtj(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wtj2") + end if + if( interp%horizInterpReals4_type%wti(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wti1") + end if + if( interp%horizInterpReals4_type%wti(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d with wtj2") + end if + endif + end do + end do + endif + call mpp_clock_end(id1) + !checking to make sure data_src is equal to data_dst + do j=1, nj_src + do i=1, ni_src + if( data_src(i,j).ne.data_dst(i,j) ) then + write(*,*) 'expected ', data_src(i,j), ' but computed ', data_dst(i,j) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d1d data comparison") + end if + end do + end do + if(.not. test_solo) then + call horiz_interp_del(interp) + call check_dealloc(interp) + endif + + ! --- 1dx2d version bilinear interpolation + data_dst = 0.0_lkind + ! taking the midpoint + do i = 1, ni_src + lon2D_dst(i,:) = (lon1D_src(i) + lon1D_src(i+1)) * 0.5_lkind + end do + do j = 1, nj_src + lat2D_dst(:,j) = (lat1D_src(j) + lat1D_src(j+1)) * 0.5_lkind + end do + call mpp_clock_begin(id2) + if(.not. test_solo) then + call horiz_interp_new(interp, lon1D_src, lat1D_src, lon2D_dst, lat2D_dst, interp_method = "bilinear") + call horiz_interp(interp, data_src, data_dst) + else + call horiz_interp(data_src, lon1D_src, lat1D_src, lon2D_dst, lat2D_dst, data_dst,interp_method="bilinear") + endif + call mpp_clock_end(id2) + ! check weights + if(.not. test_solo) then + do j=1, nj_src-1 + do i=1, ni_src-1 + if(interp%horizInterpReals8_type%is_allocated) then + if( interp%horizInterpReals8_type%wtj(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wtj1") + end if + if( interp%horizInterpReals8_type%wtj(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wtj2") + end if + if( interp%horizInterpReals8_type%wti(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wti1") + end if + if( interp%horizInterpReals8_type%wti(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wti2") + end if + else + if( interp%horizInterpReals4_type%wtj(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wtj1") + end if + if( interp%horizInterpReals4_type%wtj(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wtj2") + end if + if( interp%horizInterpReals4_type%wti(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wti1") + end if + if( interp%horizInterpReals4_type%wti(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d with wti2") + end if + endif + end do + end do + endif + !check that data are equal + do j=1, nj_src + do i=1, ni_src + if( data_src(i,j).ne.data_dst(i,j) ) then + write(*,*) 'expected ', data_src(i,j), ' but computed ', data_dst(i,j) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_1d2d data comparison") + end if + end do + end do + if(.not. test_solo) then + call horiz_interp_del(interp) + call check_dealloc(interp) + endif + + ! --- 2dx1d version bilinear interpolation + data_dst = 0.0_lkind + lon1d_dst = lon1d_src + lat1d_dst = lat1d_src + do i=1, ni_src + lon2d_src(i,:) = lon1d_dst(i) + end do + do j=1, nj_src + lat2d_src(:,j) = lat1d_dst(j) + end do + call mpp_clock_begin(id3) + if(.not. test_solo) then + call horiz_interp_new(interp,lon2D_src,lat2D_src,lon1D_dst(1:ni_src),lat1D_dst(1:nj_src), & + interp_method = "bilinear") + call horiz_interp(interp, data_src, data_dst) + else + call horiz_interp(data_src, lon2D_src, lat2d_src, lon1D_dst(1:ni_src),lat1D_dst(1:nj_src), data_dst, & + interp_method="bilinear") + endif + call mpp_clock_end(id3) + ! check weights + !j=1,i=1 is a special case; see subroutine find_neighbor + if(.not. test_solo) then + i=1 ; j=1 + if(interp%horizInterpReals8_type%is_allocated) then + if( interp%horizInterpReals8_type%wtj(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', i,j,interp%horizInterpReals8_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj(1,1,1)") + end if + if( interp%horizInterpReals8_type%wtj(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj(1,1,2)") + end if + if( interp%horizInterpReals8_type%wti(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti(1,1,1)") + end if + if( interp%horizInterpReals8_type%wti(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti(1,1,2)") + end if + else + if( interp%horizInterpReals4_type%wtj(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', i,j,interp%horizInterpReals4_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj(1,1,1)") + end if + if( interp%horizInterpReals4_type%wtj(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj(1,1,2)") + end if + if( interp%horizInterpReals4_type%wti(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti(1,1,1)") + end if + if( interp%horizInterpReals4_type%wti(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti(1,1,2)") + end if + endif + do j=2, nj_src + do i=2, ni_src + if(interp%horizInterpReals8_type%is_allocated) then + if( interp%horizInterpReals8_type%wtj(i,j,1).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', i,j, & + interp%horizInterpReals8_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj1") + end if + if( interp%horizInterpReals8_type%wtj(i,j,2).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj2") + end if + if( interp%horizInterpReals8_type%wti(i,j,1).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti1") + end if + if( interp%horizInterpReals8_type%wti(i,j,2).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti2") + end if + else + if( interp%horizInterpReals4_type%wtj(i,j,1).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', i,j, & + interp%horizInterpReals4_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj1") + end if + if( interp%horizInterpReals4_type%wtj(i,j,2).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wtj2") + end if + if( interp%horizInterpReals4_type%wti(i,j,1).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti1") + end if + if( interp%horizInterpReals4_type%wti(i,j,2).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d with wti2") + end if + endif + end do + end do + endif + !check that data are equal + do j=1, nj_src + do i=1, ni_src + if( data_src(i,j).ne.data_dst(i,j) ) then + write(*,*) 'expected ', data_src(i,j), ' but computed ', data_dst(i,j) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d1d data comparison") + end if + end do + end do + if(.not. test_solo) then + call horiz_interp_del(interp) + call check_dealloc(interp) + endif + + ! --- 2dx2d version bilinear interpolation + data_dst = 0.0_lkind + lon2D_dst = lon2D_src + lat2D_dst = lat2D_src + + call mpp_clock_begin(id4) + if(.not. test_solo) then + call horiz_interp_new(interp, lon2D_src, lat2D_src, lon2D_dst, lat2D_dst, interp_method = "bilinear") + call horiz_interp(interp, data_src, data_dst) + else + call horiz_interp(data_src, lon2D_src, lat2d_src, lon2D_dst, lat2D_dst, data_dst, interp_method="bilinear") + endif + call mpp_clock_end(id4) + ! check weights + if(.not. test_solo) then + !j=1,i=1 is a special case; see subroutine find_neighbor + i=1 ; j=1 + if(interp%horizInterpReals8_type%is_allocated) then + if( interp%horizInterpReals8_type%wtj(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', i,j,interp%horizInterpReals8_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj(1,1,1)") + end if + if( interp%horizInterpReals8_type%wtj(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj(1,1,2)") + end if + if( interp%horizInterpReals8_type%wti(i,j,1).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti(1,1,1)") + end if + if( interp%horizInterpReals8_type%wti(i,j,2).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti(1,1,2)") + end if + else + if( interp%horizInterpReals4_type%wtj(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', i,j,interp%horizInterpReals4_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj(1,1,1)") + end if + if( interp%horizInterpReals4_type%wtj(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj(1,1,2)") + end if + if( interp%horizInterpReals4_type%wti(i,j,1).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti(1,1,1)") + end if + if( interp%horizInterpReals4_type%wti(i,j,2).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti(1,1,2)") + end if + endif + do j=2, nj_src + do i=2, ni_src + if(interp%horizInterpReals8_type%is_allocated) then + if( interp%horizInterpReals8_type%wtj(i,j,1).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', i,j, & + interp%horizInterpReals8_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj1") + end if + if( interp%horizInterpReals8_type%wtj(i,j,2).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj2") + end if + if( interp%horizInterpReals8_type%wti(i,j,1).ne.0.0_r8_kind ) then + write(*,*) 'expected ', 1.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti1") + end if + if( interp%horizInterpReals8_type%wti(i,j,2).ne.1.0_r8_kind ) then + write(*,*) 'expected ', 0.0_r8_kind, ' but computed ', interp%horizInterpReals8_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti2") + end if + else + if( interp%horizInterpReals4_type%wtj(i,j,1).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', i,j, & + interp%horizInterpReals4_type%wtj(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj1") + end if + if( interp%horizInterpReals4_type%wtj(i,j,2).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wtj(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wtj2") + end if + if( interp%horizInterpReals4_type%wti(i,j,1).ne.0.0_r4_kind ) then + write(*,*) 'expected ', 1.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,1) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti1") + end if + if( interp%horizInterpReals4_type%wti(i,j,2).ne.1.0_r4_kind ) then + write(*,*) 'expected ', 0.0_r4_kind, ' but computed ', interp%horizInterpReals4_type%wti(i,j,2) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d wti2") + end if + endif + end do + end do + endif + if(.not. test_solo) then + call horiz_interp_del(interp) + call check_dealloc(interp) + endif + !check that data are equal + do j=1, nj_src + do i=1, ni_src + if( data_src(i,j).ne.data_dst(i,j) ) then + write(*,*) 'expected ', data_src(i,j), ' but computed ', data_dst(i,j) + call mpp_error(FATAL, "failed at horiz_interp_bilinear_2d2d data comparison") + end if + end do + end do + + end subroutine test_horiz_interp_bilinear + + !> Tests bicubic module interpolation with each dimension conversion + !! test without passing in the type when test_solo is true + subroutine test_horiz_interp_bicubic + !! grid data + real(HI_TEST_KIND_), allocatable, dimension(:) :: lat_in_1D, lon_in_1D + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_in_2D, lon_in_2D + type(horiz_interp_type) :: interp_t + !! input data + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: data_src, data_dst + !! output data + real(HI_TEST_KIND_), allocatable, dimension(:) :: lat_out_1D, lon_out_1D + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_out_2D, lon_out_2D + !! array sizes and number of lat/lon per index + real(HI_TEST_KIND_) :: nlon_in, nlat_in + real(HI_TEST_KIND_) :: nlon_out, nlat_out + real(HI_TEST_KIND_) :: dlon_src, dlat_src, dlon_dst, dlat_dst + !! parameters for lon/lat setup + real(HI_TEST_KIND_) :: lon_src_beg = 0._lkind, lon_src_end = 360._lkind + real(HI_TEST_KIND_) :: lat_src_beg = -90._lkind, lat_src_end = 90._lkind + real(HI_TEST_KIND_) :: lon_dst_beg = -280._lkind, lon_dst_end = 80._lkind + real(HI_TEST_KIND_) :: lat_dst_beg = -90._lkind, lat_dst_end = 90._lkind + real(HI_TEST_KIND_) :: D2R = real(PI,HI_TEST_KIND_)/180._lkind + real(HI_TEST_KIND_) :: R2D = 180._lkind/real(PI,HI_TEST_KIND_) + real(HI_TEST_KIND_), parameter :: SMALL = 1.0e-10_lkind + + ! set up longitude and latitude of source/destination grid. + dlon_src = (lon_src_end-lon_src_beg)/real(ni_src, lkind) + dlat_src = (lat_src_end-lat_src_beg)/real(nj_src, lkind) + dlon_dst = (lon_dst_end-lon_dst_beg)/real(ni_dst, lkind) + dlat_dst = (lat_dst_end-lat_dst_beg)/real(nj_dst, lkind) + + allocate(lon_in_1D(ni_src+1), lat_in_1D(nj_src+1)) + do i = 1, ni_src+1 + lon_in_1D(i) = lon_src_beg + real(i-1, lkind)*dlon_src + end do + do j = 1, nj_src+1 + lat_in_1D(j) = lat_src_beg + real(j-1, lkind)*dlat_src + end do + allocate(lon_out_1D(isc:iec+1), lat_out_1D(jsc:jec+1)) + do i = isc, iec+1 + lon_out_1D(i) = lon_dst_beg + real(i-1,lkind)*dlon_dst + end do + do j = jsc, jec+1 + lat_out_1D(j) = lat_dst_beg + real(j-1,lkind)*dlat_dst + end do + ! convert to rads + lon_in_1D = lon_in_1D * D2R + lat_in_1D = lat_in_1D * D2R + lon_out_1D = lon_out_1D * D2R + lat_out_1D = lat_out_1D * D2R + + ! set up 2d lon/lat + allocate(lon_out_2D(isc:iec+1, jsc:jec+1), lat_out_2D(isc:iec+1, jsc:jec+1)) + do i = isc, iec+1 + lon_out_2D(i,:) = lon_out_1D(i) + end do + do j = jsc, jec+1 + lat_out_2D(:,j) = lat_out_1D(j) + end do + + nlon_in = real(ni_src, lkind); nlat_in = real(nj_src, lkind) + nlon_out = real(iec - isc, lkind); nlat_out = real(jec - jsc, lkind) + + ! allocate data + allocate(data_src(ni_src, nj_src)) + allocate(data_dst(isc:iec, jsc:jec)) + data_dst = 0.0_lkind ; data_src = 1.0_lkind + + id1 = mpp_clock_id( 'horiz_interp_bicubic_1dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + id2 = mpp_clock_id( 'horiz_interp_bicubic_1dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + + ! 1D x 1D + call mpp_clock_begin(id1) + if(.not. test_solo) then + call horiz_interp_new(interp_t, lon_in_1d, lat_in_1d, lon_out_1d, lat_out_1d, interp_method="bicubic") + call horiz_interp(interp_t, data_src, data_dst) + else + call horiz_interp(data_src, lon_in_1D, lat_in_1D, lon_out_1D, lat_out_1D, data_dst, interp_method="bicubic") + endif + call mpp_clock_end(id1) + call mpp_sync() + ! check weights (for last index, 1=x,2=y,3=xy derivatives) + ! 1 radian (in degrees) at edges, 0.5 otherwise + if( .not. test_solo) then + do i=1, ni_src-1 + do j=1, nj_src-1 + if( interp_t%horizInterpReals4_type%is_allocated) then + if( interp_t%horizInterpReals4_type%wti(i,j,1) * interp_t%horizInterpReals4_type%wti(i,j,2) & + - interp_t%horizInterpReals4_type%wti(i,j,3) .gt. SMALL .or. & + interp_t%horizInterpReals4_type%wti(i,j,3) - (57.2958_lkind * 57.2958_lkind) .gt. SMALL) then + print *, i, j, interp_t%horizInterpReals4_type%wti(i,j,:) + call mpp_error(FATAL, "test_horiz_interp: bicubic test failed 1Dx1D weight calculation") + endif + else + if( interp_t%horizInterpReals8_type%wti(i,j,1) * interp_t%horizInterpReals8_type%wti(i,j,2) & + - interp_t%horizInterpReals8_type%wti(i,j,3) .gt. SMALL .and. & + interp_t%horizInterpReals8_type%wti(i,j,3) - (57.2958_lkind * 57.2958_lkind) .gt. SMALL) then + print *, i, j, interp_t%horizInterpReals8_type%wti(i,j,:) + call mpp_error(FATAL, "test_horiz_interp: bicubic test failed 1Dx1D weight calculation") + endif + endif + enddo + enddo + call horiz_interp_del(interp_t) + call check_dealloc(interp_t) + endif + do i=isc, iec + do j=jsc, jec + if( data_dst(i,j) .ne. 1.0_lkind) call mpp_error(FATAL, "test_horiz_interp: error in 1Dx1D output data") + enddo + enddo + + ! 1D x 2D + deallocate(data_src, data_dst) + allocate(data_src(ni_src+1, nj_src+1)) + allocate(data_dst(isc:iec+1, jsc:jec+1)) + data_dst = 0.0_lkind ; data_src = 1.0_lkind + + call mpp_clock_begin(id2) + if(.not. test_solo) then + call horiz_interp_new(interp_t, lon_in_1d, lat_in_1d, lon_out_2d, lat_out_2d, interp_method="bicubic") + call horiz_interp(interp_t, data_src, data_dst) + else + call horiz_interp(data_src, lon_in_1D, lat_in_1D, lon_out_2D, lat_out_2D, data_dst, interp_method="bicubic") + endif + call mpp_clock_end(id2) + if( .not. test_solo) then + do i=1, ni_src-1 + do j=1, nj_src-1 + if( interp_t%horizInterpReals4_type%is_allocated) then + if( interp_t%horizInterpReals4_type%wti(i,j,1) * interp_t%horizInterpReals4_type%wti(i,j,2) & + - interp_t%horizInterpReals4_type%wti(i,j,3) .gt. SMALL .or. & + interp_t%horizInterpReals4_type%wti(i,j,3) - (57.2958_lkind * 57.2958_lkind) .gt. SMALL) then + print *, i, j, interp_t%horizInterpReals4_type%wti(i,j,:) + call mpp_error(FATAL, "test_horiz_interp: bicubic test failed 1Dx1D weight calculation") + endif + else + if( interp_t%horizInterpReals8_type%wti(i,j,1) * interp_t%horizInterpReals8_type%wti(i,j,2) & + - interp_t%horizInterpReals8_type%wti(i,j,3) .gt. SMALL .or. & + interp_t%horizInterpReals8_type%wti(i,j,3) - (57.2958_lkind * 57.2958_lkind) .gt. SMALL) then + print *, i, j, interp_t%horizInterpReals8_type%wti(i,j,:) + call mpp_error(FATAL, "test_horiz_interp: bicubic test failed 1Dx1D weight calculation") + endif + endif + enddo + enddo + call horiz_interp_del(interp_t) + call check_dealloc(interp_t) + endif + do i=isc, iec + do j=jsc, jec + if( data_dst(i,j) .ne. 1.0_lkind) call mpp_error(FATAL, "test_horiz_interp: error in 1Dx2D output data") + enddo + enddo + + deallocate(data_src, data_dst) + deallocate(lat_in_1D, lon_in_1D) + deallocate(lat_out_1D, lon_out_1D, lat_out_2D, lon_out_2D) + + end subroutine test_horiz_interp_bicubic + + !> Tests conservative (default) interpolation module and checks grids reproduce across 1/2d versions + subroutine test_horiz_interp_conserve + real(HI_TEST_KIND_) :: dlon_src, dlat_src, dlon_dst, dlat_dst + real(HI_TEST_KIND_), allocatable, dimension(:) :: lon1D_src, lat1D_src, lon1D_dst, lat1D_dst + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lon2D_src, lat2D_src, lon2D_dst, lat2D_dst + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: data_src, data1_dst, data2_dst, data3_dst, data4_dst + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: data1_solo, data2_solo, data3_solo, data4_solo + real(HI_TEST_KIND_) :: lon_src_beg = 0._lkind, lon_src_end = 360._lkind + real(HI_TEST_KIND_) :: lat_src_beg = -90._lkind, lat_src_end = 90._lkind + real(HI_TEST_KIND_) :: lon_dst_beg = -280._lkind, lon_dst_end = 80._lkind + real(HI_TEST_KIND_) :: lat_dst_beg = -90._lkind, lat_dst_end = 90._lkind + real(HI_TEST_KIND_) :: D2R = real(PI,HI_TEST_KIND_)/180._lkind + real(HI_TEST_KIND_), parameter :: SMALL = 1.0e-10_lkind + type(horiz_interp_type) :: interp_conserve + + allocate(lon2D_src(ni_src+1, nj_src+1), lat2D_src(ni_src+1, nj_src+1) ) + allocate(lon1D_src(ni_src+1), lat1D_src(nj_src+1), data_src(ni_src, nj_src) ) + + allocate(lon2D_dst(isc:iec+1, jsc:jec+1), lat2D_dst(isc:iec+1, jsc:jec+1) ) + allocate(lon1D_dst(isc:iec+1), lat1D_dst(jsc:jec+1) ) + allocate(data1_dst(isc:iec, jsc:jec), data2_dst(isc:iec, jsc:jec) ) + allocate(data3_dst(isc:iec, jsc:jec), data4_dst(isc:iec, jsc:jec) ) + + ! set up longitude and latitude of source/destination grid. + dlon_src = (lon_src_end-lon_src_beg)/real(ni_src, lkind) + dlat_src = (lat_src_end-lat_src_beg)/real(nj_src, lkind) + dlon_dst = (lon_dst_end-lon_dst_beg)/real(ni_dst, lkind) + dlat_dst = (lat_dst_end-lat_dst_beg)/real(nj_dst, lkind) + + do i = 1, ni_src+1 + lon1D_src(i) = lon_src_beg + real(i-1, lkind)*dlon_src + end do + + do j = 1, nj_src+1 + lat1D_src(j) = lat_src_beg + real(j-1, lkind)*dlat_src + end do + + do i = isc, iec+1 + lon1D_dst(i) = lon_dst_beg + real(i-1, lkind)*dlon_dst + end do + + do j = jsc, jec+1 + lat1D_dst(j) = lat_dst_beg + real(j-1, lkind)*dlat_dst + end do + + ! scale grid to radians. + lon1D_src = lon1D_src * D2R + lat1D_src = lat1D_src * D2R + lon1D_dst = lon1D_dst * D2R + lat1D_dst = lat1D_dst * D2R + + do i = 1, ni_src+1 + lon2D_src(i,:) = lon1D_src(i) + end do + + do j = 1, nj_src+1 + lat2D_src(:,j) = lat1D_src(j) + end do + + do i = isc, iec+1 + lon2D_dst(i,:) = lon1D_dst(i) + end do + + do j = jsc, jec+1 + lat2D_dst(:,j) = lat1D_dst(j) + end do + + !--- set up the source data + do j = 1, nj_src + do i = 1, ni_src + data_src(i,j) = real(i,lkind) + real(j,lkind)*0.001_lkind + end do + end do + + id1 = mpp_clock_id( 'horiz_interp_1dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + id2 = mpp_clock_id( 'horiz_interp_1dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + id3 = mpp_clock_id( 'horiz_interp_2dx1d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + id4 = mpp_clock_id( 'horiz_interp_2dx2d', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + + ! --- 1dx1d version conservative interpolation + call mpp_clock_begin(id1) + if(.not. test_solo) then + call horiz_interp_new(interp_conserve, lon1D_src, lat1D_src, lon1D_dst, lat1D_dst, & + interp_method = "conservative") + call horiz_interp(interp_conserve, data_src, data1_dst) + call horiz_interp_del(interp_conserve) + call check_dealloc(interp_conserve) + else + call horiz_interp(data_src, lon1D_src, lat1D_src, lon1D_dst, lat1D_dst, data1_dst, & + interp_method="conservative") + endif + call mpp_clock_end(id1) + + ! --- 1dx2d version conservative interpolation + call mpp_clock_begin(id2) + if(.not. test_solo) then + call horiz_interp_new(interp_conserve, lon1D_src, lat1D_src, lon2D_dst, lat2D_dst, & + interp_method = "conservative") + call horiz_interp(interp_conserve, data_src, data2_dst) + call horiz_interp_del(interp_conserve) + call check_dealloc(interp_conserve) + else + call horiz_interp(data_src, lon1D_src, lat1D_src, lon2D_dst, lat2D_dst, data2_dst, & + interp_method="conservative") + endif + call mpp_clock_end(id2) + + ! --- 2dx1d version conservative interpolation + call mpp_clock_begin(id3) + if(.not. test_solo) then + call horiz_interp_new(interp_conserve, lon2D_src, lat2D_src, lon1D_dst, lat1D_dst, & + interp_method = "conservative") + call horiz_interp(interp_conserve, data_src, data3_dst) + call horiz_interp_del(interp_conserve) + call check_dealloc(interp_conserve) + else + call horiz_interp(data_src, lon2D_src, lat2D_src, lon1D_dst, lat1D_dst, data3_dst, & + interp_method="conservative") + endif + call mpp_clock_end(id3) + + ! --- 2dx2d version conservative interpolation + call mpp_clock_begin(id4) + if(.not. test_solo) then + call horiz_interp_new(interp_conserve, lon2D_src, lat2D_src, lon2D_dst, lat2D_dst, & + interp_method = "conservative") + call horiz_interp(interp_conserve, data_src, data4_dst) + call horiz_interp_del(interp_conserve) + call check_dealloc(interp_conserve) + else + call horiz_interp(data_src, lon2D_src, lat2D_src, lon2D_dst, lat2D_dst, data4_dst, & + interp_method="conservative") + endif + call mpp_clock_end(id4) + + !--- compare the data after interpolation between 1-D and 2-D version interpolation + do j = jsc, jsc + do i = isc, iec + + if( abs(data1_dst(i,j)-data2_dst(i,j)) > SMALL ) then + print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), & + ", data2 = ", data2_dst(i,j), ", data1-data2 = ", data1_dst(i,j) - data2_dst(i,j) + call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data2_dst") + end if + end do + end do + + if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE, & + "The test that verify 1dx2d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") + + do j = jsc, jsc + do i = isc, iec + + if( abs(data1_dst(i,j)-data3_dst(i,j)) > SMALL ) then + print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), & + ", data2 = ", data3_dst(i,j), ", data1-data2 = ", data1_dst(i,j) - data3_dst(i,j) + call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data3_dst") + end if + end do + end do + + if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE, & + "The test that verify 2dx1d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") + + do j = jsc, jsc + do i = isc, iec + + if( abs(data1_dst(i,j)-data4_dst(i,j)) > SMALL ) then + print*, "After interpolation At point (i,j) = (", i, ",", j, "), data1 = ", data1_dst(i,j), & + ", data2 = ", data4_dst(i,j), ", data1-data2 = ", data1_dst(i,j) - data4_dst(i,j) + call mpp_error(FATAL,"horiz_interp_test: data1_dst does not approxiamate data4_dst") + end if + end do + end do + + if(mpp_pe() == mpp_root_pe()) call mpp_error(NOTE, & + "The test that verify 2dx2d version horiz_interp can reproduce 1dx1d version of horiz_interp is succesful") + + + end subroutine + + !> Tests the assignment overload for horiz_interp_type + !! creates some new instances of the derived type for the different methods + !! and tests equality of fields after initial weiht calculations + subroutine test_assignment() + type(horiz_interp_type) :: Interp_new1, Interp_new2, Interp_cp, intp_3 + !! grid data points + real(HI_TEST_KIND_), allocatable, dimension(:) :: lat_in_1D, lon_in_1D + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_in_2D, lon_in_2D + !! output data points + real(HI_TEST_KIND_), allocatable, dimension(:) :: lat_out_1D, lon_out_1D + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_out_2D, lon_out_2D + real(HI_TEST_KIND_), allocatable, dimension(:) :: lat_out_bil, lon_out_bil + real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_in_bil, lon_in_bil + !! array sizes and number of lat/lon per index + real(HI_TEST_KIND_) :: nlon_in, nlat_in + real(HI_TEST_KIND_) :: nlon_out, nlat_out + real(HI_TEST_KIND_) :: dlon_src, dlat_src, dlon_dst, dlat_dst + !! parameters for lon/lat setup + real(HI_TEST_KIND_) :: lon_src_beg = 0._lkind, lon_src_end = 360._lkind + real(HI_TEST_KIND_) :: lat_src_beg = -90._lkind, lat_src_end = 90._lkind + real(HI_TEST_KIND_) :: lon_dst_beg = 0.0_lkind, lon_dst_end = 360._lkind + real(HI_TEST_KIND_) :: lat_dst_beg = -90._lkind, lat_dst_end = 90._lkind + real(HI_TEST_KIND_) :: D2R = real(PI,HI_TEST_KIND_)/180._lkind + real(HI_TEST_KIND_) :: R2D = 180._lkind/real(PI,HI_TEST_KIND_) + real(HI_TEST_KIND_), parameter :: SMALL = 1.0e-10_lkind + + ! set up longitude and latitude of source/destination grid. + dlon_src = (lon_src_end-lon_src_beg)/real(ni_src, lkind) + dlat_src = (lat_src_end-lat_src_beg)/real(nj_src, lkind) + dlon_dst = (lon_dst_end-lon_dst_beg)/real(ni_dst, lkind) + dlat_dst = (lat_dst_end-lat_dst_beg)/real(nj_dst, lkind) + + allocate(lon_in_1D(ni_src+1), lat_in_1D(nj_src+1)) + allocate(lon_out_1D(isc:iec+1), lat_out_1D(jsc:jec+1)) + do i = 1, ni_src+1 + lon_in_1D(i) = lon_src_beg + real(i-1,HI_TEST_KIND_)*dlon_src + end do + do j = 1, nj_src+1 + lat_in_1D(j) = lat_src_beg + real(j-1,HI_TEST_KIND_)*dlat_src + end do + do i = isc, iec+1 + lon_out_1D(i) = lon_dst_beg + real(i-1,HI_TEST_KIND_)*dlon_dst + end do + do j = jsc, jec+1 + lat_out_1D(j) = lat_dst_beg + real(j-1, HI_TEST_KIND_)*dlat_dst + end do + + lon_in_1D = lon_in_1D * D2R + lat_in_1D = lat_in_1D * D2R + lon_out_1D = lon_out_1D * D2R + lat_out_1D = lat_out_1D * D2R + + allocate(lon_in_2D(ni_src+1, nj_src+1), lat_in_2D(ni_src+1, nj_src+1)) + do i = 1, ni_src+1 + lon_in_2D(i,:) = lon_in_1D(i) + end do + do j = 1, nj_src+1 + lat_in_2D(:,j) = lat_in_1D(j) + end do + allocate(lon_out_2D(isc:iec+1, jsc:jec+1), lat_out_2D(isc:iec+1, jsc:jec+1)) + do i = isc, iec+1 + lon_out_2D(i,:) = lon_out_1D(i) + end do + do j = jsc, jec+1 + lat_out_2D(:,j) = lat_out_1D(j) + end do + + ! conservative + ! 1dx1d + call horiz_interp_new(Interp_new1, lon_in_1D, lat_in_1D, lon_out_1D, lat_out_1D, interp_method="conservative") + call horiz_interp_new(Interp_new2, lon_in_1D, lat_in_1D, lon_out_1D, lat_out_1D, interp_method="conservative") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x1d conservative") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + ! 1dx2d + call horiz_interp_new(Interp_new1, lon_in_1D, lat_in_1D, lon_out_2D, lat_out_2D, interp_method="conservative") + call horiz_interp_new(Interp_new2, lon_in_1D, lat_in_1D, lon_out_2D, lat_out_2D, interp_method="conservative") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x2d conservative") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + ! 2dx1d + call horiz_interp_new(Interp_new1, lon_in_2D, lat_in_2D, lon_out_1D, lat_out_1D, interp_method="conservative") + call horiz_interp_new(Interp_new2, lon_in_2D, lat_in_2D, lon_out_1D, lat_out_1D, interp_method="conservative") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 2x1d conservative") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + ! 2dx2d + call horiz_interp_new(Interp_new1, lon_in_2D, lat_in_2D, lon_out_2D, lat_out_2D, interp_method="conservative") + call horiz_interp_new(Interp_new2, lon_in_2D, lat_in_2D, lon_out_2D, lat_out_2D, interp_method="conservative") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 2x2d conservative") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + + ! bicubic only works with 1d src + ! 1dx1d + call horiz_interp_new(Interp_new1, lon_in_1D, lat_in_1D, lon_out_1D, lat_out_1D, interp_method="bicubic") + call horiz_interp_new(Interp_new2, lon_in_1D, lat_in_1D, lon_out_1D, lat_out_1D, interp_method="bicubic") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x1d bicubic") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + ! 1dx2d + call horiz_interp_new(Interp_new1, lon_in_1D, lat_in_1D, lon_out_2D, lat_out_2D, interp_method="bicubic") + call horiz_interp_new(Interp_new2, lon_in_1D, lat_in_1D, lon_out_2D, lat_out_2D, interp_method="bicubic") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x2d bicubic") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + + deallocate(lon_out_2D, lat_out_2D, lon_in_2D, lat_in_2D) + allocate(lon_out_2D(ni_dst, nj_dst), lat_out_2D(ni_dst, nj_dst)) + allocate(lon_in_2D(ni_src, nj_src), lat_in_2D(ni_src, nj_src)) + do i = 1, ni_dst + lon_out_2D(i,:) = lon_dst_beg + real(i-1, HI_TEST_KIND_)*dlon_dst + end do + do j = 1, nj_dst + lat_out_2D(:,j) = lat_dst_beg + real(j-1, HI_TEST_KIND_)*dlat_dst + end do + do i = 1, ni_src + lon_in_2D(i,:) = lon_src_beg + real(i-1, HI_TEST_KIND_)*dlon_src + end do + do j = 1, nj_src + lat_in_2D(:,j) = lat_src_beg + real(j-1, HI_TEST_KIND_)*dlat_src + end do + ! scale to radians + lat_in_2D = lat_in_2D * D2R + lon_in_2D = lon_in_2D * D2R + lat_out_2D = lat_out_2D * D2R + lon_out_2D = lon_out_2D * D2R + + ! spherical + ! only 2dx2d + call horiz_interp_new(Interp_new1, lon_in_2D, lat_in_2D, lon_out_2D, lat_out_2D, interp_method="spherical") + call horiz_interp_new(Interp_new2, lon_in_2D, lat_in_2D, lon_out_2D, lat_out_2D, interp_method="spherical") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x2d bilinear") + call check_type_eq(Interp_cp, Interp_new1) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + + ! bilinear + ! 1dx1d + call horiz_interp_new(Interp_new1, lon_in_1D, lat_in_1D, lon_in_1D, lat_in_1D, interp_method="bilinear") + call horiz_interp_new(Interp_new2, lon_in_1D, lat_in_1D, lon_in_1D, lat_in_1D, interp_method="bilinear") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x1d bilinear") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + ! 1dx2d + call horiz_interp_new(Interp_new1, lon_in_1D, lat_in_1D, lon_in_2D, lat_in_2D, interp_method="bilinear") + call horiz_interp_new(Interp_new2, lon_in_1D, lat_in_1D, lon_in_2D, lat_in_2D, interp_method="bilinear") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x2d bilinear") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + ! 2dx1d + deallocate(lon_out_1D, lat_out_1D) + allocate(lon_out_1D(ni_dst+1), lat_out_1D(nj_dst+1)) + do i=1, ni_dst + lon_out_1d(i) = real(i-1, HI_TEST_KIND_) * dlon_dst + lon_dst_beg + enddo + do j=1, nj_dst + lat_out_1d(j) = real(j-1, HI_TEST_KIND_) * dlat_dst + lat_dst_beg + enddo + lat_out_1d = lat_out_1D * D2R + lon_out_1d = lon_out_1D * D2R + call horiz_interp_new(Interp_new1, lon_in_2D, lat_in_2D, lon_out_1D, lat_out_1D, interp_method="bilinear") + call horiz_interp_new(Interp_new2, lon_in_2D, lat_in_2D, lon_out_1D, lat_out_1D, interp_method="bilinear") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x2d bilinear") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + ! 2dx2d + call horiz_interp_new(Interp_new1, lon_in_2D, lat_in_2D, lon_in_2D, lat_in_2D, interp_method="bilinear") + call horiz_interp_new(Interp_new2, lon_in_2D, lat_in_2D, lon_in_2D, lat_in_2D, interp_method="bilinear") + Interp_cp = Interp_new1 + call mpp_error(NOTE,"testing horiz_interp_type assignment 1x2d bilinear") + call check_type_eq(Interp_cp, Interp_new2) + call check_type_eq(Interp_cp, Interp_new1) + call horiz_interp_del(Interp_new1) + call horiz_interp_del(Interp_new2) + call horiz_interp_del(Interp_cp) + + end subroutine + !> helps assignment test with derived type comparisons + subroutine check_type_eq(interp_1, interp_2) + type(horiz_interp_type), intent(in) :: interp_1, interp_2 + integer :: k + if(interp_1%horizInterpReals4_type%is_allocated) then + if(allocated(interp_1%horizInterpReals4_type%faci)) then + if( ANY(interp_2%horizInterpReals4_type%faci .ne. interp_1%horizInterpReals4_type%faci)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: faci") + endif + if(allocated(interp_1%horizInterpReals4_type%facj)) then + if( ANY(interp_2%horizInterpReals4_type%facj .ne. interp_1%horizInterpReals4_type%facj)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: facj") + endif + if(allocated(interp_1%horizInterpReals4_type%area_src)) then + if( ANY(interp_2%horizInterpReals4_type%area_src .ne. interp_1%horizInterpReals4_type%area_src)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: area_src") + endif + if(allocated(interp_1%horizInterpReals4_type%area_dst)) then + if( ANY(interp_2%horizInterpReals4_type%area_dst .ne. interp_1%horizInterpReals4_type%area_dst)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: area_dst") + endif + if(allocated(interp_1%horizInterpReals4_type%wti)) then + if( ANY(interp_2%horizInterpReals4_type%wti .ne. interp_1%horizInterpReals4_type%wti)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: wti") + endif + if(allocated(interp_1%horizInterpReals4_type%wtj)) then + if( ANY(interp_2%horizInterpReals4_type%wtj .ne. interp_1%horizInterpReals4_type%wtj)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: wtj") + endif + if(allocated(interp_1%horizInterpReals4_type%src_dist)) then + if( ANY(interp_2%horizInterpReals4_type%src_dist .ne. interp_1%horizInterpReals4_type%src_dist)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: src_dst") + endif + if(allocated(interp_1%horizInterpReals4_type%rat_x)) then + if( ANY(interp_2%horizInterpReals4_type%rat_x .ne. interp_1%horizInterpReals4_type%rat_x)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: src_dst") + endif + if(allocated(interp_1%horizInterpReals4_type%rat_y)) then + if( ANY(interp_2%horizInterpReals4_type%rat_y .ne. interp_1%horizInterpReals4_type%rat_y)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: src_dst") + endif + if(allocated(interp_1%horizInterpReals4_type%lon_in)) then + if( ANY(interp_2%horizInterpReals4_type%lon_in .ne. interp_1%horizInterpReals4_type%lon_in)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: lon_in") + endif + if(allocated(interp_1%horizInterpReals4_type%lat_in)) then + if( ANY(interp_2%horizInterpReals4_type%lat_in .ne. interp_1%horizInterpReals4_type%lat_in)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: lat_in") + endif + + if(allocated(interp_1%horizInterpReals4_type%area_frac_dst)) then + if(ANY(interp_2%horizInterpReals4_type%area_frac_dst.ne.interp_1%horizInterpReals4_type%area_frac_dst))& + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: area_frac_dst") + endif + if(allocated(interp_1%horizInterpReals4_type%mask_in)) then + if(ANY(interp_2%horizInterpReals4_type%mask_in.ne.interp_1%horizInterpReals4_type%mask_in)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: mask_in") + endif + !! only set during spherical + if(interp_1%interp_method .eq. SPHERICA) then + if( interp_2%horizInterpReals4_type%max_src_dist .ne. interp_1%horizInterpReals4_type%max_src_dist) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: max_src_dist") + endif + + else if(interp_1%horizInterpReals8_type%is_allocated) then + !! + if(allocated(interp_1%horizInterpReals8_type%faci)) then + if( ANY(interp_2%horizInterpReals8_type%faci .ne. interp_1%horizInterpReals8_type%faci)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: faci") + endif + if(allocated(interp_1%horizInterpReals8_type%facj)) then + if( ANY(interp_2%horizInterpReals8_type%facj .ne. interp_1%horizInterpReals8_type%facj)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: facj") + endif + if(allocated(interp_1%horizInterpReals8_type%area_src)) then + if( ANY(interp_2%horizInterpReals8_type%area_src .ne. interp_1%horizInterpReals8_type%area_src)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: area_src") + endif + if(allocated(interp_1%horizInterpReals8_type%area_dst)) then + if( ANY(interp_2%horizInterpReals8_type%area_dst .ne. interp_1%horizInterpReals8_type%area_dst)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: area_dst") + endif + if(allocated(interp_1%horizInterpReals8_type%wti)) then + if( ANY(interp_2%horizInterpReals8_type%wti .ne. interp_1%horizInterpReals8_type%wti)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: wti") + endif + if(allocated(interp_1%horizInterpReals8_type%wtj)) then + if( ANY(interp_2%horizInterpReals8_type%wtj .ne. interp_1%horizInterpReals8_type%wtj)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: wtj") + endif + if(allocated(interp_1%horizInterpReals8_type%src_dist)) then + if( ANY(interp_2%horizInterpReals8_type%src_dist .ne. interp_1%horizInterpReals8_type%src_dist)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: src_dst") + endif + if(allocated(interp_1%horizInterpReals8_type%rat_x)) then + if( ANY(interp_2%horizInterpReals8_type%rat_x .ne. interp_1%horizInterpReals8_type%rat_x)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: src_dst") + endif + if(allocated(interp_1%horizInterpReals8_type%rat_y)) then + if( ANY(interp_2%horizInterpReals8_type%rat_y .ne. interp_1%horizInterpReals8_type%rat_y)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: src_dst") + endif + if(allocated(interp_1%horizInterpReals8_type%lon_in)) then + if( ANY(interp_2%horizInterpReals8_type%lon_in .ne. interp_1%horizInterpReals8_type%lon_in)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: lon_in") + endif + if(allocated(interp_1%horizInterpReals8_type%lat_in)) then + if( ANY(interp_2%horizInterpReals8_type%lat_in .ne. interp_1%horizInterpReals8_type%lat_in)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: lat_in") + endif + + if(allocated(interp_1%horizInterpReals8_type%area_frac_dst)) then + if(ANY(interp_2%horizInterpReals8_type%area_frac_dst.ne.interp_1%horizInterpReals8_type%area_frac_dst))& + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: area_frac_dst") + endif + if(allocated(interp_1%horizInterpReals8_type%mask_in)) then + if(ANY(interp_2%horizInterpReals8_type%mask_in.ne.interp_1%horizInterpReals8_type%mask_in)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: mask_in") + endif + + !! only set during spherical + if(interp_1%interp_method .eq. SPHERICA) then + if( interp_2%horizInterpReals8_type%max_src_dist .ne. interp_1%horizInterpReals8_type%max_src_dist) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: max_src_dist") + endif + else + call mpp_error(FATAL, "check_type.ne. both real kinds unallocated") + endif + ! non reals + if(allocated(interp_1%ilon)) then + if( ANY(interp_2%ilon .ne. interp_1%ilon)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: ilon") + endif + if(allocated(interp_1%jlat)) then + if( ANY(interp_2%jlat .ne. interp_1%jlat)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: ilon") + endif + if(allocated(interp_1%found_neighbors)) then + if( ANY(interp_2%found_neighbors .neqv. interp_1%found_neighbors)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: found_neighbors") + endif + if(allocated(interp_1%num_found)) then + if( ANY(interp_2%num_found .ne. interp_1%num_found)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: num_found") + endif + if(allocated(interp_1%i_src)) then + if(ANY(interp_2%i_src .ne. interp_1%i_src)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: i_src") + endif + if(allocated(interp_1%j_src)) then + if(ANY(interp_2%j_src .ne. interp_1%j_src)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: j_src") + endif + if(allocated(interp_1%i_dst)) then + if(ANY(interp_2%i_dst .ne. interp_1%i_dst)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: i_dst") + endif + if(allocated(interp_1%j_dst)) then + if(ANY(interp_2%j_dst .ne. interp_1%j_dst)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: j_dst") + endif + if(interp_2%nlon_src .ne. interp_1%nlon_src) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: nlon_src") + if(interp_2%nlat_src .ne. interp_1%nlat_src) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: nlat_src") + if(interp_2%nlon_dst .ne. interp_1%nlon_dst) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: nlon_dst") + if(interp_2%nlat_dst .ne. interp_1%nlat_dst) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: nlat_dst") + + ! these checks were giving me issues with the ALL comparison (gnu), seems to work here tho + if( allocated(interp_1%i_lon)) then + do i=1, SIZE(interp_1%i_lon, 1) + do j=1, SIZE(interp_1%i_lon, 2) + do k=1, SIZE(interp_1%i_lon, 3) + if(interp_1%i_lon(i,j,k) .ne. interp_2%i_lon(i,j,k)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: i_lon") + enddo + enddo + enddo + do i=1, SIZE(interp_1%j_lat, 1) + do j=1, SIZE(interp_1%j_lat, 2) + do k=1, SIZE(interp_1%j_lat, 3) + if(interp_1%j_lat(i,j,k) .ne. interp_2%j_lat(i,j,k)) & + call mpp_error(FATAL, "Invalid value for copied horiz_interp_type field: j_lat") + enddo + enddo + enddo + endif + end subroutine + + subroutine check_dealloc(hi_type) + type(horiz_interp_type), intent(in) :: hi_type + !! can only check the encapsulating real types, inner fields are inaccessible after deallocation + if(hi_type%horizInterpReals4_type%is_allocated) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: horizInterpReals4_type") + endif + if(hi_type%horizInterpReals8_type%is_allocated) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: horizInterpReals8_type") + endif + !! non reals + if(allocated(hi_type%ilon)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: ilon") + endif + if(allocated(hi_type%jlat)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: jlat") + endif + if(allocated(hi_type%found_neighbors)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: found_neighbors") + endif + if(allocated(hi_type%num_found)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: num_found") + endif + if(allocated(hi_type%i_src)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: i_src") + endif + if(allocated(hi_type%j_src)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: j_src") + endif + if(allocated(hi_type%i_dst)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: i_dst") + endif + if(allocated(hi_type%j_dst)) then + call mpp_error(FATAL, "horiz_interp_test: field left allocated after type deletion: j_dst") + endif + + end subroutine + + end program horiz_interp_test diff --git a/test_fms/horiz_interp/test_horiz_interp2.sh b/test_fms/horiz_interp/test_horiz_interp2.sh index f9554f9df9..485be882fd 100755 --- a/test_fms/horiz_interp/test_horiz_interp2.sh +++ b/test_fms/horiz_interp/test_horiz_interp2.sh @@ -23,6 +23,7 @@ # execute tests in the test_fms/horiz_interp directory. # Ed Hartnett 11/29/19 +# Ryan Mulhall 01/23 # Set common test settings. . ../test-lib.sh @@ -30,6 +31,7 @@ # Create file for test. cat <<_EOF > input.nml &test_horiz_interp_nml + test_conserve = .true. ni_src = 360 nj_src = 180 ni_dst = 144 @@ -37,8 +39,179 @@ cat <<_EOF > input.nml / _EOF -test_expect_success "Horiz_interp test" ' - mpirun -n 2 ./test_horiz_interp +test_expect_success "conservative method with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +test_expect_success "conservative method with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r4 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_conserve = .true. + test_solo = .true. + ni_src = 360 + nj_src = 180 + ni_dst = 144 + nj_dst = 72 +/ +_EOF + +test_expect_success "conservative method solo wrappers with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +test_expect_success "conservative method solo wrappers with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r4 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_bicubic= .true. + ni_src = 360 + nj_src = 180 + ni_dst = 144 + nj_dst = 72 +/ +_EOF + +test_expect_success "bicubic method with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "bicubic method with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_bicubic= .true. + test_solo = .true. + ni_src = 360 + nj_src = 180 + ni_dst = 144 + nj_dst = 72 +/ +_EOF + +test_expect_success "bicubic method solo wrappers with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "bicubic method solo wrappers with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_bilinear= .true. + ni_src = 360 + nj_src = 180 + ni_dst = 144 + nj_dst = 72 +/ +_EOF + +test_expect_success "bilinear method with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "bilinear method with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_bilinear= .true. + test_solo = .true. + ni_src = 360 + nj_src = 180 + ni_dst = 144 + nj_dst = 72 +/ +_EOF + +test_expect_success "bilinear method solo wrapper with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "bilinear method solo wrapper with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +# the spherical module has a namelist with an option for the search algorithm used +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_spherical= .true. + ni_src = 360 + nj_src = 180 + ni_dst = 12 + nj_dst = 6 +/ + +&horiz_interp_sherical_nml + search_method = "radial search" +/ +_EOF + +test_expect_success "spherical method (radial search) with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "spherical method (radial search) with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_spherical= .true. + ni_src = 360 + nj_src = 180 + ni_dst = 12 + nj_dst = 6 +/ + +&horiz_interp_sherical_nml + search_method = "full search" +/ +_EOF + +test_expect_success "spherical method (full search) with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "spherical method (full search) with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_spherical= .true. + test_solo= .true. + ni_src = 360 + nj_src = 180 + ni_dst = 12 + nj_dst = 6 +/ +_EOF + +test_expect_success "spherical method solo wrappers with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "spherical method solo wrappers with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 +' + +cat <<_EOF > input.nml +&test_horiz_interp_nml + test_assign= .true. + ni_src = 360 + nj_src = 180 + ni_dst = 12 + nj_dst = 6 +/ +_EOF + +test_expect_success "assignment overloads with real kind=4" ' + mpirun -n 2 ./test_horiz_interp_r4 +' +test_expect_success "assignment overloads with real kind=8" ' + mpirun -n 2 ./test_horiz_interp_r8 ' test_done diff --git a/test_fms/sat_vapor_pres/Makefile.am b/test_fms/sat_vapor_pres/Makefile.am new file mode 100644 index 0000000000..974b6fbab1 --- /dev/null +++ b/test_fms/sat_vapor_pres/Makefile.am @@ -0,0 +1,50 @@ +#*********************************************************************** +#* GNU Lesser General Public License +#* +#* This file is part of the GFDL Flexible Modeling System (FMS). +#* +#* FMS is free software: you can redistribute it and/or modify it under +#* the terms of the GNU Lesser General Public License as published by +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** + +# This is an automake file for the test_fms/time_manager directory of the FMS +# package. + + +# Find the fms_mod.mod file. +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) + +# Link to the FMS library. +LDADD = $(top_builddir)/libFMS/libFMS.la + +# Build this test program. +check_PROGRAMS = test_sat_vapor_pres_r4 test_sat_vapor_pres_r8 + +# This is the source code for the test. +test_sat_vapor_pres_r4_SOURCES = test_sat_vapor_pres.F90 +test_sat_vapor_pres_r8_SOURCES = test_sat_vapor_pres.F90 + +test_sat_vapor_pres_r4_CPPFLAGS=-DTEST_SVP_KIND_=4 -I$(MODDIR) +test_sat_vapor_pres_r8_CPPFLAGS=-DTEST_SVP_KIND_=8 -I$(MODDIR) + +TEST_EXTENSIONS = .sh +SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) $(abs_top_srcdir)/test_fms/tap-driver.sh + +# Run the test program. +TESTS = test_sat_vapor_pres.sh + +# These files will be included in the distribution. +EXTRA_DIST = test_sat_vapor_pres.sh + +# Clean up +CLEANFILES = *.nml *.out* *.dpi *.spi *.dyn *.spl diff --git a/test_fms/sat_vapor_pres/test_sat_vapor_pres.F90 b/test_fms/sat_vapor_pres/test_sat_vapor_pres.F90 new file mode 100644 index 0000000000..a05fc9811c --- /dev/null +++ b/test_fms/sat_vapor_pres/test_sat_vapor_pres.F90 @@ -0,0 +1,1010 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @file +!! @brief unit test for the mpp_root_pe() function +!! @author MiKyung Lee +!! @email gfdl.climate.model.info@noaa.gov +!! @description This program tests mainly the lookup* procedures in sat_vapor_pres_mod. +!! The compute_tables, compute_es_k, and compute_es_liq_k subroutines found in +!! this file are copied from sat_vapor_pres_k.F90 in order to generate answers. +!! TODO: A more comprehensive testing suite for the subroutine compute_qd +!! TODO: A more comprehensive testing suite for the compute_mrs +!! TODO: A test to check computation of TABLE and DTABLE when do_simple=.true. +!! (see subroutine sat_vapor_press_k_init) +!! TODO: Testing suite to test computations involving D2TABLE, D2TABLE2, D2TABLE3 +!! Current tests for the lookup* subroutines only checks esat and desat for temperatures +!! = TCMIN and TCMAX. The D2* tables are not involved in the computation for these two cases. +!! Thus, testing suite that involves these D2* table values should be incorporated here. +!! TODO: Test the computation of nbads and test to to see if the expected error occurs if the temperature +!! is less than TCMIN or higher than TCMAX + +program test_sat_vap_pressure + +use fms_mod, only: fms_init, fms_end +use mpp_mod, only: mpp_error, FATAL +use platform_mod, only: r4_kind, r8_kind +use constants_mod, only: RDGAS, RVGAS, TFREEZE +use sat_vapor_pres_mod, only: TCMIN, TCMAX, sat_vapor_pres_init, & + compute_qs, compute_mrs, & + lookup_es, lookup_des, lookup_es_des, & + lookup_es2, lookup_des2, lookup_es2_des2, & + lookup_es3, lookup_des3, lookup_es3_des3 + +implicit none + +integer, parameter :: ESRES=10 !> taken from sat_vapor_pres_mod +real(r8_kind), dimension(:), allocatable :: TABLE, DTABLE, TABLE2, DTABLE2, TABLE3, DTABLE3 +integer :: io, N + +integer, parameter :: nml_unit_var=100 +character(100) :: nml_file +logical :: test1, test2, test3, test4, test5 +NAMELIST / test_sat_vapor_pres_nml/ test1, test2, test3, test4, test5 + +N=(TCMAX-TCMIN)*ESRES+1 +allocate( TABLE(N),DTABLE(N),TABLE2(N),DTABLE2(N),TABLE3(N),DTABLE3(N) ) + +call fms_init() +call sat_vapor_pres_init() !> compute tables to be used for testing +call compute_tables() !> compute tables to generate answers/reference values + +nml_file='test_sat_vapor_pres.nml' +open(unit=nml_unit_var, file=trim(nml_file), action='read') +read(unit=nml_unit_var, nml=test_sat_vapor_pres_nml,iostat=io) +close(nml_unit_var) + +!CALL TESTS +if(test1) then + write(*,*)'***TEST COMPUTE_QS 1D-3D***' + call test_compute_qs() +end if +if(test2) then + write(*,*)'***TEST COMPUTE_MRS 1D-3D***' + call test_compute_mrs() +end if +if(test3) then + write(*,*)'***TEST LOOKUP_ES, LOOKUP_DES, LOOKUP_ES_DES, 1D-3D***' + call test_lookup_es_des() +end if +if(test4) then + write(*,*)'***TEST LOOKUP_ES2, LOOKUP_DES2, LOOKUP_ES2_DES2, 1D-3D***' + call test_lookup_es2_des2() +end if +if(test5) then + write(*,*)'***TEST_LOOKUP_ES3, LOOKUP_DES3, LOOKUP_ES3_DES3, 1D-3D***' + call test_lookup_es3_des3() +end if + +call fms_end() + +contains + !----------------------------------------------------------------------- + subroutine test_compute_qs() + + !> TEST: The qsat value should equal RDGAS/RVGAS as pressure is (hypothetically) zero. + !! The tests for this section is not comprehensive and more tests should be added. + + implicit none + + real(kind=TEST_SVP_KIND_) :: temp, press, answer, qsat + real(kind=TEST_SVP_KIND_), dimension(1) :: temp_1d, press_1d, answer_1d, qsat_1d + real(kind=TEST_SVP_KIND_), dimension(1,1) :: temp_2d, press_2d, answer_2d, qsat_2d + real(kind=TEST_SVP_KIND_), dimension(1,1,1) :: temp_3d, press_3d, answer_3d, qsat_3d + + real(kind=r8_kind), parameter :: EPSILO=real(RDGAS,r8_kind)/real(RVGAS, r8_kind) + integer, parameter :: lkind=TEST_SVP_KIND_ !< local kind value; using TEST_SVP_KIND_ in cases + !! such as 1.0_TEST_SVP_KIND_ cannot be compiled with + !! with gcc compilers. + + !---- 0d ----! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp = 270.0_lkind ; press = 0.0_lkind ; answer=real(EPSILO,lkind) + call compute_qs(temp, press, qsat) + call check_answer_0d( answer, qsat, 'test_compute_qs_0d') + + !---- 1d ----! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp_1d = 270.0_lkind ; press_1d = 0.0_lkind ; answer_1d=real(EPSILO,lkind) + call compute_qs(temp_1d, press_1d, qsat_1d) + call check_answer_1d( answer_1d, qsat_1d, 'test_compute_qs_1d') + + !---- 2d ----! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp_2d = 270.0_lkind ; press_2d = 0.0_lkind ; answer_2d=real(EPSILO,lkind) + call compute_qs(temp_2d, press_2d, qsat_2d) + call check_answer_2d( answer_2d, qsat_2d, 'test_compute_qs_2d') + + !---- 3d ----! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp_3d = 270.0_lkind ; press_3d = 0.0_lkind ; answer_3d=real(EPSILO,lkind) + call compute_qs(temp_3d, press_3d, qsat_3d) + call check_answer_3d( answer_3d, qsat_3d, 'test_compute_qs_3d') + + end subroutine test_compute_qs + !----------------------------------------------------------------------- + subroutine test_compute_mrs() + + !> TEST: The qsat value should equal RDGAS/RVGAS as pressure is (hypothetically) zero. + !! The tests for this section is not comprehensive and more tests should be added. + + implicit none + real(kind=TEST_SVP_KIND_) :: temp, press, answer, mrsat + real(kind=TEST_SVP_KIND_), dimension(1) :: temp_1d, press_1d, answer_1d, mrsat_1d + real(kind=TEST_SVP_KIND_), dimension(1,1) :: temp_2d, press_2d, answer_2d, mrsat_2d + real(kind=TEST_SVP_KIND_), dimension(1,1,1) :: temp_3d, press_3d, answer_3d, mrsat_3d + + real(kind=r8_kind), parameter :: EPSILO=real(RDGAS,r8_kind)/real(RVGAS, r8_kind) + integer, parameter :: lkind=TEST_SVP_KIND_ !< local kind value; using TEST_SVP_KIND_ in cases + !! such as 1.0_TEST_SVP_KIND_ cannot be compiled with + !! with gcc compilers. + + !--------0d--------! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp= 270.0_lkind ; press= 0.0_lkind ; answer=real(EPSILO,lkind) + call compute_mrs(temp, press, mrsat) + call check_answer_0d(answer,mrsat,'test_compute_mrs_0d precision=TEST_SVP_KIND_') + + !--------1d--------! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp_1d = 270.0_lkind ; press_1d = 0.0_lkind ; answer_1d=real(EPSILO,lkind) + call compute_mrs(temp_1d, press_1d, mrsat_1d) + call check_answer_1d(answer_1d,mrsat_1d,'test_compute_mrs_1d precision=TEST_SVP_KIND_') + + !--------2d--------! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp_2d = 270.0_lkind ; press_2d = 0.0_lkind ; answer_2d=real(EPSILO,lkind) + call compute_mrs(temp_2d, press_2d, mrsat_2d) + call check_answer_2d(answer_2d,mrsat_2d,'test_compute_mrs_2d precision=TEST_SVP_KIND_') + + !--------3d--------! + !> press is 0. Therefore the answer should be eps=EPSILO=RDGAS/RVGAS + temp_3d = 270.0_lkind ; press_3d = 0.0_lkind ; answer_3d=real(EPSILO,lkind) + call compute_mrs(temp_3d, press_3d, mrsat_3d) + call check_answer_3d(answer_3d,mrsat_3d,'test_compute_mrs_3d precision=TEST_SVP_KIND_') + + end subroutine test_compute_mrs + !----------------------------------------------------------------------- + subroutine test_lookup_es_des + + !> TEST: at the minimum temperature (TCMIN), the pressures should correspond to the first element in the (D)TABLE + !! TEST: at the maximum temperature (TCMAX), the pressures should correspond to the last element in the (D)TABLE + + implicit none + real(kind=TEST_SVP_KIND_) :: temp, esat, desat, esat_answer, desat_answer + real(kind=TEST_SVP_KIND_), dimension(1) :: temp_1d, esat_1d, desat_1d, esat_answer_1d, desat_answer_1d + real(kind=TEST_SVP_KIND_), dimension(1,1) :: temp_2d, esat_2d, desat_2d, esat_answer_2d, desat_answer_2d + real(kind=TEST_SVP_KIND_), dimension(1,1,1) :: temp_3d, esat_3d, desat_3d, esat_answer_3d, desat_answer_3d + + integer, parameter :: lkind=TEST_SVP_KIND_ !< local kind value; using TEST_SVP_KIND_ in cases + !! such as 1.0_TEST_SVP_KIND_ cannot be compiled with + !! with gcc compilers + + !-----0d test-------! + !> test lookup_es + !! at temp=TCMIN, the answers should be TABLE(1) + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE(1), lkind) + call lookup_es(temp,esat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es_0d TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N) + temp=real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE(N),lkind) + call lookup_es(temp,esat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es_0d precision TCMAX') + + !> test lookup_des + !! at temp=TCMIN, the answers should be DTABLE(1) + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer=real(DTABLE(1), lkind) + call lookup_des(temp,desat) + call check_answer_0d(desat_answer, desat, 'test_lookup_des_0d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE(N) + temp=real(TCMAX,lkind)+real(TFREEZE,lkind) + desat_answer = real(DTABLE(N),lkind) + call lookup_des(temp,desat) + call check_answer_0d(desat_answer, desat, 'test_lookup_es_0d TCMAX') + + !> test lookup_es_des + !! at temp=TCMIN, the answers should be TABLE(1) and DTABLE(1) respectively + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE(1), lkind) + desat_answer = real(DTABLE(1), lkind) + esat = 0._lkind ; desat = 0.0_lkind + call lookup_es_des(temp,esat,desat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es_des_0d TCMIN') + call check_answer_0d(desat_answer, desat, 'test_lookup_es_des_0d TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N), DTABLE(N) respectively + temp = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE(N), lkind) + desat_answer = real(DTABLE(N), lkind) + esat = 0._lkind ; desat = 0.0_lkind + call lookup_es_des(temp,esat,desat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es_des_0d TCMAX') + call check_answer_0d(desat_answer, desat, 'test_lookup_es_des_0d TCMAX') + + + !-----1d test-------! + !> test lookup_es + !! at temp=TCMIN, the answers should be TABLE(1) + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE(1) + call lookup_es(temp_1d,esat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es_1d TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N) + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE(N) + call lookup_es(temp_1d,esat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es_1d TCMAX') + + !> test lookup_des + !! at temp=TCMIN, the answers should be DTABLE(1) + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_1d = DTABLE(1) + call lookup_des(temp_1d,desat_1d) + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_des_1d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE(N) + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_1d = DTABLE(N) + call lookup_des(temp_1d,desat_1d) + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_des_1d TCMAX') + + !> test lookup_es_des + !! at temp=TCMIN, the answers should be TABLE(1) and DTABLE(1) respectively + esat_1d = 0._lkind ; desat_1d = 0._lkind + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE(1) + desat_answer_1d = DTABLE(1) + call lookup_es_des(temp_1d,esat_1d,desat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es_des_1d TCMIN') + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_es_des_1d TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N) and DTABLE(N) respectively + esat_1d = 0._lkind ; desat_1d = 0._lkind + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE(N) + desat_answer_1d = DTABLE(N) + call lookup_es_des(temp_1d,esat_1d,desat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es_des_1d TCMAX') + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_es_des_1d TCMAX') + + !-----2d test-------! + !> test lookup_es + !! at temp=TCMIN, the answers should be TABLE(1) + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_2d = real(TABLE(1),lkind) + call lookup_es(temp_2d,esat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es_2d TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N) + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_2d = real(TABLE(N),lkind) + call lookup_es(temp_2d,esat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es_2d TCMAX') + + !> test lookup_des + !! at temp=TCMIN, the answers should be DTABLE(1) + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_2d = DTABLE(1) + call lookup_des(temp_2d,desat_2d) + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_des_2d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE(N) + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_2d = DTABLE(N) + call lookup_des(temp_2d,desat_2d) + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_des_2d TCMAX') + + !> test lookup_es_des + !! at temp=TCMIN, the answers should be TABLE(1) and DTABLE(1) respectively + esat_2d = 0._lkind ; desat_2d = 0._lkind + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_2d = TABLE(1) + desat_answer_2d = DTABLE(1) + call lookup_es_des(temp_2d,esat_2d,desat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es_des_2d TCMIN') + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_es_des_2d TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N) and DTABLE(N) respectively + esat_2d = 0._lkind ; desat_2d = 0._lkind + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_2d = TABLE(N) + desat_answer_2d = DTABLE(N) + call lookup_es_des(temp_2d,esat_2d,desat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es_des_2d TCMAX') + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_es_des_2d TCMAX') + + !-----3d test-------! + !> test lookup_es + !! at temp=TCMIN, the answers should be TABLE(1) + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE(1) + call lookup_es(temp_3d,esat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es_3d precision TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N) + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE(N) + call lookup_es(temp_3d,esat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es_3d TCMAX') + + !> test lookup_des + !! at temp=TCMIN, the answers should be DTABLE(1) + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_3d = DTABLE(1) + call lookup_des(temp_3d,desat_3d) + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_des_3d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE(N) + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_3d = DTABLE(N) + call lookup_des(temp_3d,desat_3d) + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_des_3d TCMAX') + + !> test lookup_es_des + !! at temp=TCMIN, the answers should be TABLE(1) and DTABLE(1) respectively + esat_3d = 0._lkind ; desat_3d = 0._lkind + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE(1) + desat_answer_3d = DTABLE(1) + call lookup_es_des(temp_3d,esat_3d,desat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es_des_3d TCMIN') + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_es_des_3d TCMIN') + !! at temp=TCMAX, the answers should be TABLE(N) and DTABLE(N) respectively + esat_3d = 0._lkind ; desat_3d = 0._lkind + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE(N) + desat_answer_3d = DTABLE(N) + call lookup_es_des(temp_3d,esat_3d,desat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es_des_3d TCMAX') + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_es_des_3d TCMAX') + + end subroutine test_lookup_es_des + !---------------------------------------------------------------------- + subroutine test_lookup_es2_des2 + + !> TEST: at the minimum temperature (TCMIN), the pressures should correspond to the first element in the (D)TABLE2 + !! TEST: at the maximum temperature (TCMAX), the pressures should correspond to the last element in the (D)TABLE2 + + implicit none + real(kind=TEST_SVP_KIND_) :: temp, esat, desat, esat_answer, desat_answer + real(kind=TEST_SVP_KIND_), dimension(1) :: temp_1d, esat_1d, desat_1d, esat_answer_1d, desat_answer_1d + real(kind=TEST_SVP_KIND_), dimension(1,1) :: temp_2d, esat_2d, desat_2d, esat_answer_2d, desat_answer_2d + real(kind=TEST_SVP_KIND_), dimension(1,1,1) :: temp_3d, esat_3d, desat_3d, esat_answer_3d, desat_answer_3d + + integer, parameter :: lkind=TEST_SVP_KIND_ !< local kind value; using TEST_SVP_KIND_ in cases + !! such as 1.0_TEST_SVP_KIND_ cannot be compiled with + !! with gcc compilers. + + !-----0d test-------! + !> test lookup_es2 + !! at temp=TCMIN, the answers should be TABLE2(1) + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE2(1),lkind) + call lookup_es2(temp,esat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es2_0d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) + temp = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE2(N),lkind) + !! test lookup_es2 + call lookup_es2(temp,esat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es2_0d TCMAX') + + !> test lookup_des2 + !! at temp=TCMIN, the answers should be DTABLE2(1) + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer=real(DTABLE2(1),lkind) + call lookup_des2(temp,desat) + call check_answer_0d(desat_answer, desat, 'test_lookup_des2_0d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE2(N) + temp = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer=real(DTABLE2(N),lkind) + call lookup_des2(temp,desat) + call check_answer_0d(desat_answer, desat, 'test_lookup_des2_0d TCMAX') + + !> test lookup_es2_des2 + !! at temp=TCMIN, the answers should be TABLE2(1) and DTABLE2(1) respectively + esat = 0._lkind ; desat = 0.0_lkind + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE2(1),lkind) + desat_answer=real(DTABLE2(1),lkind) + call lookup_es2_des2(temp,esat,desat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es2_des2_0d TCMIN') + call check_answer_0d(desat_answer, desat, 'test_lookup_es2_des2_0d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) and DTABLE2(N) respectively + esat = 0._lkind ; desat = 0.0_lkind + temp = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer = real(TABLE2(N),lkind) + desat_answer=real(DTABLE2(N),lkind) + call lookup_es2_des2(temp,esat,desat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es2_des2_0d TCMAX') + call check_answer_0d(desat_answer, desat, 'test_lookup_es2_des2_0d TCMAX') + + !-----1d test-------! + !> test lookup_es2 + !! at temp=TCMIN, the answers should be TABLE2(1) + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE2(1) + call lookup_es2(temp_1d,esat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es2_1d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE2(N) + call lookup_es2(temp_1d,esat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es2_1d TCMAX') + + !> test lookup_des2 + !! at temp=TCMIN, the answers should be DTABLE2(1) + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_1d = DTABLE2(1) + call lookup_des2(temp_1d,desat_1d) + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_des2_1d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE2(N) + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_1d = DTABLE2(N) + call lookup_des2(temp_1d,desat_1d) + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_des2_1d TCMAX') + + !> test lookup_es2_des2 + !! at temp=TCMIN, the answers should be TABLE2(1) and DTABLE2(1) respectively + esat_1d = 0._lkind ; desat_1d = 0._lkind + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE2(1) + desat_answer_1d = DTABLE2(1) + call lookup_es2_des2(temp_1d,esat_1d,desat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es2_des2_1d TCMIN') + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_es2_des2_1d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) and DTABLE2(N) respectively + esat_1d = 0._lkind ; desat_1d = 0._lkind + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_1d = TABLE2(N) + desat_answer_1d = DTABLE2(N) + call lookup_es2_des2(temp_1d,esat_1d,desat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es2_des2_1d TCMAX') + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_es2_des2_1d TCMAX') + + + !-----2d test-------! + !> test lookup_es2 + !! at temp=TCMIN, the answers should be TABLE2(1) + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_2d = TABLE2(1) + call lookup_es2(temp_2d,esat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es2_2d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_2d = TABLE2(N) + call lookup_es2(temp_2d,esat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es2_2d TCMAX') + + !> test lookup_des2 + !! at temp=TCMIN, the answers should be DTABLE2(1) + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_2d = DTABLE2(1) + call lookup_des2(temp_2d,desat_2d) + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_des2_2d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE2(N) + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_2d = DTABLE2(N) + call lookup_des2(temp_2d,desat_2d) + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_des2_2d TCMAX') + + !> test lookup_es2_des2 + !! at temp=TCMIN, the answers should be TABLE2(1) and DTABLE2(1) respectively + esat_2d = 0._lkind ; desat_2d = 0._lkind + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_2d = TABLE2(1) + desat_answer_2d = DTABLE2(1) + call lookup_es2_des2(temp_2d,esat_2d,desat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es2_des2_2d TCMIN') + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_es2_des2_2d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) and DTABLE2(N) respectively + esat_2d = 0._lkind ; desat_2d = 0._lkind + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_2d = TABLE2(N) + desat_answer_2d = DTABLE2(N) + call lookup_es2_des2(temp_2d,esat_2d,desat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es2_des2_2d TCMAX') + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_es2_des2_2d TCMAX') + + + !-----3d test-------! + !> test lookup_es2 + !! at temp=TCMIN, the answers should be TABLE2(1) + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE2(1) + call lookup_es2(temp_3d,esat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es2_3d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE2(N) + call lookup_es2(temp_3d,esat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es2_3d TCMAX') + + !> test lookup_des2 + !! at temp=TCMIN, the answers should be DTABLE2(1) + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_3d = DTABLE2(1) + call lookup_des2(temp_3d,desat_3d) + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_des2_3d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE2(N) + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_3d = DTABLE2(N) + call lookup_des2(temp_3d,desat_3d) + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_des2_3d TCMAX') + + !> test lookup_es2_des2 + !! at temp=TCMIN, the answers should be TABLE2(1) and DTABLE2(1) respectively + esat_3d = 0._lkind ; desat_3d = 0._lkind + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE2(1) + desat_answer_3d = DTABLE2(1) + call lookup_es2_des2(temp_3d,esat_3d,desat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es2_des2_3d TCMIN') + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_es2_des2_3d TCMIN') + !! at temp=TCMAX, the answers should be TABLE2(N) and DTABLE2(N) respectively + esat_3d = 0._lkind ; desat_3d = 0._lkind + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE2(N) + desat_answer_3d = DTABLE2(N) + call lookup_es2_des2(temp_3d,esat_3d,desat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es2_des2_3d TCMAX') + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_es2_des2_3d TCMAX') + + end subroutine test_lookup_es2_des2 + !---------------------------------------------------------------------- + subroutine test_lookup_es3_des3 + + !> TEST: at the minimum temperature (TCMIN), the pressures should correspond to the first element in the (D)TABLE3 + !! TEST: at the maximum temperature (TCMAX), the pressures should correspond to the last element in the (D)TABLE3 + + implicit none + real(kind=TEST_SVP_KIND_) :: temp, esat, desat, esat_answer, desat_answer + real(kind=TEST_SVP_KIND_), dimension(1) :: temp_1d, esat_1d, desat_1d, esat_answer_1d, desat_answer_1d + real(kind=TEST_SVP_KIND_), dimension(1,1) :: temp_2d, esat_2d, desat_2d, esat_answer_2d, desat_answer_2d + real(kind=TEST_SVP_KIND_), dimension(1,1,1) :: temp_3d, esat_3d, desat_3d, esat_answer_3d, desat_answer_3d + + integer, parameter :: lkind=TEST_SVP_KIND_ !< local kind value; using TEST_SVP_KIND_ in cases + !! such as 1.0_TEST_SVP_KIND_ cannot be compiled with + !! with gcc compilers. + + !-----0d test-------! + !> test lookup_es3 + !! at temp=TCMIN, the answers should be TABLE3(1) + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer = TABLE3(1) + call lookup_es3(temp,esat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es3_0d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) + temp = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer = TABLE3(N) + call lookup_es3(temp,esat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es3_0d TCMAX') + + !> test lookup_des3 + !! at temp=TCMIN, the answers should be DTABLE3(1) + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer=DTABLE3(1) + call lookup_des3(temp,desat) + call check_answer_0d(desat_answer, desat, 'test_lookup_des3_0d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE3(N) + temp = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer=DTABLE3(N) + call lookup_des3(temp,desat) + call check_answer_0d(desat_answer, desat, 'test_lookup_des3_0d TCMAX') + + !> test lookup_es3_des3 + !! at temp=TCMIN, the answers should be TABLE3(1) and DTABLE3(1) respectively + esat = 0._lkind ; desat = 0.0_lkind + temp = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer = TABLE3(1) + desat_answer = DTABLE3(1) + call lookup_es3_des3(temp,esat,desat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es3_des3_0d TCMIN') + call check_answer_0d(desat_answer, desat, 'test_lookup_es3_des3_0d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) and DTABLE3(N) respectively + esat = 0._lkind ; desat = 0.0_lkind + temp = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer = TABLE3(N) ; desat_answer=DTABLE3(N) + call lookup_es3_des3(temp,esat,desat) + call check_answer_0d(esat_answer, esat, 'test_lookup_es3_des3_0d TCMAX') + call check_answer_0d(desat_answer, desat, 'test_lookup_es3_des3_0d TCMAX') + + !-----1d test-------! + !> test lookup_es3 + !! at temp=TCMIN, the answers should be TABLE3(1) + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_1d = real(TABLE3(1),lkind) + call lookup_es3(temp_1d,esat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es3_1d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_1d = real(TABLE3(N),lkind) + call lookup_es3(temp_1d,esat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es3_1d TCMAX') + + !> test looup_des3 + !! at temp=TCMIN, the answers should be DTABLE3(1) + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_1d = real(DTABLE3(1),lkind) + call lookup_des3(temp_1d,desat_1d) + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_des3_1d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE3(N) + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_1d = real(DTABLE3(N),lkind) + call lookup_des3(temp_1d,desat_1d) + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_des3_1d TCMAX') + + !> test lookup_es3_des3 + !! at temp=TCMIN, the answers should be TABLE3(1) and DTABLE3(1) respectively + esat_1d = 0._lkind ; desat_1d = 0._lkind + temp_1d(1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_1d = real(TABLE3(1),lkind) + desat_answer_1d = real(DTABLE3(1),lkind) + call lookup_es3_des3(temp_1d,esat_1d,desat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es3_des3_1d TCMIN') + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_es3_des3_1d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) and DTABLE3(N) respectively + esat_1d = 0._lkind ; desat_1d = 0._lkind + temp_1d(1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_1d = real(TABLE3(N),lkind) + desat_answer_1d = real(DTABLE3(N),lkind) + call lookup_es3_des3(temp_1d,esat_1d,desat_1d) + call check_answer_1d(esat_answer_1d, esat_1d, 'test_lookup_es3_des3_1d TCMAX') + call check_answer_1d(desat_answer_1d, desat_1d, 'test_lookup_es3_des3_1d TCMAX') + + + !-----2d test-------! + !> test lookup_es3 + !! at temp=TCMIN, the answers should be TABLE3(1) + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_2d = real(TABLE3(1),lkind) + call lookup_es3(temp_2d,esat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es3_2d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_2d = real(TABLE3(N),lkind) + call lookup_es3(temp_2d,esat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es3_2d TCMAX') + + !> test lookup_des3 + !! at temp=TCMIN, the answers should be DTABLE3(1) + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_2d = real(DTABLE3(1),lkind) + call lookup_des3(temp_2d,desat_2d) + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_des3_2d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE3(N) + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_2d = real(DTABLE3(N),lkind) + call lookup_des3(temp_2d,desat_2d) + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_des3_2d TCMAX') + + !> test lookup_es3_des3 + !! at temp=TCMIN, the answers should be TABLE3(1) and DTABLE3(1) respectively + esat_2d = 0._lkind ; desat_2d = 0._lkind + temp_2d(1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_2d = real(TABLE3(1),lkind) + desat_answer_2d = real(DTABLE3(1),lkind) + call lookup_es3_des3(temp_2d,esat_2d,desat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es3_des3_2d TCMIN') + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_es3_des3_2d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) and DTABLE3(N) respectively + esat_2d = 0._lkind ; desat_2d = 0._lkind + temp_2d(1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_2d = real(TABLE3(N),lkind) + desat_answer_2d = real(DTABLE3(N),lkind) + call lookup_es3_des3(temp_2d,esat_2d,desat_2d) + call check_answer_2d(esat_answer_2d, esat_2d, 'test_lookup_es3_des3_2d TCMAX') + call check_answer_2d(desat_answer_2d, desat_2d, 'test_lookup_es3_des3_2d TCMAX') + + !-----3d test-------! + !> test lookup_es3 + !! at temp=TCMIN, the answers should be TABLE3(1) + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE3(1) + call lookup_es3(temp_3d,esat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es3_3d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE3(N) + call lookup_es3(temp_3d,esat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es3_3d TCMAX') + + !> test lookup_des3 + !! at temp=TCMIN, the answers should be DTABLE3(1) + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + desat_answer_3d = DTABLE3(1) + call lookup_des3(temp_3d,desat_3d) + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_des3_3d TCMIN') + !! at temp=TCMAX, the answers should be DTABLE3(N) + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + desat_answer_3d = DTABLE3(N) + call lookup_des3(temp_3d,desat_3d) + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_des3_3d TCMAX') + + !> test lookup_es3_des3 + esat_3d = 0._lkind ; desat_3d = 0._lkind + temp_3d(1,1,1) = real(TCMIN,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE3(1) + desat_answer_3d = DTABLE3(1) + call lookup_es3_des3(temp_3d,esat_3d,desat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es3_des3_3d TCMIN') + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_es3_des3_3d TCMIN') + !! at temp=TCMAX, the answers should be TABLE3(N) and DTABLE3(N) respectively + esat_3d = 0._lkind ; desat_3d = 0._lkind + temp_3d(1,1,1) = real(TCMAX,lkind) + real(TFREEZE,lkind) + esat_answer_3d = TABLE3(N) + desat_answer_3d = DTABLE3(N) + call lookup_es3_des3(temp_3d,esat_3d,desat_3d) + call check_answer_3d(esat_answer_3d, esat_3d, 'test_lookup_es3_des3_3d TCMAX') + call check_answer_3d(desat_answer_3d, desat_3d, 'test_lookup_es3_des3_3d TCMAX') + + + end subroutine test_lookup_es3_des3 + !---------------------------------------------------------------------- + subroutine check_answer_0d(answer,fms_result,whoami) + + implicit none + real(TEST_SVP_KIND_), intent(in) :: answer, fms_result + character(len=*), intent(in) :: whoami + + if(answer .ne. fms_result) then + write(*,*) 'Expected ', answer, ' but got ', fms_result + call mpp_error(FATAL,'ERROR:'//trim(whoami) ) + end if + + end subroutine check_answer_0d + !----------------------------------------------------------------------- + subroutine check_answer_1d(answer,fms_result,whoami) + + implicit none + real(TEST_SVP_KIND_), dimension(:), intent(in) :: answer, fms_result + character(len=*), intent(in) :: whoami + + if(answer(1) .ne. fms_result(1)) then + write(*,*) 'Expected ', answer(1), ' but got ', fms_result(1) + call mpp_error(FATAL,'ERROR:'//trim(whoami) ) + end if + + end subroutine check_answer_1d + !----------------------------------------------------------------------- + subroutine check_answer_2d(answer,fms_result,whoami) + + implicit none + real(TEST_SVP_KIND_), dimension(:,:), intent(in) :: answer, fms_result + character(len=*), intent(in) :: whoami + + if(answer(1,1) .ne. fms_result(1,1)) then + write(*,*) 'Expected ', answer(1,1), ' but got ', fms_result(1,1) + call mpp_error(FATAL,'ERROR:'//trim(whoami) ) + end if + + end subroutine check_answer_2d + !----------------------------------------------------------------------- + subroutine check_answer_3d(answer,fms_result,whoami) + + implicit none + real(TEST_SVP_KIND_), dimension(:,:,:), intent(in) :: answer, fms_result + character(len=*), intent(in) :: whoami + + if(answer(1,1,1) .ne. fms_result(1,1,1)) then + write(*,*) 'Expected ', answer(1,1,1), ' but got ', fms_result(1,1,1) + call mpp_error(FATAL,'ERROR:'//trim(whoami) ) + end if + + end subroutine check_answer_3d + !----------------------------------------------------------------------- + subroutine compute_tables + + !> This subroutine is taken from the sat_vapor_pres_init_k subroutine in sat_vapor_pres/include + !! Thus, sat_vapor_pres_init_k subroutine is not tested and is assumed to be correct. + !! The TABLE* and DTABLE* values are required to test compute_qs, compute_mrs, and the 3 flavors of + !! loopup_es_des subroutines + !! The TABLE* and DTABLE* values are computed with r8_precision. + + + real(kind=r8_kind), dimension(3) :: tem, es + real(kind=r8_kind) :: dtres, tminl, dtinvl, tepsl, tinrc, tfact + integer :: i + + + !> TCMAX, TCMIN,TFREEZE are module level variables in sat_vapor_pres_mod + dtres = (real(TCMAX,r8_kind)-real(TCMIN,r8_kind))/real(N-1,r8_kind) + tminl = real(TCMIN,r8_kind)+real(TFREEZE,r8_kind) + dtinvl = 1.0_r8_kind/dtres + tepsl = 0.5_r8_kind*dtres + tinrc = 0.1_r8_kind*dtres + tfact = 5.0_r8_kind*dtinvl + + do i = 1, N + tem(1) = tminl + dtres*real(i-1,r8_kind) + tem(2) = tem(1)-tinrc + tem(3) = tem(1)+tinrc + es = compute_es_k (tem, real(TFREEZE,r8_kind)) + TABLE(i) = es(1) + DTABLE(i) = (es(3)-es(2))*tfact + enddo + + do i = 1, N + tem(1) = tminl + dtres*real(i-1,r8_kind) + tem(2) = tem(1)-tinrc + tem(3) = tem(1)+tinrc + !> pass in flag to force all values to be wrt liquid + es = compute_es_liq_k (tem, real(TFREEZE,r8_kind)) + TABLE2(i) = es(1) + DTABLE2(i) = (es(3)-es(2))*tfact + enddo + + do i = 1, N + tem(1) = tminl + dtres*real(i-1,r8_kind) + tem(2) = tem(1)-tinrc + tem(3) = tem(1)+tinrc + !> pass in flag to force all values to be wrt liquid + es = compute_es_liq_ice_k (tem, real(TFREEZE,r8_kind)) + TABLE3(i) = es(1) + DTABLE3(i) = (es(3)-es(2))*tfact + enddo + + end subroutine compute_tables + !----------------------------------------------------------------------- + function compute_es_k(tem, TFREEZE) result (es) + + !> This subroutine is taken from the compute_es_k subroutine in sat_vapor_pres/include + !! and is required to compute the TABLE and DTABLE values. + !! Thus, compute_es_k subroutine is not tested and is assumed to be correct. + !! Since the TABLE and DTABLE values are computed with r8_precision, all variables here + !! are in r8_kind precision. + + + real(kind=r8_kind), intent(in) :: tem(:), TFREEZE + real(kind=r8_kind) :: es(size(tem,1)) + + real(kind=r8_kind) :: x, esice, esh2o, TBASW, TBASI + integer :: i + + real(kind=r8_kind), parameter :: ESBASW = 101324.60_r8_kind + real(kind=r8_kind), parameter :: ESBASI = 610.71_r8_kind + + real(r8_kind), parameter :: one=1.0_r8_kind + real(r8_kind), parameter :: ten=10.0_r8_kind + + TBASW = TFREEZE+100.0_r8_kind + TBASI = TFREEZE + do i = 1, size(tem) + + !> compute es over ice + + if (tem(i) < TBASI) then + x = -9.09718_r8_kind*(TBASI/tem(i)-one) & + -3.56654_r8_kind*log10(TBASI/tem(i)) & + +0.876793_r8_kind*(one-tem(i)/TBASI) + log10(ESBASI) + esice =ten**(x) + else + esice = 0.0_r8_kind + endif + + !> compute es over water greater than -20 c. + !! values over 100 c may not be valid + !! see smithsonian meteorological tables page 350. + + if (tem(i) > -20.0_r8_kind+TBASI) then + x = -7.90298_r8_kind*(TBASW/tem(i)-one) & + +5.02808_r8_kind*log10(TBASW/tem(i)) & + -1.3816e-07_r8_kind*(ten**((one-tem(i)/TBASW)*11.344d0)-one) & + +8.1328e-03_r8_kind*(ten**((TBASW/tem(i)-one)*(-3.49149d0))-one) & + +log10(ESBASW) + esh2o = ten**(x) + else + esh2o = 0.0_r8_kind + endif + + !> derive blended es over ice and supercooled water between -20c and 0c + + if (tem(i) <= -20.0_r8_kind+TBASI) then + es(i) = esice + else if (tem(i) >= TBASI) then + es(i) = esh2o + else + es(i) = 0.05_r8_kind*((TBASI-tem(i))*esice + (tem(i)-TBASI+20.0_r8_kind)*esh2o) + endif + + enddo + + end function compute_es_k +!----------------------------------------------------------------------- + function compute_es_liq_k(tem, TFREEZE) result (es) + + !> This subroutine is taken from the compute_es_liq_k subroutine in sat_vapor_pres/include + !! and is required to compute the TABLE2 and DTABLE2 values. + !! Thus, compute_es_liq_k subroutine is not tested and is assumed to be correct. + !! Since the TABLE2 and DTABLE2 values are computed with r8_precision, all variables here + !! are in r8_kind precision. + + real(kind=r8_kind), intent(in) :: tem(:), TFREEZE + real(kind=r8_kind) :: es(size(tem,1)) + + real(kind=r8_kind) :: x, esh2o, TBASW + integer :: i + + real(kind=r8_kind), parameter :: one=1.0_r8_kind + real(kind=r8_kind), parameter :: ten=10.0_r8_kind + real(kind=r8_kind), parameter :: ESBASW = 101324.60_r8_kind + + + TBASW = TFREEZE+100.0_r8_kind + + do i = 1, size(tem) +!> compute es over water for all temps. +!! values over 100 c may not be valid +!! see smithsonian meteorological tables page 350. + x = -7.90298_r8_kind*(TBASW/tem(i)-one) & + +5.02808_r8_kind*log10(TBASW/tem(i)) & + -1.3816e-07_r8_kind*(ten**((one-tem(i)/TBASW)*11.344_r8_kind)-one) & + +8.1328e-03_r8_kind*(ten**((TBASW/tem(i)-one)*-3.49149_r8_kind)-one)& + +log10(ESBASW) + esh2o = ten**(x) + es(i) = esh2o + + enddo + + end function compute_es_liq_k + !----------------------------------------------------------------------- + function compute_es_liq_ice_k(tem, TFREEZE) result (es) + + !> This subroutine is taken from the compute_es_liq_ice_k subroutine in sat_vapor_pres/include + !! and is required to compute the TABLE3 and DTABLE3 values. + !! Thus, compute_es_liq_ice_k subroutine is not tested and is assumed to be correct. + !! Since the TABLE3 and DTABLE3 values are computed with r8_precision, all variables here + !! are in r8_kind precision. + + real(kind=r8_kind), intent(in) :: tem(:), TFREEZE + real(kind=r8_kind) :: es(size(tem,1)) + + real(kind=r8_kind) :: x, TBASW, TBASI + integer :: i + + real(kind=r8_kind), parameter :: ESBASW = 101324.60_r8_kind + real(kind=r8_kind), parameter :: ESBASI = 610.71_r8_kind + real(kind=r8_kind), parameter :: one= 1.0_r8_kind + real(kind=r8_kind), parameter :: ten= 10.0_r8_kind + + TBASW = TFREEZE+100.0_r8_kind + TBASI = TFREEZE + + do i = 1, size(tem) + + if (tem(i) < TBASI) then + +!> compute es over ice + + x = -9.09718_r8_kind*(TBASI/tem(i)-one) & + -3.56654_r8_kind*log10(TBASI/tem(i)) & + +0.876793_r8_kind*(one-tem(i)/TBASI) + log10(ESBASI) + es(i) =ten**(x) + else + +!> compute es over water +!! values over 100 c may not be valid +!! see smithsonian meteorological tables page 350. + + x = -7.90298_r8_kind*(TBASW/tem(i)-one) & + +5.02808_r8_kind*log10(TBASW/tem(i)) & + -1.3816e-07_r8_kind*(ten**((one-tem(i)/TBASW)*11.344_r8_kind)-one) & + +8.1328e-03_r8_kind*(ten**((TBASW/tem(i)-one)*(-3.49149_r8_kind))-one) & + +log10(ESBASW) + es(i) = ten**(x) + endif + enddo + + end function compute_es_liq_ice_k + !----------------------------------------------------------------------- +end program test_sat_vap_pressure diff --git a/test_fms/sat_vapor_pres/test_sat_vapor_pres.sh b/test_fms/sat_vapor_pres/test_sat_vapor_pres.sh new file mode 100755 index 0000000000..7e22b88a8f --- /dev/null +++ b/test_fms/sat_vapor_pres/test_sat_vapor_pres.sh @@ -0,0 +1,116 @@ +#* the Free Software Foundation, either version 3 of the License, or (at +#* your option) any later version. +#* +#* FMS is distributed in the hope that it will be useful, but WITHOUT +#* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +#* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +#* for more details. +#* +#* You should have received a copy of the GNU Lesser General Public +#* License along with FMS. If not, see . +#*********************************************************************** + +# This is part of the GFDL FMS package. This is a shell script to +# execute tests in the test_fms/horiz_interp directory. + +# Copyright 2021 Seth Underwood + +# Set common test settings. +. ../test-lib.sh + +# Prepare the directory to run the tests. +cat << EOF > input.nml +&sat_vapor_pres_nml + construct_table_wrt_liq = .true., + construct_table_wrt_liq_and_ice = .true., + use_exact_qs = .true. +/ +EOF + + +##### +cat < test_sat_vapor_pres.nml +&test_sat_vapor_pres_nml + test1=.true. + test2=.false. + test3=.false. + test4=.false. + test5=.false. + / +EOF +test_expect_success "test_compute_qs_r4" ' + mpirun -n 1 ./test_sat_vapor_pres_r4 + ' +test_expect_success "test_compute_qs_r8" ' + mpirun -n 1 ./test_sat_vapor_pres_r8 + ' + +#### +cat < test_sat_vapor_pres.nml +&test_sat_vapor_pres_nml + test1=.false. + test2=.true. + test3=.false. + test4=.false. + test5=.false. + / +EOF +test_expect_success "test_compute_mrs_r4" ' + mpirun -n 1 ./test_sat_vapor_pres_r4 + ' +test_expect_success "test_compute_mrs_r8" ' + mpirun -n 1 ./test_sat_vapor_pres_r8 + ' + +#### +cat < test_sat_vapor_pres.nml +&test_sat_vapor_pres_nml + test1=.false. + test2=.false. + test3=.true. + test4=.false. + test5=.false. + / +EOF +test_expect_success "test_lookup_es_des_r4" ' + mpirun -n 1 ./test_sat_vapor_pres_r4 + ' +test_expect_success "test_lookup_es_des_r8" ' + mpirun -n 1 ./test_sat_vapor_pres_r8 + ' + +#### +cat < test_sat_vapor_pres.nml +&test_sat_vapor_pres_nml + test1=.false. + test2=.false. + test3=.false. + test4=.true. + test5=.false. + / +EOF +test_expect_success "test_lookup_es2_des2_r4" ' + mpirun -n 1 ./test_sat_vapor_pres_r4 + ' +test_expect_success "test_lookup_es2_des2_r8" ' + mpirun -n 1 ./test_sat_vapor_pres_r8 + ' + +#### +cat < test_sat_vapor_pres.nml +&test_sat_vapor_pres_nml + test1=.false. + test2=.false. + test3=.false. + test4=.false. + test5=.true. + / +EOF +test_expect_success "test_lookup_es3_des3_r4" ' + mpirun -n 1 ./test_sat_vapor_pres_r4 + ' +test_expect_success "test_lookup_es3_des3_r8" ' + mpirun -n 1 ./test_sat_vapor_pres_r8 + ' + +test_done From af15993b06c8492813b4728a4d0eeed0550da616 Mon Sep 17 00:00:00 2001 From: dkokron Date: Fri, 16 Jun 2023 15:04:10 -0500 Subject: [PATCH 19/51] fix: replace current_peset_num with 'n' which should be the active pelist. (#1246) --- mpp/include/mpp_transmit_mpi.fh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mpp/include/mpp_transmit_mpi.fh b/mpp/include/mpp_transmit_mpi.fh index 023c2d5124..fa820300c1 100644 --- a/mpp/include/mpp_transmit_mpi.fh +++ b/mpp/include/mpp_transmit_mpi.fh @@ -182,7 +182,7 @@ 'T=',tick, ' PE=',pe, ' MPP_BROADCAST begin: from_pe, length=', from_pe, length end if - if( .NOT.ANY(from_pe.EQ.peset(current_peset_num)%list) ) & + if( .NOT.ANY(from_pe.EQ.peset(n)%list) ) & call mpp_error( FATAL, 'MPP_BROADCAST: broadcasting from invalid PE.' ) if( debug .and. (current_clock.NE.0) )call SYSTEM_CLOCK(start_tick) From de0379877983bb75673ef7c555d1d5d55736ae9b Mon Sep 17 00:00:00 2001 From: laurenchilutti <60401591+laurenchilutti@users.noreply.github.com> Date: Fri, 16 Jun 2023 16:07:06 -0400 Subject: [PATCH 20/51] fix: gcc class(*) bug workaround for character arrays (#1163) --- fms2_io/include/array_utils_char.inc | 135 ++++++++++++++++++++- fms2_io/include/netcdf_read_data.inc | 165 +++++++++++++++----------- fms2_io/include/netcdf_write_data.inc | 152 ++++++++++++++---------- mosaic2/mosaic2.F90 | 15 +++ 4 files changed, 332 insertions(+), 135 deletions(-) diff --git a/fms2_io/include/array_utils_char.inc b/fms2_io/include/array_utils_char.inc index 884f1f3cda..528aa5520b 100644 --- a/fms2_io/include/array_utils_char.inc +++ b/fms2_io/include/array_utils_char.inc @@ -23,79 +23,202 @@ !> @{ !> @brief Allocate character arrays using an input array of sizes. -subroutine allocate_array_char_1d(buf, sizes) +subroutine allocate_array_char_1d(buf, sizes, initialize) character(len=*), dimension(:), allocatable, intent(inout) :: buf !< Array that will be allocated. integer, dimension(1), intent(in) :: sizes !< Array of dimension sizes. + logical, intent(in), optional :: initialize !< Optional argument when true will initialize with a blank string. + + logical :: init !< local variable for initialize + integer :: i, c !< for looping + + init = .false. + if (present(initialize)) init = initialize if (allocated(buf)) then deallocate(buf) endif allocate(buf(sizes(1))) + + if (init) then + do i = 1, sizes(1) + do c = 1, len(buf(i)) + buf(i)(c:c) = " " + enddo + enddo + endif + end subroutine allocate_array_char_1d !> @brief Allocate character arrays using an input array of sizes. -subroutine allocate_array_char_2d(buf, sizes) +subroutine allocate_array_char_2d(buf, sizes, initialize) character(len=*), dimension(:,:), allocatable, intent(inout) :: buf !< Array that will be allocated. integer, dimension(2), intent(in) :: sizes !< Array of dimension sizes. + logical, intent(in), optional :: initialize !< Optional argument when true will initialize with a blank string. + + logical :: init !< local variable for initialize + integer :: i, j, c !< for looping + + init = .false. + if (present(initialize)) init = initialize if (allocated(buf)) then deallocate(buf) endif allocate(buf(sizes(1), sizes(2))) + + if (init) then + do j = 1, sizes(2) + do i = 1, sizes(1) + do c = 1, len(buf(i,j)) + buf(i,j)(c:c) = " " + enddo + enddo + enddo + endif + end subroutine allocate_array_char_2d !> @brief Allocate character arrays using an input array of sizes. -subroutine allocate_array_char_3d(buf, sizes) +subroutine allocate_array_char_3d(buf, sizes, initialize) character(len=*), dimension(:,:,:), allocatable, intent(inout) :: buf !< Array that will be allocated. integer, dimension(3), intent(in) :: sizes !< Array of dimension sizes. + logical, intent(in), optional :: initialize !< Optional argument when true will initialize with a blank string. + + logical :: init !< local variable for initialize + integer :: i, j, k, c !< for looping + + init = .false. + if (present(initialize)) init = initialize if (allocated(buf)) then deallocate(buf) endif allocate(buf(sizes(1), sizes(2), sizes(3))) + + if (init) then + do k = 1, sizes(3) + do j = 1, sizes(2) + do i = 1, sizes(1) + do c = 1, len(buf(i,j,k)) + buf(i,j,k)(c:c) = " " + enddo + enddo + enddo + enddo + endif + end subroutine allocate_array_char_3d !> @brief Allocate character arrays using an input array of sizes. -subroutine allocate_array_char_4d(buf, sizes) +subroutine allocate_array_char_4d(buf, sizes, initialize) character(len=*), dimension(:,:,:,:), allocatable, intent(inout) :: buf !< Array that will be allocated. integer, dimension(4), intent(in) :: sizes !< Array of dimension sizes. + logical, intent(in), optional :: initialize !< Optional argument when true will initialize with a blank string. + + logical :: init !< local variable for initialize + integer :: i, j, k, l, c !< for looping + + init = .false. + if (present(initialize)) init = initialize if (allocated(buf)) then deallocate(buf) endif allocate(buf(sizes(1), sizes(2), sizes(3), sizes(4))) + + if (init) then + do l = 1, sizes(4) + do k = 1, sizes(3) + do j = 1, sizes(2) + do i = 1, sizes(1) + do c = 1, len(buf(i,j,k,l)) + buf(i,j,k,l)(c:c) = " " + enddo + enddo + enddo + enddo + enddo + endif end subroutine allocate_array_char_4d !> @brief Allocate character arrays using an input array of sizes. -subroutine allocate_array_char_5d(buf, sizes) +subroutine allocate_array_char_5d(buf, sizes, initialize) character(len=*), dimension(:,:,:,:,:), allocatable, intent(inout) :: buf !< Array that will be allocated. integer, dimension(5), intent(in) :: sizes !< Array of dimension sizes. + logical, intent(in), optional :: initialize !< Optional argument when true will initialize with a blank string. + + logical :: init !< local variable for initialize + integer :: i, j, k, l, m, c !< for looping + + init = .false. + if (present(initialize)) init = initialize if (allocated(buf)) then deallocate(buf) endif allocate(buf(sizes(1), sizes(2), sizes(3), sizes(4), sizes(5))) + + if (init) then + do m = 1, sizes(5) + do l = 1, sizes(4) + do k = 1, sizes(3) + do j = 1, sizes(2) + do i = 1, sizes(1) + do c = 1, len(buf(i,j,k,l,m)) + buf(i,j,k,l,m)(c:c) = " " + enddo + enddo + enddo + enddo + enddo + enddo + endif end subroutine allocate_array_char_5d !> @brief Allocate character arrays using an input array of sizes. -subroutine allocate_array_char_6d(buf, sizes) +subroutine allocate_array_char_6d(buf, sizes, initialize) character(len=*), dimension(:,:,:,:,:,:), allocatable, intent(inout) :: buf !< Array that will be allocated. integer, dimension(6), intent(in) :: sizes !< Array of dimension sizes. + logical, intent(in), optional :: initialize !< Optional argument when true will initialize with a blank string. + + logical :: init !< local variable for initialize + integer :: i, j, k, l, m, n, c !< for looping + + init = .false. + if (present(initialize)) init = initialize if (allocated(buf)) then deallocate(buf) endif allocate(buf(sizes(1), sizes(2), sizes(3), sizes(4), sizes(5), sizes(6))) + + if (init) then + do n = 1, sizes(6) + do m = 1, sizes(5) + do l = 1, sizes(4) + do k = 1, sizes(3) + do j = 1, sizes(2) + do i = 1, sizes(1) + do c = 1, len(buf(i,j,k,l,m,n)) + buf(i,j,k,l,m,n)(c:c) = " " + enddo + enddo + enddo + enddo + enddo + enddo + enddo + endif end subroutine allocate_array_char_6d !> @} diff --git a/fms2_io/include/netcdf_read_data.inc b/fms2_io/include/netcdf_read_data.inc index 3a5e7e3733..66c1484f29 100644 --- a/fms2_io/include/netcdf_read_data.inc +++ b/fms2_io/include/netcdf_read_data.inc @@ -23,6 +23,102 @@ !> @addtogroup netcdf_io_mod !> @{ +!> @brief Character read 0d function. +subroutine char_read_0d(fileobj, variable_name, buf, corner, append_error_msg, err, varid) + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + character(len=*), intent(inout) :: buf !< Array that the data will be read into + integer, intent(in), optional :: corner !< Index of the string to read if the variable + !! contains a 1D array of strings. + character(len=200), intent(in):: append_error_msg !< Msg to be appended to FATAL error message + integer, intent(inout) :: err + integer, intent(in) :: varid + + integer, dimension(2) :: start + integer :: ndims + character, dimension(:), allocatable :: charbuf + integer, dimension(:), allocatable :: dimsizes + integer :: i + + start(:) = 1 + ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) + allocate(dimsizes(ndims)) + call get_variable_size(fileobj, variable_name, dimsizes, broadcast=.false.) + allocate(charbuf(dimsizes(1))) + charbuf(:) = "" + if (ndims .eq. 2) then + if (present(corner)) then + start(2) = corner + endif + dimsizes(2) = 1 + elseif (ndims .gt. 2) then + call error("Only scalar and 1d string values are currently supported: "//trim(append_error_msg)) + endif + err = nf90_get_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) + if (len(buf) .lt. dimsizes(1)) then + call error("character buffer is too small; increase length: "//trim(append_error_msg)) + endif + buf = "" + do i = 1, dimsizes(1) + if (charbuf(i) .eq. char(0)) then + exit + endif + buf(i:i) = charbuf(i) + enddo + deallocate(charbuf) + deallocate(dimsizes) +end subroutine char_read_0d + +!> @brief Character read 1d function. +subroutine char_read_1d(fileobj, variable_name, buf, c, append_error_msg, err, varid) + + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + character(len=*), dimension(:), intent(inout) :: buf !< Array that the data + !! will be read into. + integer, dimension(2), intent(in) :: c + character(len=200), intent(in) :: append_error_msg !< Msg to be appended to FATAL error message + integer, intent(inout) :: err + integer, intent(in) :: varid + + integer :: ndims + integer, dimension(2) :: start + integer, dimension(2) :: dimsizes + character, dimension(:,:), allocatable :: charbuf + character(len=1024) :: sbuf + integer :: i + integer :: j + + ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) + if (ndims .ne. 2) then + call error(trim(variable_name)//"must be 2d dimensional in netcdf file.") + endif + start(1) = 1 + start(2) = c(1) + call get_variable_size(fileobj, variable_name, dimsizes, .false.) + dimsizes(2) = dimsizes(2) - start(2) + 1 + call allocate_array(charbuf, dimsizes, initialize=.true.) + err = nf90_get_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) + if (len(buf(1)) .lt. dimsizes(1)) then + call error("character buffer is too small; increase length: "//trim(append_error_msg)) + endif + if (size(buf) .lt. dimsizes(2)) then + call error("incorrect buffer array size:: "//trim(append_error_msg)) + endif + do i = start(2), start(2)+dimsizes(2)-1 + sbuf = "" + do j = 1, dimsizes(1) + if (charbuf(j, i-start(2)+1) .eq. char(0)) then + exit + endif + sbuf(j:j) = charbuf(j, i-start(2)+1) + enddo + call string_copy(buf(i-start(2)+1), sbuf) + enddo + deallocate(charbuf) + +end subroutine char_read_1d + !> @brief Read in data from a variable in a netcdf file. subroutine netcdf_read_data_0d(fileobj, variable_name, buf, unlim_dim_level, & corner, broadcast) @@ -45,11 +141,6 @@ subroutine netcdf_read_data_0d(fileobj, variable_name, buf, unlim_dim_level, & integer :: varid integer :: unlim_dim_index integer, dimension(1) :: c - integer, dimension(2) :: start - integer :: ndims - character, dimension(:), allocatable :: charbuf - integer, dimension(:), allocatable :: dimsizes - integer :: i character(len=1024), dimension(1) :: buf1d character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message @@ -81,33 +172,7 @@ subroutine netcdf_read_data_0d(fileobj, variable_name, buf, unlim_dim_level, & type is (real(kind=r8_kind)) err = nf90_get_var(fileobj%ncid, varid, buf, start=c) type is (character(len=*)) - start(:) = 1 - ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) - allocate(dimsizes(ndims)) - call get_variable_size(fileobj, variable_name, dimsizes, broadcast=.false.) - allocate(charbuf(dimsizes(1))) - charbuf(:) = "" - if (ndims .eq. 2) then - if (present(corner)) then - start(2) = corner - endif - dimsizes(2) = 1 - elseif (ndims .gt. 2) then - call error("Only scalar and 1d string values are currently supported: "//trim(append_error_msg)) - endif - err = nf90_get_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) - if (len(buf) .lt. dimsizes(1)) then - call error("character buffer is too small; increase length: "//trim(append_error_msg)) - endif - buf = "" - do i = 1, dimsizes(1) - if (charbuf(i) .eq. char(0)) then - exit - endif - buf(i:i) = charbuf(i) - enddo - deallocate(charbuf) - deallocate(dimsizes) + call char_read_0d(fileobj, variable_name, buf, corner, append_error_msg, err, varid) class default call error("Unsupported variable type: "//trim(append_error_msg)) end select @@ -165,13 +230,6 @@ subroutine netcdf_read_data_1d(fileobj, variable_name, buf, unlim_dim_level, & integer :: unlim_dim_index integer, dimension(2) :: c integer, dimension(2) :: e - integer :: ndims - integer, dimension(2) :: start - integer, dimension(2) :: dimsizes - character, dimension(:,:), allocatable :: charbuf - character(len=1024) :: sbuf - integer :: i - integer :: j character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message append_error_msg = "netcdf_read_data_1d: file:"//trim(fileobj%path)//"- variable:"//trim(variable_name) @@ -211,34 +269,7 @@ subroutine netcdf_read_data_1d(fileobj, variable_name, buf, unlim_dim_level, & type is (real(kind=r8_kind)) err = nf90_get_var(fileobj%ncid, varid, buf, start=c, count=e) type is (character(len=*)) - ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) - if (ndims .ne. 2) then - call error(trim(variable_name)//"must be 2d dimensional in netcdf file.") - endif - start(1) = 1 - start(2) = c(1) - call get_variable_size(fileobj, variable_name, dimsizes, .false.) - dimsizes(2) = dimsizes(2) - start(2) + 1 - call allocate_array(charbuf, dimsizes) - charbuf(:,:) = "" - err = nf90_get_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) - if (len(buf(1)) .lt. dimsizes(1)) then - call error("character buffer is too small; increase length: "//trim(append_error_msg)) - endif - if (size(buf) .lt. dimsizes(2)) then - call error("incorrect buffer array size:: "//trim(append_error_msg)) - endif - do i = start(2), start(2)+dimsizes(2)-1 - sbuf = "" - do j = 1, dimsizes(1) - if (charbuf(j, i-start(2)+1) .eq. char(0)) then - exit - endif - sbuf(j:j) = charbuf(j, i-start(2)+1) - enddo - call string_copy(buf(i-start(2)+1), sbuf) - enddo - deallocate(charbuf) + call char_read_1d(fileobj, variable_name, buf, c, append_error_msg, err, varid) class default call error("Unsupported variable type: "//trim(append_error_msg)) end select diff --git a/fms2_io/include/netcdf_write_data.inc b/fms2_io/include/netcdf_write_data.inc index 22e3d11b67..0c5748bf3b 100644 --- a/fms2_io/include/netcdf_write_data.inc +++ b/fms2_io/include/netcdf_write_data.inc @@ -23,6 +23,94 @@ !> @addtogroup netcdf_io_mod !> @{ +!> @brief Character write 0d function. +subroutine char_write_0d(fileobj, variable_name, variable_data, append_error_msg, err, varid) + + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + character(len=*), intent(in) :: variable_data !< Data that will be written. + character(len=200), intent(in) :: append_error_msg !< Msg to be appended to FATAL error message + integer, intent(inout) :: err + integer, intent(in) :: varid + + integer :: ndims + integer, dimension(:), allocatable :: start + integer, dimension(:), allocatable :: dimsizes + character, dimension(:), allocatable :: charbuf + integer :: i + integer :: tlen + + ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) + if (ndims .ne. 1) then + call error("currently only scalar and 1d character writes are supported: "//trim(append_error_msg)) + endif + allocate(start(ndims)) + start(:) = 1 + allocate(dimsizes(ndims)) + call get_variable_size(fileobj, variable_name, dimsizes, .false.) + call allocate_array(charbuf, dimsizes) + charbuf(:) = "" + tlen = len_trim(variable_data) + if (tlen .gt. dimsizes(1)) then + call error("character buffer is too big; decrease length: "//trim(append_error_msg)) + endif + do i = 1, tlen + charbuf(i) = variable_data(i:i) + enddo + err = nf90_put_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) + deallocate(charbuf) + deallocate(dimsizes) + deallocate(start) +end subroutine char_write_0d + +!> @brief Character write 1d function. +subroutine character_write_1d(fileobj, variable_name, variable_data, append_error_msg, err, varid) + + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + character(len=*), intent(in) :: variable_name !< Variable name. + character(len=*), dimension(:), intent(in) :: variable_data !< Data that will be written. + character(len=200), intent(in) :: append_error_msg !< Msg to be appended to FATAL error message + integer, intent(inout) :: err + integer, intent(in) :: varid + + integer :: ndims + integer, dimension(:), allocatable :: start + integer, dimension(:), allocatable :: dimsizes + character, dimension(:,:), allocatable :: charbuf + character(len=1024) :: sbuf + integer :: i + integer :: j + integer :: tlen + + ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) + if (ndims .ne. 2) then + call error("currently only scalar and 1d character writes are supported: "//trim(append_error_msg)) + endif + allocate(start(ndims)) + start(:) = 1 + allocate(dimsizes(ndims)) + call get_variable_size(fileobj, variable_name, dimsizes, .false.) + call allocate_array(charbuf, dimsizes) + charbuf(:,:) = "" + tlen = len(variable_data(1)) + if (tlen .gt. dimsizes(1)) then + call error("character buffer is too big; decrease length: "//trim(append_error_msg)) + endif + if (size(variable_data) .ne. dimsizes(2)) then + call error("incorrect size of variable_data array: "//trim(append_error_msg)) + endif + do j = 1, dimsizes(2) + call string_copy(sbuf, variable_data(j)) + do i = 1, tlen + charbuf(i,j) = sbuf(i:i) + enddo + enddo + err = nf90_put_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) + deallocate(charbuf) + deallocate(dimsizes) + deallocate(start) +end subroutine character_write_1d + !> @brief Write data to a variable in a netcdf file. subroutine netcdf_write_data_0d(fileobj, variable_name, variable_data, unlim_dim_level, & corner) @@ -40,12 +128,6 @@ subroutine netcdf_write_data_0d(fileobj, variable_name, variable_data, unlim_dim integer :: varid integer :: unlim_dim_index integer, dimension(1) :: c - integer :: ndims - integer, dimension(:), allocatable :: start - integer, dimension(:), allocatable :: dimsizes - character, dimension(:), allocatable :: charbuf - integer :: i - integer :: tlen character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message append_error_msg = "netcdf_write_data_0d: file:"//trim(fileobj%path)//" variable: "//trim(variable_name) @@ -74,27 +156,7 @@ subroutine netcdf_write_data_0d(fileobj, variable_name, variable_data, unlim_dim type is (real(kind=r8_kind)) err = nf90_put_var(fileobj%ncid, varid, variable_data, start=c) type is (character(len=*)) - ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) - if (ndims .ne. 1) then - call error("currently only scalar and 1d character writes are supported: "//trim(append_error_msg)) - endif - allocate(start(ndims)) - start(:) = 1 - allocate(dimsizes(ndims)) - call get_variable_size(fileobj, variable_name, dimsizes, .false.) - call allocate_array(charbuf, dimsizes) - charbuf(:) = "" - tlen = len_trim(variable_data) - if (tlen .gt. dimsizes(1)) then - call error("character buffer is too big; decrease length: "//trim(append_error_msg)) - endif - do i = 1, tlen - charbuf(i) = variable_data(i:i) - enddo - err = nf90_put_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) - deallocate(charbuf) - deallocate(dimsizes) - deallocate(start) + call char_write_0d(fileobj, variable_name, variable_data, append_error_msg, err, varid) class default call error("Unsupported variable type: "//trim(append_error_msg)) end select @@ -125,14 +187,6 @@ subroutine netcdf_write_data_1d(fileobj, variable_name, variable_data, unlim_dim integer :: unlim_dim_index integer, dimension(2) :: c integer, dimension(2) :: e - integer :: ndims - integer, dimension(:), allocatable :: start - integer, dimension(:), allocatable :: dimsizes - character, dimension(:,:), allocatable :: charbuf - character(len=1024) :: sbuf - integer :: i - integer :: j - integer :: tlen character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message append_error_msg = "netcdf_write_data_1d: file:"//trim(fileobj%path)//" variable: "//trim(variable_name) @@ -168,33 +222,7 @@ subroutine netcdf_write_data_1d(fileobj, variable_name, variable_data, unlim_dim type is (real(kind=r8_kind)) err = nf90_put_var(fileobj%ncid, varid, variable_data, start=c, count=e) type is (character(len=*)) - ndims = get_variable_num_dimensions(fileobj, variable_name, broadcast=.false.) - if (ndims .ne. 2) then - call error("currently only scalar and 1d character writes are supported: "//trim(append_error_msg)) - endif - allocate(start(ndims)) - start(:) = 1 - allocate(dimsizes(ndims)) - call get_variable_size(fileobj, variable_name, dimsizes, .false.) - call allocate_array(charbuf, dimsizes) - charbuf(:,:) = "" - tlen = len(variable_data(1)) - if (tlen .gt. dimsizes(1)) then - call error("character buffer is too big; decrease length: "//trim(append_error_msg)) - endif - if (size(variable_data) .ne. dimsizes(2)) then - call error("incorrect size of variable_data array: "//trim(append_error_msg)) - endif - do j = 1, dimsizes(2) - call string_copy(sbuf, variable_data(j)) - do i = 1, tlen - charbuf(i,j) = sbuf(i:i) - enddo - enddo - err = nf90_put_var(fileobj%ncid, varid, charbuf, start=start, count=dimsizes) - deallocate(charbuf) - deallocate(dimsizes) - deallocate(start) + call character_write_1d(fileobj, variable_name, variable_data, append_error_msg, err, varid) class default call error("Unsupported variable type: "//trim(append_error_msg)) end select diff --git a/mosaic2/mosaic2.F90 b/mosaic2/mosaic2.F90 index ed225a07d2..9cb4584178 100644 --- a/mosaic2/mosaic2.F90 +++ b/mosaic2/mosaic2.F90 @@ -290,11 +290,26 @@ subroutine get_mosaic_contact( fileobj, tile1, tile2, istart1, iend1, jstart1, j ntiles = get_mosaic_ntiles(fileobj) allocate(gridtiles(ntiles)) + if(mpp_pe()==mpp_root_pe()) then + do n = 1, ntiles + do m = 1,MAX_NAME + gridtiles(n)(m:m) = " " + enddo + enddo + endif call read_data(fileobj, 'gridtiles', gridtiles) ncontacts = get_mosaic_ncontacts(fileobj) if(ncontacts>0) then allocate(contacts(ncontacts), contacts_index(ncontacts)) + if(mpp_pe()==mpp_root_pe()) then + do n = 1, ncontacts + do m = 1,MAX_NAME + contacts(n)(m:m) = " " + contacts_index(n)(m:m) = " " + enddo + enddo + endif call read_data(fileobj, "contacts", contacts) call read_data(fileobj, "contact_index", contacts_index) endif From 16d71a27c5948b972c7a63f9ee2ce61661d6db48 Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Fri, 16 Jun 2023 16:07:50 -0400 Subject: [PATCH 21/51] fix: improve error messages in fms2_io (#1183) --- fms2_io/fms_netcdf_domain_io.F90 | 4 ++-- fms2_io/netcdf_io.F90 | 8 +++++--- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/fms2_io/fms_netcdf_domain_io.F90 b/fms2_io/fms_netcdf_domain_io.F90 index 57e61800c5..f592bd24c7 100644 --- a/fms2_io/fms_netcdf_domain_io.F90 +++ b/fms2_io/fms_netcdf_domain_io.F90 @@ -369,7 +369,7 @@ function open_domain_file(fileobj, path, mode, domain, nc_format, is_restart, do !Get the path of a "distributed" file. io_domain => mpp_get_io_domain(domain) if (.not. associated(io_domain)) then - call error("The domain associated with the file:"//trim(fileobj%path)//" does not have an io_domain.") + call error("The domain associated with the file:"//trim(path)//" does not have an io_domain.") endif if (io_layout(1)*io_layout(2) .gt. 1) then tile_id = mpp_get_tile_id(io_domain) @@ -393,7 +393,7 @@ function open_domain_file(fileobj, path, mode, domain, nc_format, is_restart, do success2 = netcdf_file_open(fileobj2, combined_filepath, mode, nc_format, pelist, & is_restart, dont_add_res_to_filename) if (success2) then - call error("The domain decomposed file:"//trim(fileobj%path)// & + call error("The domain decomposed file:"//trim(path)// & & " contains both combined (*.nc) and distributed files (*.nc.XXXX).") endif endif diff --git a/fms2_io/netcdf_io.F90 b/fms2_io/netcdf_io.F90 index b76042900a..15bd0cdeff 100644 --- a/fms2_io/netcdf_io.F90 +++ b/fms2_io/netcdf_io.F90 @@ -924,7 +924,7 @@ subroutine netcdf_add_variable(fileobj, variable_name, variable_type, dimensions integer :: i character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message - append_error_msg = "netcdf_add_variable: file:"//trim(fileobj%path)//"variable:"//trim(variable_name) + append_error_msg = "netcdf_add_variable: file:"//trim(fileobj%path)//" variable:"//trim(variable_name) if (fileobj%is_root) then call set_netcdf_mode(fileobj%ncid, define_mode) @@ -1057,7 +1057,8 @@ subroutine netcdf_save_restart(fileobj, unlim_dim_level) integer :: i if (.not. fileobj%is_restart) then - call error("file "//trim(fileobj%path)//" is not a restart file.") + call error("write_restart:: file "//trim(fileobj%path)//" is not a restart file."& + &" Be sure the file was opened with is_restart=.true.") endif do i = 1, fileobj%num_restart_vars if (associated(fileobj%restart_vars(i)%data0d)) then @@ -1098,7 +1099,8 @@ subroutine netcdf_restore_state(fileobj, unlim_dim_level) integer :: i if (.not. fileobj%is_restart) then - call error("file "//trim(fileobj%path)//" is not a restart file.") + call error("read_restart:: file "//trim(fileobj%path)//" is not a restart file."& + &" Be sure the file was opened with is_restart=.true.") endif do i = 1, fileobj%num_restart_vars if (associated(fileobj%restart_vars(i)%data0d)) then From 22c498ea613fe6290094cc829966411872c9241a Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Fri, 16 Jun 2023 17:00:43 -0400 Subject: [PATCH 22/51] feat: fms2_io unpack data (#1231) --- amip_interp/amip_interp.F90 | 5 +- fms2_io/Makefile.am | 5 +- fms2_io/include/netcdf_read_data.inc | 6 + fms2_io/include/unpack_data.inc | 286 +++++++++++++++++++++++++ fms2_io/netcdf_io.F90 | 1 + test_fms/fms2_io/Makefile.am | 4 +- test_fms/fms2_io/test_packed_reads.F90 | 198 +++++++++++++++++ 7 files changed, 501 insertions(+), 4 deletions(-) create mode 100644 fms2_io/include/unpack_data.inc create mode 100644 test_fms/fms2_io/test_packed_reads.F90 diff --git a/amip_interp/amip_interp.F90 b/amip_interp/amip_interp.F90 index 98914feaa3..d276052369 100644 --- a/amip_interp/amip_interp.F90 +++ b/amip_interp/amip_interp.F90 @@ -1353,7 +1353,10 @@ subroutine read_record (type, Date, Adate, dat) else call fms2_io_read_data(fileobj, ncfieldname, dat, unlim_dim_level=k) endif - idat = nint(dat, I2_KIND) ! reconstruct packed data for reproducibility + !TODO This assumes that the data is "packed" (has the scale_factor and add_offset attributes) + ! in fms2_io_read_data the data is unpacked (data_in_file*scale_factor + add_offset) + ! the line below "packs" the data again. This is needed for reproducibility + idat = nint(dat*100., I2_KIND) !---- unpacking of data ---- diff --git a/fms2_io/Makefile.am b/fms2_io/Makefile.am index c186d76678..3938fa4e71 100644 --- a/fms2_io/Makefile.am +++ b/fms2_io/Makefile.am @@ -54,7 +54,8 @@ libfms2_io_la_SOURCES = \ include/register_variable_attribute.inc \ include/unstructured_domain_write.inc \ include/gather_data_bc.inc \ - include/scatter_data_bc.inc + include/scatter_data_bc.inc \ + include/unpack_data.inc # Some mods are dependant on other mods in this dir. fms2_io_mod.$(FC_MODEXT): fms_io_utils_mod.$(FC_MODEXT) netcdf_io_mod.$(FC_MODEXT) fms_netcdf_domain_io_mod.$(FC_MODEXT) \ @@ -65,7 +66,7 @@ netcdf_io_mod.$(FC_MODEXT): fms_io_utils_mod.$(FC_MODEXT) include/netcdf_add_res include/netcdf_write_data.inc include/register_global_attribute.inc \ include/register_variable_attribute.inc include/get_global_attribute.inc \ include/get_variable_attribute.inc include/compressed_write.inc include/compressed_read.inc \ - include/gather_data_bc.inc include/scatter_data_bc.inc + include/gather_data_bc.inc include/scatter_data_bc.inc include/unpack_data.inc fms_netcdf_domain_io_mod.$(FC_MODEXT): fms_io_utils_mod.$(FC_MODEXT) netcdf_io_mod.$(FC_MODEXT) include/register_domain_restart_variable.inc \ include/domain_read.inc include/domain_write.inc include/compute_global_checksum.inc fms_netcdf_unstructured_domain_io_mod.$(FC_MODEXT): fms_io_utils_mod.$(FC_MODEXT) netcdf_io_mod.$(FC_MODEXT) \ diff --git a/fms2_io/include/netcdf_read_data.inc b/fms2_io/include/netcdf_read_data.inc index 66c1484f29..4bfd427970 100644 --- a/fms2_io/include/netcdf_read_data.inc +++ b/fms2_io/include/netcdf_read_data.inc @@ -177,6 +177,7 @@ subroutine netcdf_read_data_0d(fileobj, variable_name, buf, unlim_dim_level, & call error("Unsupported variable type: "//trim(append_error_msg)) end select call check_netcdf_code(err, append_error_msg) + call unpack_data_0d(fileobj, varid, variable_name, buf) endif if (bcast) then select type(buf) @@ -274,6 +275,7 @@ subroutine netcdf_read_data_1d(fileobj, variable_name, buf, unlim_dim_level, & call error("Unsupported variable type: "//trim(append_error_msg)) end select call check_netcdf_code(err, append_error_msg) + call unpack_data_1d(fileobj, varid, variable_name, buf) endif if (bcast) then select type(buf) @@ -367,6 +369,7 @@ subroutine netcdf_read_data_2d(fileobj, variable_name, buf, unlim_dim_level, & call error("Unsupported variable type: "//trim(append_error_msg)) end select call check_netcdf_code(err, append_error_msg) + call unpack_data_2d(fileobj, varid, variable_name, buf) endif if (bcast) then select type(buf) @@ -458,6 +461,7 @@ subroutine netcdf_read_data_3d(fileobj, variable_name, buf, unlim_dim_level, & call error("Unsupported variable type: "//trim(append_error_msg)) end select call check_netcdf_code(err, append_error_msg) + call unpack_data_3d(fileobj, varid, variable_name, buf) endif if (bcast) then select type(buf) @@ -549,6 +553,7 @@ subroutine netcdf_read_data_4d(fileobj, variable_name, buf, unlim_dim_level, & call error("Unsupported variable type: "//trim(append_error_msg)) end select call check_netcdf_code(err, append_error_msg) + call unpack_data_4d(fileobj, varid, variable_name, buf) endif if (bcast) then select type(buf) @@ -640,6 +645,7 @@ subroutine netcdf_read_data_5d(fileobj, variable_name, buf, unlim_dim_level, & call error("Unsupported variable type: "//trim(append_error_msg)) end select call check_netcdf_code(err, append_error_msg) + call unpack_data_5d(fileobj, varid, variable_name, buf) endif if (bcast) then select type(buf) diff --git a/fms2_io/include/unpack_data.inc b/fms2_io/include/unpack_data.inc new file mode 100644 index 0000000000..c3695c4793 --- /dev/null +++ b/fms2_io/include/unpack_data.inc @@ -0,0 +1,286 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!> @file +!> @brief Routines for the @ref gather_data_bc interface + +!> @addtogroup netcdf_io_mod +!> @{ +subroutine unpack_data_0d(fileobj, varid, varname, var_data) + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + integer, intent(in) :: varid !< Netcdf variable ID + character(len=*), intent(in) :: varname !< Name of the variable (for error messages) + class(*), intent(inout) :: var_data !< Array that the data + !! will be read into. + + character(len=128) :: msg !< Message to append in error message + real(kind=r4_kind) :: buf_r4_kind !< r4_kind buffer to read the scale_factor/add_offset to + real(kind=r8_kind) :: buf_r8_kind !< r8_kind buffer to read the scale_factor/add_offset to + integer :: err !< netcdf error code + + msg = "Check your read_data call for the variable:"//trim(varname)//& + " in file:"//trim(fileobj%path) + + if (attribute_exists(fileobj%ncid, varid, "scale_factor") .or. & + attribute_exists(fileobj%ncid, varid, "add_offset")) then + + select type(var_data) + type is (real(kind=r4_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r4_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r4_kind + + type is (real(kind=r8_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r8_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r8_kind + + class default + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& + "r4_kind or r8_kind."//trim(msg)) + end select + end if +end subroutine + +subroutine unpack_data_1d(fileobj, varid, varname, var_data) + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + integer, intent(in) :: varid !< Netcdf variable ID + character(len=*), intent(in) :: varname !< Name of the variable (for error messages) + class(*), intent(inout) :: var_data(:) !< Array that the data + !! will be read into. + + character(len=128) :: msg !< Message to append in error message + real(kind=r4_kind) :: buf_r4_kind !< r4_kind buffer to read the scale_factor/add_offset to + real(kind=r8_kind) :: buf_r8_kind !< r8_kind buffer to read the scale_factor/add_offset to + integer :: err !< netcdf error code + + msg = "Check your read_data call for the variable:"//trim(varname)//& + " in file:"//trim(fileobj%path) + + if (attribute_exists(fileobj%ncid, varid, "scale_factor") .or. & + attribute_exists(fileobj%ncid, varid, "add_offset")) then + + select type(var_data) + type is (real(kind=r4_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r4_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r4_kind + + type is (real(kind=r8_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r8_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r8_kind + + class default + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& + "r4_kind or r8_kind."//trim(msg)) + end select + end if +end subroutine + +subroutine unpack_data_2d(fileobj, varid, varname, var_data) + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + integer, intent(in) :: varid !< Netcdf variable ID + character(len=*), intent(in) :: varname !< Name of the variable (for error messages) + class(*), intent(inout) :: var_data(:,:) !< Array that the data + !! will be read into. + + character(len=128) :: msg !< Message to append in error message + real(kind=r4_kind) :: buf_r4_kind !< r4_kind buffer to read the scale_factor/add_offset to + real(kind=r8_kind) :: buf_r8_kind !< r8_kind buffer to read the scale_factor/add_offset to + integer :: err !< netcdf error code + + msg = "Check your read_data call for the variable:"//trim(varname)//& + " in file:"//trim(fileobj%path) + + if (attribute_exists(fileobj%ncid, varid, "scale_factor") .or. & + attribute_exists(fileobj%ncid, varid, "add_offset")) then + + select type(var_data) + type is (real(kind=r4_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r4_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r4_kind + + type is (real(kind=r8_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r8_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r8_kind + + class default + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& + "r4_kind or r8_kind."//trim(msg)) + end select + end if +end subroutine + +subroutine unpack_data_3d(fileobj, varid, varname, var_data) + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + integer, intent(in) :: varid !< Netcdf variable ID + character(len=*), intent(in) :: varname !< Name of the variable (for error messages) + class(*), intent(inout) :: var_data(:,:,:) !< Array that the data + !! will be read into. + + character(len=128) :: msg !< Message to append in error message + real(kind=r4_kind) :: buf_r4_kind !< r4_kind buffer to read the scale_factor/add_offset to + real(kind=r8_kind) :: buf_r8_kind !< r8_kind buffer to read the scale_factor/add_offset to + integer :: err !< netcdf error code + + msg = "Check your read_data call for the variable:"//trim(varname)//& + " in file:"//trim(fileobj%path) + + if (attribute_exists(fileobj%ncid, varid, "scale_factor") .or. & + attribute_exists(fileobj%ncid, varid, "add_offset")) then + + select type(var_data) + type is (real(kind=r4_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r4_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r4_kind + + type is (real(kind=r8_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r8_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r8_kind + + class default + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& + "r4_kind or r8_kind."//trim(msg)) + end select + end if +end subroutine + +subroutine unpack_data_4d(fileobj, varid, varname, var_data) + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + integer, intent(in) :: varid !< Netcdf variable ID + character(len=*), intent(in) :: varname !< Name of the variable (for error messages) + class(*), intent(inout) :: var_data(:,:,:,:) !< Array that the data + !! will be read into. + + character(len=128) :: msg !< Message to append in error message + real(kind=r4_kind) :: buf_r4_kind !< r4_kind buffer to read the scale_factor/add_offset to + real(kind=r8_kind) :: buf_r8_kind !< r8_kind buffer to read the scale_factor/add_offset to + integer :: err !< netcdf error code + + msg = "Check your read_data call for the variable:"//trim(varname)//& + " in file:"//trim(fileobj%path) + + if (attribute_exists(fileobj%ncid, varid, "scale_factor") .or. & + attribute_exists(fileobj%ncid, varid, "add_offset")) then + + select type(var_data) + type is (real(kind=r4_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r4_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r4_kind + + type is (real(kind=r8_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r8_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r8_kind + + class default + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& + "r4_kind or r8_kind."//trim(msg)) + end select + end if +end subroutine + +subroutine unpack_data_5d(fileobj, varid, varname, var_data) + class(FmsNetcdfFile_t), intent(in) :: fileobj !< File object. + integer, intent(in) :: varid !< Netcdf variable ID + character(len=*), intent(in) :: varname !< Name of the variable (for error messages) + class(*), intent(inout) :: var_data(:,:,:,:,:) !< Array that the data + !! will be read into. + + character(len=128) :: msg !< Message to append in error message + real(kind=r4_kind) :: buf_r4_kind !< r4_kind buffer to read the scale_factor/add_offset to + real(kind=r8_kind) :: buf_r8_kind !< r8_kind buffer to read the scale_factor/add_offset to + integer :: err !< netcdf error code + + msg = "Check your read_data call for the variable:"//trim(varname)//& + " in file:"//trim(fileobj%path) + + if (attribute_exists(fileobj%ncid, varid, "scale_factor") .or. & + attribute_exists(fileobj%ncid, varid, "add_offset")) then + + select type(var_data) + type is (real(kind=r4_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r4_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r4_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r4_kind + + type is (real(kind=r8_kind)) + err = nf90_get_att(fileobj%ncid, varid, "scale_factor", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data * buf_r8_kind + + err = nf90_get_att(fileobj%ncid, varid, "add_offset", buf_r8_kind ) + call check_netcdf_code(err, msg) + var_data = var_data + buf_r8_kind + + class default + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& + "r4_kind or r8_kind."//trim(msg)) + end select + end if +end subroutine diff --git a/fms2_io/netcdf_io.F90 b/fms2_io/netcdf_io.F90 index 15bd0cdeff..b66c6f0526 100644 --- a/fms2_io/netcdf_io.F90 +++ b/fms2_io/netcdf_io.F90 @@ -2001,6 +2001,7 @@ end subroutine compressed_start_and_count include "compressed_read.inc" include "scatter_data_bc.inc" include "gather_data_bc.inc" +include "unpack_data.inc" !> @brief Wrapper to distinguish interfaces. function netcdf_file_open_wrap(fileobj, path, mode, nc_format, pelist, is_restart, dont_add_res_to_filename) & diff --git a/test_fms/fms2_io/Makefile.am b/test_fms/fms2_io/Makefile.am index ee4fddbc0e..aa94b0c342 100644 --- a/test_fms/fms2_io/Makefile.am +++ b/test_fms/fms2_io/Makefile.am @@ -30,7 +30,8 @@ LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. check_PROGRAMS = test_get_is_valid test_file_appendix test_fms2_io test_atmosphere_io test_io_simple test_io_with_mask test_global_att \ - test_bc_restart test_get_mosaic_tile_grid test_read_ascii_file test_unlimit_compressed test_chunksizes test_domain_io test_compressed_writes + test_packed_reads test_bc_restart test_get_mosaic_tile_grid test_read_ascii_file test_unlimit_compressed test_chunksizes \ + test_domain_io test_compressed_writes # This is the source code for the test. test_get_is_valid_SOURCES = test_get_is_valid.F90 @@ -49,6 +50,7 @@ test_read_ascii_file_SOURCES=test_read_ascii_file.F90 test_file_appendix_SOURCES=test_file_appendix.F90 test_unlimit_compressed_SOURCES=test_unlimit_compressed.F90 test_chunksizes_SOURCES = test_chunksizes.F90 +test_packed_reads_SOURCES = test_packed_reads.F90 test_compressed_writes_SOURCES = test_compressed_writes.F90 test_domain_io_SOURCES = test_domain_io.F90 diff --git a/test_fms/fms2_io/test_packed_reads.F90 b/test_fms/fms2_io/test_packed_reads.F90 new file mode 100644 index 0000000000..bc2a1206a5 --- /dev/null +++ b/test_fms/fms2_io/test_packed_reads.F90 @@ -0,0 +1,198 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +program test_packed_reads + use fms_mod, only: fms_init, fms_end + use platform_mod, only: r8_kind, r4_kind, i8_kind + use mpp_mod, only: mpp_error, FATAL, mpp_chksum + use fms2_io_mod, only: open_file, close_file, FmsNetcdfFile_t, read_data + use netcdf + + implicit none + + real(kind=r8_kind) :: var_r8(10, 1, 1, 1, 1) !< original r8 data + real(kind=r8_kind) :: var_r8_out(10, 1, 1, 1, 1) !< expected r8 data + real(kind=r8_kind) :: var_r8_out2(10, 1, 1, 1, 1) !< r8 data from file + real(kind=r8_kind) :: scale_factor_r8 !< r8 scale factor + real(kind=r8_kind) :: add_offset_r8 !< r8 offset + + real(kind=r4_kind) :: var_r4(10, 1, 1, 1, 1) !< original r4 data + real(kind=r4_kind) :: var_r4_out(10, 1, 1, 1, 1) !< expected r4 data + real(kind=r4_kind) :: var_r4_out2(10, 1, 1, 1, 1) !< r4 data from file + real(kind=r4_kind) :: scale_factor_r4 !< r4 scale factor + real(kind=r4_kind) :: add_offset_r4 !< r4 offset + + type(FmsNetcdfFile_t) :: fileobj !< Fms2_io fileobj + + integer(2) :: packed_data_r8(10, 1, 1, 1, 1) !< Packed data calculated from r8 + integer(2) :: packed_data_r4(10, 1, 1, 1, 1) !< Packed data calculated from r4 + + integer :: ncid !< netcdf file id + integer :: varid1_r8, varid2_r8, varid3_r8, varid4_r8, varid5_r8 !< Variable ids + integer :: varid1_r4, varid2_r4, varid3_r4, varid4_r4, varid5_r4 !< variable ids + integer :: dimid1, dimid2, dimid3, dimid4, dimid5 !< Dimension ids + integer :: dim(5) !< Array of dimension ids + integer :: i !< For do loops + integer :: err !< netcdf error code + + call fms_init() + + do i = 1, size(var_r4, 1) + var_r4(i,:,:,:,:) = 90_r4_kind - real(i, kind=r4_kind)/13_r4_kind + real(i, kind=r4_kind) + var_r8(i,:,:,:,:) = 90_r8_kind - real(i, kind=r8_kind)/13_r8_kind + real(i, kind=r8_kind) + enddo + + scale_factor_r4 = real((maxval(var_r4) - minval(var_r4)) / (2**(16-1)), kind=r4_kind) + add_offset_r4 = real(minval(var_r4) + 2 ** (16 - 1) * scale_factor_r4, kind=r4_kind) + packed_data_r4 = nint((var_r4 - add_offset_r4) / scale_factor_r4, kind=2) + var_r4_out = packed_data_r4*scale_factor_r4 + add_offset_r4 + + scale_factor_r8 = real((maxval(var_r8) - minval(var_r8)) / (2**(16-1)), kind=r8_kind) + add_offset_r8 = real(minval(var_r8) + 2 ** (16 - 1) * scale_factor_r8, kind=r8_kind) + packed_data_r8 = nint((var_r8 - add_offset_r8) / scale_factor_r8, kind=2) + var_r8_out = packed_data_r8*scale_factor_r8 + add_offset_r8 + + err = nf90_create("short_file.nc", ior(nf90_clobber, nf90_64bit_offset), ncid) + err = nf90_def_dim(ncid, 'dim1', 10, dimid1) + err = nf90_def_dim(ncid, 'dim2', 1, dimid2) + err = nf90_def_dim(ncid, 'dim3', 1, dimid3) + err = nf90_def_dim(ncid, 'dim4', 1, dimid4) + err = nf90_def_dim(ncid, 'dim5', 1, dimid5) + + dim = (/dimid1, dimid2, dimid3, dimid4, dimid5/) + + call write_var_metadata(ncid, 'var_1d', dim(1:1), scale_factor_r4, scale_factor_r8, & + add_offset_r4, add_offset_r8, varid1_r8, varid1_r4) + call write_var_metadata(ncid, 'var_2d', dim(1:2), scale_factor_r4, scale_factor_r8, & + add_offset_r4, add_offset_r8, varid2_r8, varid2_r4) + call write_var_metadata(ncid, 'var_3d', dim(1:3), scale_factor_r4, scale_factor_r8, & + add_offset_r4, add_offset_r8, varid3_r8, varid3_r4) + call write_var_metadata(ncid, 'var_4d', dim(1:4), scale_factor_r4, scale_factor_r8, & + add_offset_r4, add_offset_r8, varid4_r8, varid4_r4) + call write_var_metadata(ncid, 'var_5d', dim(1:5), scale_factor_r4, scale_factor_r8, & + add_offset_r4, add_offset_r8, varid5_r8, varid5_r4) + + call check(nf90_enddef(ncid)) + + call check(nf90_put_var(ncid, varid1_r8, packed_data_r8(:,1,1,1,1))) + call check(nf90_put_var(ncid, varid2_r8, packed_data_r8(:,:,1,1,1))) + call check(nf90_put_var(ncid, varid3_r8, packed_data_r8(:,:,:,1,1))) + call check(nf90_put_var(ncid, varid4_r8, packed_data_r8(:,:,:,:,1))) + call check(nf90_put_var(ncid, varid5_r8, packed_data_r8(:,:,:,:,:))) + + call check(nf90_put_var(ncid, varid1_r4, packed_data_r4(:,1,1,1,1))) + call check(nf90_put_var(ncid, varid2_r4, packed_data_r4(:,:,1,1,1))) + call check(nf90_put_var(ncid, varid3_r4, packed_data_r4(:,:,:,1,1))) + call check(nf90_put_var(ncid, varid4_r4, packed_data_r4(:,:,:,:,1))) + call check(nf90_put_var(ncid, varid5_r4, packed_data_r4(:,:,:,:,:))) + + call check(nf90_close(ncid)) + + if (open_file(fileobj, "short_file.nc", "read")) then + var_r8_out2 = -999_r8_kind + call read_data(fileobj, "var_1d_r8", var_r8_out2(:,1,1,1,1)) + call compare_data(mpp_chksum(var_r8_out2(:,1,1,1,1)), mpp_chksum(var_r8_out(:,1,1,1,1)), "var_1d_r8") + + var_r8_out2 = -999_r8_kind + call read_data(fileobj, "var_2d_r8", var_r8_out2(:,:,1,1,1)) + call compare_data(mpp_chksum(var_r8_out2(:,:,1,1,1)), mpp_chksum(var_r8_out(:,:,1,1,1)), "var_1d_r8") + + var_r8_out2 = -999_r8_kind + call read_data(fileobj, "var_3d_r8", var_r8_out2(:,:,:,1,1)) + call compare_data(mpp_chksum(var_r8_out2(:,:,:,1,1)), mpp_chksum(var_r8_out(:,:,:,1,1)), "var_1d_r8") + + var_r8_out2 = -999_r8_kind + call read_data(fileobj, "var_4d_r8", var_r8_out2(:,:,:,:,1)) + call compare_data(mpp_chksum(var_r8_out2(:,:,:,:,1)), mpp_chksum(var_r8_out(:,:,:,:,1)), "var_1d_r8") + + var_r8_out2 = -999_r8_kind + call read_data(fileobj, "var_5d_r8", var_r8_out2(:,:,:,:,:)) + call compare_data(mpp_chksum(var_r8_out2(:,:,:,:,:)), mpp_chksum(var_r8_out(:,:,:,:,:)), "var_1d_r8") + + var_r4_out2 = -999_r4_kind + call read_data(fileobj, "var_1d_r4", var_r4_out2(:,1,1,1,1)) + call compare_data(mpp_chksum(var_r4_out2(:,1,1,1,1)), mpp_chksum(var_r4_out(:,1,1,1,1)), "var_1d_r4") + + var_r4_out2 = -999_r4_kind + call read_data(fileobj, "var_2d_r4", var_r4_out2(:,:,1,1,1)) + call compare_data(mpp_chksum(var_r4_out2(:,:,1,1,1)), mpp_chksum(var_r4_out(:,:,1,1,1)), "var_1d_r4") + + var_r4_out2 = -999_r4_kind + call read_data(fileobj, "var_3d_r4", var_r4_out2(:,:,:,1,1)) + call compare_data(mpp_chksum(var_r4_out2(:,:,:,1,1)), mpp_chksum(var_r4_out(:,:,:,1,1)), "var_1d_r4") + + var_r4_out2 = -999_r4_kind + call read_data(fileobj, "var_4d_r4", var_r4_out2(:,:,:,:,1)) + call compare_data(mpp_chksum(var_r4_out2(:,:,:,:,1)), mpp_chksum(var_r4_out(:,:,:,:,1)), "var_1d_r4") + + var_r4_out2 = -999_r4_kind + call read_data(fileobj, "var_5d_r4", var_r4_out2(:,:,:,:,:)) + call compare_data(mpp_chksum(var_r4_out2(:,:,:,:,:)), mpp_chksum(var_r4_out(:,:,:,:,:)), "var_1d_r4") + + + call close_file(fileobj) + endif + + call fms_end() + + contains + + !> @brief Write out the variable data + subroutine write_var_metadata(fileid, varname, dimids, sfactor_r4, sfactor_r8, & + offset_r4, offset_r8, varid_r4, varid_r8) + integer, intent(in) :: fileid !< netcdf file id + character(len=*), intent(in) :: varname !< variable name + integer, intent(in) :: dimids(:) !< array of the dimension ids + real(kind=r4_kind), intent(in) :: sfactor_r4 !< Scale factor in r4 precision + real(kind=r8_kind), intent(in) :: sfactor_r8 !< Scale factor in r8 precision + real(kind=r4_kind), intent(in) :: offset_r4 !< offset in r4 precision + real(kind=r8_kind), intent(in) :: offset_r8 !< offset in r8 precision + integer, intent(out) :: varid_r4 !< variable id for the r4 variable + integer, intent(out) :: varid_r8 !< variable id for the r8 variable + + call check(nf90_def_var(ncid, trim(varname)//"_r4", nf90_short, dimids, varid_r4)) + call check(nf90_put_att(ncid, varid_r4, "scale_factor", sfactor_r4)) + call check(nf90_put_att(ncid, varid_r4, "add_offset", offset_r4)) + + call check(nf90_def_var(ncid, trim(varname)//"_r8", nf90_short, dimids, varid_r8)) + call check(nf90_put_att(ncid, varid_r8, "scale_factor", sfactor_r8)) + call check(nf90_put_att(ncid, varid_r8, "add_offset", offset_r8)) + + end subroutine write_var_metadata + + !> @brief Compare two checksums + subroutine compare_data(checksum_in, checksum_out, varname) + integer(kind=i8_kind), intent(in) :: checksum_in !< The data checksum + integer(kind=i8_kind), intent(in) :: checksum_out !< The reference checksum + character(len=*), intent(in) :: varname !< The variable's name (for error messages) + + if (checksum_in .ne. checksum_out) call mpp_error(FATAL, & + "Checksums do not match for variable: "//trim(varname)) + end subroutine + + !> @brief Check the netcdf error code + subroutine check(status) + integer, intent ( in) :: status !< netcdf error code + + if(status /= nf90_noerr) then + print *, trim(nf90_strerror(status)) + stop "Stopped" + end if + end subroutine check + +end program test_packed_reads From cf5035f5e5410ebfdeed9c11fdc0e326da66d91b Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Tue, 20 Jun 2023 11:31:22 -0400 Subject: [PATCH 23/51] fix: improve doxygen comment for `tranlon` (#1257) --- axis_utils/include/axis_utils2.inc | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/axis_utils/include/axis_utils2.inc b/axis_utils/include/axis_utils2.inc index 53707fcf78..21deca9fb4 100644 --- a/axis_utils/include/axis_utils2.inc +++ b/axis_utils/include/axis_utils2.inc @@ -165,28 +165,27 @@ end function LON_IN_RANGE_ - !> @brief Returns monotonic array of longitudes s.t., lon_strt <= lon(:) <= lon_strt+360. + !> @brief Returns monotonic array of longitudes s.t., lon_strt <= lon(:) < lon_strt+360. !! - !>
The first istrt-1 entries are moved to the end of the array: + !! This may require that entries be moved from the beginning of the array to + !! the end. If no entries are moved (i.e., if lon(:) is already monotonic in + !! the range from lon_start to lon_start + 360), then istrt is set to 0. If + !! any entries are moved, then istrt is set to the original index of the entry + !! which becomes lon(1). !! - !! e.g. - !! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 ==> - !! tranlon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 + !! e.g., + !! + !! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 + !! ==> lon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 + !! + !! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 0 + !! ==> lon = 0 1 2 3 4 5 ... 358 359; istrt = 0 subroutine TRANLON_(lon, lon_start, istrt) - - ! returns array of longitudes s.t. lon_strt <= lon < lon_strt+360. - ! also, the first istrt-1 entries are moved to the end of the array - ! - ! e.g. - ! lon = 0 1 2 3 4 5 ... 358 359; lon_strt = 3 ==> - ! tranlon = 3 4 5 6 7 8 ... 359 360 361 362; istrt = 4 - real(kind=FMS_AU_KIND_), intent(inout), dimension(:) :: lon real(kind=FMS_AU_KIND_), intent(in) :: lon_start integer, intent(out) :: istrt - integer :: len, i real(kind=FMS_AU_KIND_) :: lon_strt, tmp(size(lon(:))-1) From ecc1361680b4ade6a5db60a1e7ef024e944c8fac Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Tue, 20 Jun 2023 13:35:31 -0400 Subject: [PATCH 24/51] fix: ifort 2022.3.0 & greater ICE bug in alltoall test + missing input nmls in mpp scripts (#1158) --- test_fms/mpp/Makefile.am | 6 ++++++ test_fms/mpp/test_clock_init.sh | 3 +++ test_fms/mpp/test_global_arrays.sh | 3 +++ test_fms/mpp/test_mpp_alltoall.sh | 3 +++ test_fms/mpp/test_mpp_global_sum_ad.sh | 3 +++ test_fms/mpp/test_mpp_npes.sh | 3 +++ test_fms/mpp/test_mpp_pe.sh | 2 ++ test_fms/mpp/test_mpp_root_pe.sh | 3 +++ test_fms/mpp/test_mpp_sum.sh | 3 +++ test_fms/mpp/test_mpp_transmit.sh | 3 +++ test_fms/mpp/test_stderr.sh | 3 +++ test_fms/mpp/test_stdin.sh | 3 +++ test_fms/mpp/test_stdout.sh | 3 +++ test_fms/mpp/test_system_clock.sh | 3 +++ test_fms/mpp/test_update_domains_performance.sh | 4 ++++ 15 files changed, 48 insertions(+) diff --git a/test_fms/mpp/Makefile.am b/test_fms/mpp/Makefile.am index 66f12d9d1e..1d44b9bc93 100644 --- a/test_fms/mpp/Makefile.am +++ b/test_fms/mpp/Makefile.am @@ -134,6 +134,12 @@ test_mpp_clock_begin_end_id_SOURCES=test_mpp_clock_begin_end_id.F90 test_super_grid_SOURCES = test_super_grid.F90 test_mpp_chksum_SOURCES = test_mpp_chksum.F90 +# ifort gets a internal error during compilation for this test, issue #1071 +# we'll just remove the openmp flag if present since it doesn't use openmp at all +test_mpp_alltoall.$(OBJEXT): FCFLAGS:= $(filter-out -fopenmp,$(FCFLAGS)) +test_mpp_alltoall.$(OBJEXT): CPPFLAGS:= $(filter-out -fopenmp,$(CPPFLAGS)) + + # Run the test programs. TESTS = test_mpp_domains2.sh \ test_redistribute_int.sh \ diff --git a/test_fms/mpp/test_clock_init.sh b/test_fms/mpp/test_clock_init.sh index 93b29c4172..7ce49da379 100755 --- a/test_fms/mpp/test_clock_init.sh +++ b/test_fms/mpp/test_clock_init.sh @@ -28,6 +28,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + test_expect_success "clock initialization" ' mpirun -n 1 ./test_clock_init ' diff --git a/test_fms/mpp/test_global_arrays.sh b/test_fms/mpp/test_global_arrays.sh index dc5cbce9ee..596d1ecb0a 100755 --- a/test_fms/mpp/test_global_arrays.sh +++ b/test_fms/mpp/test_global_arrays.sh @@ -27,6 +27,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + test_expect_success "global array functions with mixed precision" ' mpirun -n 8 ./test_global_arrays ' diff --git a/test_fms/mpp/test_mpp_alltoall.sh b/test_fms/mpp/test_mpp_alltoall.sh index f54dcde599..c186b11efb 100755 --- a/test_fms/mpp/test_mpp_alltoall.sh +++ b/test_fms/mpp/test_mpp_alltoall.sh @@ -26,6 +26,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + # Run the test for one processor test_expect_success "mpp all-to-all with mixed precision" ' mpirun -n 4 ./test_mpp_alltoall diff --git a/test_fms/mpp/test_mpp_global_sum_ad.sh b/test_fms/mpp/test_mpp_global_sum_ad.sh index 8c5b1b6cc2..71296789f7 100755 --- a/test_fms/mpp/test_mpp_global_sum_ad.sh +++ b/test_fms/mpp/test_mpp_global_sum_ad.sh @@ -27,6 +27,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + # Run the test test_expect_success "mpp global adjoint sum with mixed precision" ' mpirun -n 4 ./test_mpp_global_sum_ad diff --git a/test_fms/mpp/test_mpp_npes.sh b/test_fms/mpp/test_mpp_npes.sh index 23295e4e29..edc3e4997d 100755 --- a/test_fms/mpp/test_mpp_npes.sh +++ b/test_fms/mpp/test_mpp_npes.sh @@ -28,6 +28,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + export NUM_PES=1 test_expect_success "get number of PEs single processor" ' mpirun -n 1 ./test_mpp_npes diff --git a/test_fms/mpp/test_mpp_pe.sh b/test_fms/mpp/test_mpp_pe.sh index dde00bfd99..8936de1174 100755 --- a/test_fms/mpp/test_mpp_pe.sh +++ b/test_fms/mpp/test_mpp_pe.sh @@ -27,6 +27,8 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml # Run the tests test_expect_success "get current PE single processor" ' diff --git a/test_fms/mpp/test_mpp_root_pe.sh b/test_fms/mpp/test_mpp_root_pe.sh index 23cd707a71..7970004172 100755 --- a/test_fms/mpp/test_mpp_root_pe.sh +++ b/test_fms/mpp/test_mpp_root_pe.sh @@ -28,6 +28,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + # Run the test test_expect_success "get correct root PE single processor" ' mpirun -n 1 ./test_mpp_root_pe diff --git a/test_fms/mpp/test_mpp_sum.sh b/test_fms/mpp/test_mpp_sum.sh index bd90ecb17a..fa00ea1e23 100755 --- a/test_fms/mpp/test_mpp_sum.sh +++ b/test_fms/mpp/test_mpp_sum.sh @@ -28,6 +28,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + # Run the test for 5 processors test_expect_success "mpp_sum with mixed precision" ' mpirun -n 5 ./test_mpp_sum diff --git a/test_fms/mpp/test_mpp_transmit.sh b/test_fms/mpp/test_mpp_transmit.sh index a1c4483590..77f610f091 100755 --- a/test_fms/mpp/test_mpp_transmit.sh +++ b/test_fms/mpp/test_mpp_transmit.sh @@ -28,6 +28,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + # Run the test for 5 processors test_expect_success "mpp transmit with mixed precision" ' mpirun -n 6 ./test_mpp_transmit diff --git a/test_fms/mpp/test_stderr.sh b/test_fms/mpp/test_stderr.sh index ebf8adc222..25f8190b65 100755 --- a/test_fms/mpp/test_stderr.sh +++ b/test_fms/mpp/test_stderr.sh @@ -27,6 +27,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + test_expect_success "get stderr" ' mpirun -n 1 ./test_stderr ' diff --git a/test_fms/mpp/test_stdin.sh b/test_fms/mpp/test_stdin.sh index f13d38df28..0a8df299dc 100755 --- a/test_fms/mpp/test_stdin.sh +++ b/test_fms/mpp/test_stdin.sh @@ -26,6 +26,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + test_expect_success "correct STDIN writes" ' mpirun -n 1 ./test_stdin ' diff --git a/test_fms/mpp/test_stdout.sh b/test_fms/mpp/test_stdout.sh index 67befda83b..ddce1baf2a 100755 --- a/test_fms/mpp/test_stdout.sh +++ b/test_fms/mpp/test_stdout.sh @@ -28,6 +28,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + # Run test with one processor test_expect_success "get stdout with 1 PE" ' mpirun -n 2 ./test_stdout diff --git a/test_fms/mpp/test_system_clock.sh b/test_fms/mpp/test_system_clock.sh index cdc620adaa..0cf357e824 100755 --- a/test_fms/mpp/test_system_clock.sh +++ b/test_fms/mpp/test_system_clock.sh @@ -27,6 +27,9 @@ # Set common test settings. . ../test-lib.sh +# ensure input.nml file present +touch input.nml + # Run the test for one processor test_expect_success "system clock functionality" ' mpirun -n 1 ./test_system_clock diff --git a/test_fms/mpp/test_update_domains_performance.sh b/test_fms/mpp/test_update_domains_performance.sh index 9efd622b61..36303abd53 100755 --- a/test_fms/mpp/test_update_domains_performance.sh +++ b/test_fms/mpp/test_update_domains_performance.sh @@ -26,6 +26,10 @@ # Set common test settings. . ../test-lib.sh + +# ensure input.nml file present +touch input.nml + # Run the test for one processor test_expect_success "domain update performance with 1 PE" ' mpirun -n 1 ./test_update_domains_performance From 783019fdec89a8db2b26247c2f63d4782e1495c0 Mon Sep 17 00:00:00 2001 From: ganganoaa <121043264+ganganoaa@users.noreply.github.com> Date: Tue, 20 Jun 2023 13:37:04 -0400 Subject: [PATCH 25/51] fix: checks placed before allocating pointers passed into routines (#1152) --- exchange/xgrid.F90 | 69 ++++++++++++++++++--- mpp/include/mpp_define_nest_domains.inc | 16 +++++ mpp/include/mpp_domains_define.inc | 80 +++++++++++++++++++++++++ mpp/include/mpp_domains_util.inc | 4 ++ mpp/include/mpp_unstruct_domain.inc | 7 +++ 5 files changed, 169 insertions(+), 7 deletions(-) diff --git a/exchange/xgrid.F90 b/exchange/xgrid.F90 index 54a32ec8e2..63991a8059 100644 --- a/exchange/xgrid.F90 +++ b/exchange/xgrid.F90 @@ -1087,6 +1087,7 @@ subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, u grid%x(1:size_prev) = x_local deallocate(x_local) else + if(ASSOCIATED(grid%x)) deallocate(grid%x) !< Check if allocated allocate( grid%x( grid%size ) ) grid%x%di = 0.0; grid%x%dj = 0.0 end if @@ -1248,6 +1249,7 @@ subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, u grid%x_repro(1:ll_repro) = x_local deallocate(x_local) else + if(ASSOCIATED(grid%x_repro)) deallocate(grid%x_repro) !< Check if allocated allocate( grid%x_repro( grid%size_repro ) ) grid%x_repro%di = 0.0; grid%x_repro%dj = 0.0 end if @@ -1318,7 +1320,8 @@ subroutine get_grid_version1(grid, grid_id, grid_file) endif call mpp_get_compute_domain(grid%domain, is, ie, js, je) - + if (associated(grid%lon)) deallocate(grid%lon) !< Check if allocated + if (associated(grid%lat)) deallocate(grid%lat) !< Check if allocated allocate(grid%lon(grid%im), grid%lat(grid%jm)) if(grid_id == 'ATM') then call read_data(fileobj, 'xta', lonb) @@ -1413,6 +1416,8 @@ subroutine get_grid_version2(grid, grid_id, grid_file) start(2) = 2; nread(1) = nlon*2+1 allocate(tmpx(nlon*2+1, 1), tmpy(1, nlat*2+1)) call read_data(fileobj, "x", tmpx, corner=start, edge_lengths=nread) + if (associated(grid%lon)) deallocate(grid%lon) !< Check if allocated + if (associated(grid%lat)) deallocate(grid%lat) !< Check if allocated allocate(grid%lon(grid%im), grid%lat(grid%jm)) do i = 1, grid%im grid%lon(i) = tmpx(2*i,1) * d2r @@ -1425,6 +1430,8 @@ subroutine get_grid_version2(grid, grid_id, grid_file) end do grid%is_latlon = .true. else + if (associated(grid%geolon)) deallocate(grid%geolon) !< Check if allocated + if (associated(grid%geolat)) deallocate(grid%geolat) !< Check if allocated allocate(grid%geolon(grid%isd_me:grid%ied_me, grid%jsd_me:grid%jed_me)) allocate(grid%geolat(grid%isd_me:grid%ied_me, grid%jsd_me:grid%jed_me)) grid%geolon = 1e10 @@ -1545,8 +1552,12 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ xmap%npes = mpp_npes() xmap%root_pe = mpp_root_pe() + if (associated(xmap%grids)) deallocate(xmap%grids) !< Check if allocated allocate( xmap%grids(1:size(grid_ids(:))) ) + if (associated(xmap%your1my2)) deallocate(xmap%your1my2) !< Check if allocated + if (associated(xmap%your2my1)) deallocate(xmap%your2my1) !< Check if allocated + if (associated(xmap%your2my1_size)) deallocate(xmap%your2my1_size) !< Check if allocated allocate ( xmap%your1my2(0:xmap%npes-1), xmap%your2my1(0:xmap%npes-1) ) allocate ( xmap%your2my1_size(0:xmap%npes-1) ) @@ -1589,6 +1600,11 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ grid%id = grid_ids (g) grid%domain = grid_domains(g) grid%on_this_pe = mpp_domain_is_initialized(grid_domains(g)) + if (associated(grid%is)) deallocate(grid%is) !< Check if allocated + if (associated(grid%ie)) deallocate(grid%ie) !< Check if allocated + if (associated(grid%js)) deallocate(grid%js) !< Check if allocated + if (associated(grid%je)) deallocate(grid%je) !< Check if allocated + if (associated(grid%tile)) deallocate(grid%tile) !< Check if allocated allocate ( grid%is(0:xmap%npes-1), grid%ie(0:xmap%npes-1) ) allocate ( grid%js(0:xmap%npes-1), grid%je(0:xmap%npes-1) ) allocate ( grid%tile(0:xmap%npes-1) ) @@ -1679,6 +1695,10 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ 'does not support unstructured grid for VERSION1 grid' ,FATAL) grid%is_ug = .true. grid%ug_domain = lnd_ug_domain + if (associated(grid%ls)) deallocate(grid%ls) !< Check if allocated + if (associated(grid%le)) deallocate(grid%le) !< Check if allocated + if (associated(grid%gs)) deallocate(grid%gs) !< Check if allocated + if (associated(grid%ge)) deallocate(grid%ge) !< Check if allocated allocate ( grid%ls(0:xmap%npes-1), grid%le(0:xmap%npes-1) ) allocate ( grid%gs(0:xmap%npes-1), grid%ge(0:xmap%npes-1) ) grid%ls = 0 @@ -1695,6 +1715,7 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ grid%gs_me => grid%gs(xmap%me-xmap%root_pe); grid%ge_me => grid%ge(xmap%me-xmap%root_pe) grid%tile_me => grid%tile(xmap%me-xmap%root_pe) grid%nxl_me = grid%le_me - grid%ls_me + 1 + if (associated(grid%l_index)) deallocate(grid%l_index) !< Check if allocated allocate(grid%l_index(grid%gs_me:grid%ge_me)) allocate(grid_index(grid%ls_me:grid%le_me)) call mpp_get_UG_domain_grid_index(grid%ug_domain, grid_index) @@ -1705,6 +1726,8 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ enddo if( grid%on_this_pe ) then + if (associated(grid%area)) deallocate(grid%area) !< Check if allocated + if (associated(grid%area_inv)) deallocate(grid%area_inv) !< Check if allocated allocate( grid%area (grid%ls_me:grid%le_me,1) ) allocate( grid%area_inv(grid%ls_me:grid%le_me,1) ) grid%area = 0.0 @@ -1712,6 +1735,8 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ grid%size_repro = 0 endif else if( grid%on_this_pe ) then + if (associated(grid%area)) deallocate(grid%area) !< Check if allocated + if (associated(grid%area_inv)) deallocate(grid%area_inv) !< Check if allocated allocate( grid%area (grid%is_me:grid%ie_me, grid%js_me:grid%je_me) ) allocate( grid%area_inv(grid%is_me:grid%ie_me, grid%js_me:grid%je_me) ) grid%area = 0.0 @@ -1783,6 +1808,17 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%vlon', FATAL) if(size(atm_grid%vlat,1) .NE. 3 .OR. size(atm_grid%vlat,2) .NE. nxc .OR. size(atm_grid%vlat,3) .NE. nyc)& call error_mesg('xgrid_mod', 'incorrect dimension size of atm_grid%vlat', FATAL) + if (associated(grid%box%dx)) deallocate(grid%box%dx) !< Check if allocated + if (associated(grid%box%dy)) deallocate(grid%box%dy) !< Check if allocated + if (associated(grid%box%area)) deallocate(grid%box%area) !< Check if allocated + if (associated(grid%box%edge_w)) deallocate(grid%box%edge_w) !< Check if allocated + if (associated(grid%box%edge_e)) deallocate(grid%box%edge_e) !< Check if allocated + if (associated(grid%box%edge_s)) deallocate(grid%box%edge_s) !< Check if allocated + if (associated(grid%box%edge_n)) deallocate(grid%box%edge_n) !< Check if allocated + if (associated(grid%box%en1)) deallocate(grid%box%en1) !< Check if allocated + if (associated(grid%box%en2)) deallocate(grid%box%en2) !< Check if allocated + if (associated(grid%box%vlon)) deallocate(grid%box%vlon) !< Check if allocated + if (associated(grid%box%vlat)) deallocate(grid%box%vlat) !< Check if allocated allocate(grid%box%dx (grid%is_me:grid%ie_me, grid%js_me:grid%je_me+1 )) allocate(grid%box%dy (grid%is_me:grid%ie_me+1, grid%js_me:grid%je_me )) allocate(grid%box%area (grid%is_me:grid%ie_me, grid%js_me:grid%je_me )) @@ -1811,6 +1847,7 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ if(xmap%version==VERSION2) call close_file(mosaicfileobj) if (g>1) then if(grid%on_this_pe) then + if (associated(grid%frac_area)) deallocate(grid%frac_area) !< Check if allocated if(grid%is_ug) then allocate( grid%frac_area(grid%ls_me:grid%le_me, 1, grid%km) ) else @@ -1939,6 +1976,8 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ xmap%your2my1(xmap%me-xmap%root_pe) = .false. ! a PE from communicating with itself if (make_exchange_reproduce) then + if (associated(xmap%send_count_repro)) deallocate(xmap%send_count_repro) !< Check if allocated + if (associated(xmap%recv_count_repro)) deallocate(xmap%recv_count_repro) !< Check if allocated allocate( xmap%send_count_repro(0:xmap%npes-1) ) allocate( xmap%recv_count_repro(0:xmap%npes-1) ) xmap%send_count_repro = 0 @@ -1960,12 +1999,18 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ xmap%recv_count_repro_tot = 0 end if + if (associated(xmap%x1)) deallocate(xmap%x1) !< Check if allocated + if (associated(xmap%x2)) deallocate(xmap%x2) !< Check if allocated + if (associated(xmap%x1_put)) deallocate(xmap%x1_put) !< Check if allocated + if (associated(xmap%x2_get)) deallocate(xmap%x2_get) !< Check if allocated allocate( xmap%x1(1:sum(xmap%grids(2:size(xmap%grids(:)))%size)) ) allocate( xmap%x2(1:sum(xmap%grids(2:size(xmap%grids(:)))%size)) ) allocate( xmap%x1_put(1:sum(xmap%grids(2:size(xmap%grids(:)))%size)) ) allocate( xmap%x2_get(1:sum(xmap%grids(2:size(xmap%grids(:)))%size)) ) !--- The following will setup indx to be used in regen + if (associated(xmap%get1)) deallocate(xmap%get1) !< Check if allocated + if (associated(xmap%put1)) deallocate(xmap%put1) !< Check if allocated allocate(xmap%get1, xmap%put1) call mpp_clock_begin(id_set_comm) @@ -1974,6 +2019,7 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ call set_comm_put1(xmap) if(make_exchange_reproduce) then + if (associated(xmap%get1_repro)) deallocate(xmap%get1_repro) !< Check if allocated allocate(xmap%get1_repro) call set_comm_get1_repro(xmap) endif @@ -2174,6 +2220,7 @@ subroutine set_comm_get1_repro(xmap) comm%nrecv = nrecv if( nrecv > 0 ) then + if (associated(comm%recv)) deallocate(comm%recv) !< Check if allocated allocate(comm%recv(nrecv)) pos = 0 do n = 1, nrecv @@ -2200,6 +2247,7 @@ subroutine set_comm_get1_repro(xmap) comm%nsend = nsend if( nsend > 0 ) then + if (associated(comm%send)) deallocate(comm%send) !< Check if allocated allocate(comm%send(nsend)) pos = 0 cnt(:) = 0 @@ -2296,6 +2344,7 @@ subroutine set_comm_get1(xmap) if(max_size > 0) then allocate(pe_side1(max_size)) + if (associated(xmap%ind_get1)) deallocate(xmap%ind_get1) !< Check if allocated allocate(xmap%ind_get1(max_size)) !--- find the recv_indx @@ -2399,6 +2448,7 @@ subroutine set_comm_get1(xmap) nsend = count( send_size> 0) comm%nsend = nsend if(nsend>0) then + if (associated(comm%send)) deallocate(comm%send) !< Check if allocated allocate(comm%send(nsend)) comm%send(:)%count = 0 endif @@ -2474,6 +2524,7 @@ subroutine set_comm_get1(xmap) comm%recvsize = 0 if(nrecv >0) then + if (associated(comm%recv)) deallocate(comm%recv) !< Check if allocated allocate(comm%recv(nrecv)) comm%recv(:)%count = 0 !--- set up the buffer pos for each receiving @@ -2526,6 +2577,7 @@ subroutine set_comm_get1(xmap) endif endif enddo + if (associated(comm%unpack_ind)) deallocate(comm%unpack_ind) !< Check if allocated allocate(comm%unpack_ind(nrecv)) pos = 0 do p = 0, npes-1 @@ -2604,6 +2656,7 @@ subroutine set_comm_put1(xmap) if(max_size > 0) then allocate(pe_put1(max_size)) + if (associated(xmap%ind_put1)) deallocate(xmap%ind_put1) !< Check if allocated allocate(xmap%ind_put1(max_size)) !--- find the recv_indx @@ -2724,6 +2777,7 @@ subroutine set_comm_put1(xmap) nrecv = count( send_size> 0) comm%nrecv = nrecv if(nrecv>0) then + if (associated(comm%recv)) deallocate(comm%recv) !< Check if allocated allocate(comm%recv(nrecv)) comm%recv(:)%count = 0 endif @@ -2798,6 +2852,7 @@ subroutine set_comm_put1(xmap) comm%sendsize = 0 if(nsend >0) then + if (associated(comm%send)) deallocate(comm%send) !< Check if allocated allocate(comm%send(nsend)) comm%send(:)%count = 0 pos = 0 @@ -2864,8 +2919,8 @@ subroutine regen(xmap) end do if (max_size>size(xmap%x1(:))) then - deallocate(xmap%x1) - deallocate(xmap%x2) + if (associated(xmap%x1)) deallocate(xmap%x1) !< Check x1 if allocated + if (associated(xmap%x2)) deallocate(xmap%x2) !< Check x2 if allocated allocate( xmap%x1(1:max_size) ) allocate( xmap%x2(1:max_size) ) endif @@ -2933,11 +2988,11 @@ subroutine regen(xmap) if (max_size>size(xmap%x1_put(:))) then - deallocate(xmap%x1_put) + if (associated(xmap%x1_put)) deallocate(xmap%x1_put) !< Check if allocated allocate( xmap%x1_put(1:max_size) ) endif if (max_size>size(xmap%x2_get(:))) then - deallocate(xmap%x2_get) + if (associated(xmap%x2_get)) deallocate(xmap%x2_get) !< Check if allocated allocate( xmap%x2_get(1:max_size) ) endif @@ -3067,7 +3122,7 @@ subroutine set_frac_area_sg(f, grid_id, xmap) grid => xmap%grids(g) if (grid_id==grid%id) then if (size(f,3)/=size(grid%frac_area,3)) then - deallocate (grid%frac_area) + if (associated(grid%frac_area)) deallocate (grid%frac_area) !< Check if allocated grid%km = size(f,3); allocate( grid%frac_area(grid%is_me:grid%ie_me, grid%js_me:grid%je_me, & grid%km) ) @@ -3101,7 +3156,7 @@ subroutine set_frac_area_ug(f, grid_id, xmap) grid => xmap%grids(g) if (grid_id==grid%id) then if (size(f,2)/=size(grid%frac_area,3)) then - deallocate (grid%frac_area) + if (associated(grid%frac_area)) deallocate (grid%frac_area) !< Check if allocated grid%km = size(f,2); allocate( grid%frac_area(grid%ls_me:grid%le_me, 1, grid%km) ) end if diff --git a/mpp/include/mpp_define_nest_domains.inc b/mpp/include/mpp_define_nest_domains.inc index cbcefd8927..e8eea60d00 100644 --- a/mpp/include/mpp_define_nest_domains.inc +++ b/mpp/include/mpp_define_nest_domains.inc @@ -196,6 +196,7 @@ subroutine mpp_define_nest_domains(nest_domain, domain, num_nest, nest_level, ti allocate(nest_domain%jstart_coarse(num_nest), nest_domain%jend_coarse(num_nest) ) !---Added to enable moving nests + if (associated(nest_domain%nest_level)) deallocate(nest_domain%nest_level) !< Check if allocated allocate(nest_domain%nest_level(num_nest)) nest_domain%tile_fine = tile_fine(1:num_nest) @@ -253,6 +254,7 @@ subroutine mpp_define_nest_domains(nest_domain, domain, num_nest, nest_level, ti enddo nest_domain%num_level = nlevels + if (associated(nest_domain%nest)) deallocate(nest_domain%nest) !< Check if allocated allocate(nest_domain%nest(nlevels)) allocate(pelist_level(mpp_npes())) allocate(is_nest_fine(nlevels)) @@ -297,6 +299,7 @@ subroutine mpp_define_nest_domains(nest_domain, domain, num_nest, nest_level, ti endif enddo + if (associated(nest_domain%nest(l)%pelist)) deallocate(nest_domain%nest(l)%pelist) !< Check if allocated allocate(nest_domain%nest(l)%pelist(npes_level)) nest_domain%nest(l)%pelist(:) = pelist_level(1:npes_level) @@ -490,7 +493,9 @@ subroutine define_nest_level_type(nest_domain, x_refine, y_refine, extra_halo) endif enddo + if (associated(nest_domain%pelist_fine)) deallocate(nest_domain%pelist_fine) !< Check if allocated allocate(nest_domain%pelist_fine(npes_fine)) + if (associated(nest_domain%pelist_coarse)) deallocate(nest_domain%pelist_coarse) !< Check if allocated allocate(nest_domain%pelist_coarse(npes_coarse)) nest_domain%pelist_fine = pes_fine nest_domain%pelist_coarse = pes_coarse @@ -564,11 +569,19 @@ subroutine define_nest_level_type(nest_domain, x_refine, y_refine, extra_halo) nest_domain%x_refine = x_refine nest_domain%y_refine = y_refine + if (associated(nest_domain%C2F_T)) deallocate(nest_domain%C2F_T) !< Check if allocated + if (associated(nest_domain%C2F_C)) deallocate(nest_domain%C2F_C) !< Check if allocated + if (associated(nest_domain%C2F_E)) deallocate(nest_domain%C2F_E) !< Check if allocated + if (associated(nest_domain%C2F_N)) deallocate(nest_domain%C2F_N) !< Check if allocated allocate( nest_domain%C2F_T, nest_domain%C2F_C, nest_domain%C2F_E, nest_domain%C2F_N ) nest_domain%C2F_T%next => NULL() nest_domain%C2F_C%next => NULL() nest_domain%C2F_N%next => NULL() nest_domain%C2F_E%next => NULL() + if (associated(nest_domain%F2C_T)) deallocate(nest_domain%F2C_T) !< Check if allocated + if (associated(nest_domain%F2C_C)) deallocate(nest_domain%F2C_C) !< Check if allocated + if (associated(nest_domain%F2C_E)) deallocate(nest_domain%F2C_E) !< Check if allocated + if (associated(nest_domain%F2C_N)) deallocate(nest_domain%F2C_N) !< Check if allocated allocate( nest_domain%F2C_T, nest_domain%F2C_C, nest_domain%F2C_E, nest_domain%F2C_N ) call compute_overlap_fine_to_coarse(nest_domain, nest_domain%F2C_T, CENTER, "F2C T-cell") @@ -1029,6 +1042,7 @@ subroutine compute_overlap_coarse_to_fine(nest_domain, overlap, extra_halo, posi !--- copy the overlapping into nest_domain data. overlap%nrecv = nrecv if( nrecv > 0 ) then + if (associated(overlap%recv)) deallocate(overlap%recv) !< Check if allocated allocate(overlap%recv(nrecv)) do n = 1, nrecv call copy_nest_overlap( overlap%recv(n), overLaplist(n) ) @@ -1039,6 +1053,7 @@ subroutine compute_overlap_coarse_to_fine(nest_domain, overlap, extra_halo, posi overlap%nsend = nsend if( nsend > 0 ) then + if (associated(overlap%send)) deallocate(overlap%send) !< Check if allocated allocate(overlap%send(nsend)) do n = 1, nsend call copy_nest_overlap( overlap%send(n), overLaplist(n) ) @@ -1256,6 +1271,7 @@ subroutine compute_overlap_fine_to_coarse(nest_domain, overlap, position, name) enddo overlap%nsend = nsend if(nsend > 0) then + if (associated(overlap%send)) deallocate(overlap%send) !< Check if allocated allocate(overlap%send(nsend)) do n = 1, nsend call copy_nest_overlap(overlap%send(n), overlaplist(n) ) diff --git a/mpp/include/mpp_domains_define.inc b/mpp/include/mpp_domains_define.inc index f3d6eff63a..5da34c5c47 100644 --- a/mpp/include/mpp_domains_define.inc +++ b/mpp/include/mpp_domains_define.inc @@ -490,6 +490,7 @@ "mpp_domains_define.inc(mpp_define_io_domain): "//trim(domain%name)// & ": multiple tile per pe is not supported yet for this routine") + if (associated(domain%io_domain)) deallocate(domain%io_domain) !< Check if associated allocate(domain%io_domain) domain%io_layout = io_layout io_domain => domain%io_domain @@ -516,6 +517,7 @@ io_domain%ntiles = 1 io_domain%pe = domain%pe io_domain%symmetry = domain%symmetry + if (associated(io_domain%list)) deallocate(io_domain%list) !< Check if associated allocate(io_domain%list(0:npes_in_group-1)) do i = 0, npes_in_group-1 allocate( io_domain%list(i)%x(1), io_domain%list(i)%y(1), io_domain%list(i)%tile_id(1) ) @@ -550,6 +552,9 @@ enddo deallocate(posarray) + if (associated(io_domain%x)) deallocate(io_domain%x) !< Check if associated + if (associated(io_domain%y)) deallocate(io_domain%y) !< Check if associated + if (associated(io_domain%tile_id)) deallocate(io_domain%tile_id) !< Check if associated allocate(io_domain%x(1), io_domain%y(1), io_domain%tile_id(1) ) allocate(io_domain%x(1)%list(0:npes_x-1), io_domain%y(1)%list(0:npes_y-1) ) n = -1 @@ -858,6 +863,7 @@ !--- when tile is not equal to 1, the layout for that tile always ( 1, 1), so no need for pearray in domain if( tile == 1 ) then + if (associated(domain%pearray)) deallocate(domain%pearray) !< Check if allocated allocate( domain%pearray(0:ndivx-1,0:ndivy-1) ) domain%pearray = pearray end if @@ -1010,11 +1016,18 @@ if(is_complete) then domain%whalo = whalosz; domain%ehalo = ehalosz domain%shalo = shalosz; domain%nhalo = nhalosz + if (associated(domain%update_T)) deallocate(domain%update_T) !< Check if associated + if (associated(domain%update_E)) deallocate(domain%update_E) !< Check if associated + if (associated(domain%update_C)) deallocate(domain%update_C) !< Check if associated + if (associated(domain%update_N)) deallocate(domain%update_N) !< Check if associated allocate(domain%update_T, domain%update_E, domain%update_C, domain%update_N) domain%update_T%next => NULL() domain%update_E%next => NULL() domain%update_C%next => NULL() domain%update_N%next => NULL() + if (associated(domain%check_E)) deallocate(domain%check_E) !< Check if associated + if (associated(domain%check_C)) deallocate(domain%check_C) !< Check if associated + if (associated(domain%check_N)) deallocate(domain%check_N) !< Check if associated allocate(domain%check_E, domain%check_C, domain%check_N ) domain%update_T%nsend = 0 domain%update_T%nrecv = 0 @@ -1061,6 +1074,9 @@ call set_check_overlap( domain, CORNER ) call set_check_overlap( domain, EAST ) call set_check_overlap( domain, NORTH ) + if (associated(domain%bound_E)) deallocate(domain%bound_E) !< Check if associated + if (associated(domain%bound_C)) deallocate(domain%bound_C) !< Check if associated + if (associated(domain%bound_N)) deallocate(domain%bound_N) !< Check if associated allocate(domain%bound_E, domain%bound_C, domain%bound_N ) call set_bound_overlap( domain, CORNER ) call set_bound_overlap( domain, EAST ) @@ -1297,6 +1313,7 @@ end subroutine check_message_size 'mpp_domains_define.inc: the third dimension of maskmap is not equal num_tile') end if + if (associated(domain%tileList)) deallocate(domain%tileList) !< Check if associated allocate(domain%tileList(num_tile)) do n = 1, num_tile domain%tileList(n)%xbegin = global_indices(1,n) @@ -1306,6 +1323,10 @@ end subroutine check_message_size enddo !--- define some mosaic information in domain type nt = ntile_per_pe(mpp_pe()-mpp_root_pe()) + if (associated(domain%tile_id)) deallocate(domain%tile_id) !< Check if associated + if (associated(domain%x)) deallocate(domain%x) !< Check if associated + if (associated(domain%y)) deallocate(domain%y) !< Check if associated + if (associated(domain%list)) deallocate(domain%list) !< Check if associated allocate(domain%tile_id(nt), domain%x(nt), domain%y(nt) ) allocate(domain%list(0:nlist-1)) @@ -1344,6 +1365,7 @@ end subroutine check_message_size end if end do + if (associated(domain%tile_id_all)) deallocate(domain%tile_id_all) !< Check if associated allocate(domain%tile_id_all(num_tile)) domain%tile_id_all(:) = tile_id_local(:) @@ -1518,6 +1540,9 @@ end subroutine check_message_size call set_check_overlap( domain, NORTH ) endif if(domain%symmetry) then + if (associated(domain%bound_E)) deallocate(domain%bound_E) !< Check if associated + if (associated(domain%bound_C)) deallocate(domain%bound_C) !< Check if associated + if (associated(domain%bound_N)) deallocate(domain%bound_N) !< Check if associated allocate(domain%bound_E, domain%bound_C, domain%bound_N ) call set_bound_overlap( domain, CORNER ) call set_bound_overlap( domain, EAST ) @@ -2128,6 +2153,7 @@ end subroutine check_message_size ! copy the overlapping information into domain data structure if(nsend>0) then + if (associated(update%send)) deallocate(update%send) !< Check if associated allocate(update%send(nsend)) update%nsend = nsend do m = 1, nsend @@ -2137,6 +2163,7 @@ end subroutine check_message_size if(nsend_check>0) then check%nsend = nsend_check + if (associated(check%send)) deallocate(check%send) !< Check if associated allocate(check%send(nsend_check)) do m = 1, nsend_check call add_check_overlap( check%send(m), checkList(m) ) @@ -2705,6 +2732,7 @@ end subroutine check_message_size ! copy the overlapping information into domain if(nrecv>0) then + if (associated(update%recv)) deallocate(update%recv) !< Check if associated allocate(update%recv(nrecv)) update%nrecv = nrecv do m = 1, nrecv @@ -2720,6 +2748,7 @@ end subroutine check_message_size if(nrecv_check>0) then check%nrecv = nrecv_check + if (associated(check%recv)) deallocate(check%recv) !< Check if associated allocate(check%recv(nrecv_check)) do m = 1, nrecv_check call add_check_overlap( check%recv(m), checkList(m) ) @@ -3296,6 +3325,7 @@ end subroutine check_message_size ! copy the overlapping information into domain data structure if(nsend>0) then + if (associated(update%send)) deallocate(update%send) !< Check if associated allocate(update%send(nsend)) update%nsend = nsend do m = 1, nsend @@ -3304,6 +3334,7 @@ end subroutine check_message_size endif if(nsend_check>0) then + if (associated(check%send)) deallocate(check%send) !< Check if associated allocate(check%send(nsend_check)) check%nsend = nsend_check do m = 1, nsend_check @@ -3568,6 +3599,7 @@ end subroutine check_message_size ! copy the overlapping information into domain if(nrecv>0) then update%nrecv = nrecv + if (associated(update%recv)) deallocate(update%recv) !< Check if associated allocate(update%recv(nrecv)) do m = 1, nrecv call add_update_overlap( update%recv(m), overlapList(m) ) @@ -3582,6 +3614,7 @@ end subroutine check_message_size if(nrecv_check>0) then check%nrecv = nrecv_check + if (associated(check%recv)) deallocate(check%recv) !< Check if associated allocate(check%recv(nrecv_check)) do m = 1, nrecv_check call add_check_overlap( check%recv(m), checkList(m) ) @@ -3931,6 +3964,7 @@ end subroutine check_message_size ! copy the overlapping information into domain data structure if(nsend>0) then update%nsend = nsend + if (associated(update%send)) deallocate(update%send) !< Check if associated allocate(update%send(nsend)) do m = 1, nsend call add_update_overlap( update%send(m), overlapList(m) ) @@ -3939,6 +3973,7 @@ end subroutine check_message_size if(nsend_check>0) then check%nsend = nsend_check + if (associated(check%send)) deallocate(check%send) !< Check if associated allocate(check%send(nsend_check)) do m = 1, nsend_check call add_check_overlap( check%send(m), checkList(m) ) @@ -4195,6 +4230,7 @@ end subroutine check_message_size ! copy the overlapping information into domain if(nrecv>0) then update%nrecv = nrecv + if (associated(update%recv)) deallocate(update%recv) !< Check if associated allocate(update%recv(nrecv)) do m = 1, nrecv call add_update_overlap( update%recv(m), overlapList(m) ) @@ -4209,6 +4245,7 @@ end subroutine check_message_size if(nrecv_check>0) then check%nrecv = nrecv_check + if (associated(check%recv)) deallocate(check%recv) !< Check if associated allocate(check%recv(nrecv_check)) do m = 1, nrecv_check call add_check_overlap( check%recv(m), checkList(m) ) @@ -4543,6 +4580,7 @@ end subroutine check_message_size ! copy the overlapping information into domain data structure if(nsend>0) then update%nsend = nsend + if (associated(update%send)) deallocate(update%send) !< Check if associated allocate(update%send(nsend)) do m = 1, nsend call add_update_overlap( update%send(m), overlapList(m) ) @@ -4551,6 +4589,7 @@ end subroutine check_message_size if(nsend_check>0) then check%nsend = nsend_check + if (associated(check%send)) deallocate(check%send) !< Check if associated allocate(check%send(nsend_check)) do m = 1, nsend_check call add_check_overlap( check%send(m), checkList(m) ) @@ -4794,6 +4833,7 @@ end subroutine check_message_size ! copy the overlapping information into domain if(nrecv>0) then update%nrecv = nrecv + if (associated(update%recv)) deallocate(update%recv) !< Check if associated allocate(update%recv(nrecv)) do m = 1, nrecv call add_update_overlap( update%recv(m), overlapList(m) ) @@ -4808,6 +4848,7 @@ end subroutine check_message_size if(nrecv_check>0) then check%nrecv = nrecv_check + if (associated(check%recv)) deallocate(check%recv) !< Check if associated allocate(check%recv(nrecv_check)) do m = 1, nrecv_check call add_check_overlap( check%recv(m), checkList(m) ) @@ -5065,6 +5106,7 @@ end subroutine check_message_size if(nsend>0) then overlap_out%nsend = nsend + if (associated(overlap_out%send)) deallocate(overlap_out%send) !< Check if associated allocate(overlap_out%send(nsend)); do n = 1, nsend call add_update_overlap(overlap_out%send(n), send(n) ) @@ -5154,6 +5196,7 @@ end subroutine check_message_size if(nrecv>0) then overlap_out%nrecv = nrecv + if (associated(overlap_out%recv)) deallocate(overlap_out%recv) !< Check if associated allocate(overlap_out%recv(nrecv)); do n = 1, nrecv call add_update_overlap(overlap_out%recv(n), recv(n) ) @@ -6053,6 +6096,7 @@ subroutine set_contact_point(domain, position) update_out%nsend = nsend if(nsend>0) then + if (associated(update_out%send)) deallocate(update_out%send) !< Check if associated allocate(update_out%send(nsend)) pos = 0 do list = 0, nlist-1 @@ -6135,6 +6179,7 @@ subroutine set_contact_point(domain, position) update_out%nrecv = nrecv if(nrecv>0) then + if (associated(update_out%recv)) deallocate(update_out%recv) !< Check if associated allocate(update_out%recv(nrecv)) pos = 0 do list = 0, nlist-1 @@ -6204,6 +6249,7 @@ do m = 1, update%nsend enddo if(nsend>0) then + if (associated(check%send)) deallocate(check%send) !< Check if associated allocate(check%send(nsend)) call allocate_check_overlap(overlap, maxsize) endif @@ -6280,6 +6326,7 @@ enddo if(nsend>0) call deallocate_overlap_type(overlap) if(nrecv>0) then + if (associated(check%recv)) deallocate(check%recv) !< Check if associated allocate(check%recv(nrecv)) call allocate_check_overlap(overlap, maxsize) endif @@ -6378,10 +6425,12 @@ subroutine set_bound_overlap( domain, position ) bound%nsend = nlist_send bound%nrecv = nlist_recv if(nlist_send >0) then + if (associated(bound%send)) deallocate(bound%send) !< Check if associated allocate(bound%send(nlist_send)) bound%send(:)%count = 0 endif if(nlist_recv >0) then + if (associated(bound%recv)) deallocate(bound%recv) !< Check if associated allocate(bound%recv(nlist_recv)) bound%recv(:)%count = 0 endif @@ -6522,6 +6571,13 @@ subroutine set_bound_overlap( domain, position ) if(nsend > nlist_send) call mpp_error(FATAL, "set_bound_overlap: nsend > nlist_send") bound%send(nsend)%count = count bound%send(nsend)%pe = my_pe + if (associated(bound%send(nsend)%is)) deallocate(bound%send(nsend)%is) !< Check if allocated + if (associated(bound%send(nsend)%ie)) deallocate(bound%send(nsend)%ie) !< Check if allocated + if (associated(bound%send(nsend)%js)) deallocate(bound%send(nsend)%js) !< Check if allocated + if (associated(bound%send(nsend)%je)) deallocate(bound%send(nsend)%je) !< Check if allocated + if (associated(bound%send(nsend)%dir)) deallocate(bound%send(nsend)%dir) !< Check if allocated + if (associated(bound%send(nsend)%rotation)) deallocate(bound%send(nsend)%rotation) !< Check if allocated + if (associated(bound%send(nsend)%tileMe)) deallocate(bound%send(nsend)%tileMe) !< Check if allocated allocate(bound%send(nsend)%is(count), bound%send(nsend)%ie(count) ) allocate(bound%send(nsend)%js(count), bound%send(nsend)%je(count) ) allocate(bound%send(nsend)%dir(count), bound%send(nsend)%rotation(count) ) @@ -6621,6 +6677,13 @@ subroutine set_bound_overlap( domain, position ) nsend = nsend + 1 bound%send(nsend)%count = count bound%send(nsend)%pe = overlap%pe + if (associated(bound%send(nsend)%is)) deallocate(bound%send(nsend)%is) !< Check if allocated + if (associated(bound%send(nsend)%ie)) deallocate(bound%send(nsend)%ie) !< Check if allocated + if (associated(bound%send(nsend)%js)) deallocate(bound%send(nsend)%js) !< Check if allocated + if (associated(bound%send(nsend)%je)) deallocate(bound%send(nsend)%je) !< Check if allocated + if (associated(bound%send(nsend)%dir)) deallocate(bound%send(nsend)%dir) !< Check if allocated + if (associated(bound%send(nsend)%rotation)) deallocate(bound%send(nsend)%rotation) !< Check if allocated + if (associated(bound%send(nsend)%tileMe)) deallocate(bound%send(nsend)%tileMe) !< Check if allocated allocate(bound%send(nsend)%is(count), bound%send(nsend)%ie(count) ) allocate(bound%send(nsend)%js(count), bound%send(nsend)%je(count) ) allocate(bound%send(nsend)%dir(count), bound%send(nsend)%rotation(count) ) @@ -6770,6 +6833,14 @@ subroutine set_bound_overlap( domain, position ) if(nrecv > nlist_recv) call mpp_error(FATAL, "set_bound_overlap: nrecv > nlist_recv") bound%recv(nrecv)%count = count bound%recv(nrecv)%pe = my_pe + if (associated(bound%recv(nrecv)%is)) deallocate(bound%recv(nrecv)%is) !< Check if allocated + if (associated(bound%recv(nrecv)%ie)) deallocate(bound%recv(nrecv)%ie) !< Check if allocated + if (associated(bound%recv(nrecv)%js)) deallocate(bound%recv(nrecv)%js) !< Check if allocated + if (associated(bound%recv(nrecv)%je)) deallocate(bound%recv(nrecv)%je) !< Check if allocated + if (associated(bound%recv(nrecv)%dir)) deallocate(bound%recv(nrecv)%dir) !< Check if allocated + if (associated(bound%recv(nrecv)%index)) deallocate(bound%recv(nrecv)%index) !< Check if allocated + if (associated(bound%recv(nrecv)%tileMe)) deallocate(bound%recv(nrecv)%tileMe) !< Check if allocated + if (associated(bound%recv(nrecv)%rotation)) deallocate(bound%recv(nrecv)%rotation) !< Check if allocated allocate(bound%recv(nrecv)%is(count), bound%recv(nrecv)%ie(count) ) allocate(bound%recv(nrecv)%js(count), bound%recv(nrecv)%je(count) ) allocate(bound%recv(nrecv)%dir(count), bound%recv(nrecv)%index(count) ) @@ -6865,6 +6936,14 @@ subroutine set_bound_overlap( domain, position ) nrecv = nrecv + 1 bound%recv(nrecv)%count = count bound%recv(nrecv)%pe = overlap%pe + if (associated(bound%recv(nrecv)%is)) deallocate(bound%recv(nrecv)%is) !< Check if allocated + if (associated(bound%recv(nrecv)%ie)) deallocate(bound%recv(nrecv)%ie) !< Check if allocated + if (associated(bound%recv(nrecv)%js)) deallocate(bound%recv(nrecv)%js) !< Check if allocated + if (associated(bound%recv(nrecv)%je)) deallocate(bound%recv(nrecv)%je) !< Check if allocated + if (associated(bound%recv(nrecv)%dir)) deallocate(bound%recv(nrecv)%dir) !< Check if allocated + if (associated(bound%recv(nrecv)%index)) deallocate(bound%recv(nrecv)%index) !< Check if allocated + if (associated(bound%recv(nrecv)%tileMe)) deallocate(bound%recv(nrecv)%tileMe) !< Check if allocated + if (associated(bound%recv(nrecv)%rotation)) deallocate(bound%recv(nrecv)%rotation) !< Check if allocated allocate(bound%recv(nrecv)%is(count), bound%recv(nrecv)%ie(count) ) allocate(bound%recv(nrecv)%js(count), bound%recv(nrecv)%je(count) ) allocate(bound%recv(nrecv)%dir(count), bound%recv(nrecv)%index(count) ) @@ -7531,6 +7610,7 @@ if(present(whalo) .or. present(ehalo) .or. present(shalo) .or. present(nhalo) ) else call mpp_define_null_domain(domain_out) nlist = size(domain_in%list(:)) + if (associated(domain_out%list)) deallocate(domain_out%list) !< Check if allocated allocate(domain_out%list(0:nlist-1) ) do i = 0, nlist-1 allocate(domain_out%list(i)%tile_id(1)) diff --git a/mpp/include/mpp_domains_util.inc b/mpp/include/mpp_domains_util.inc index c27af7c093..3d72df4a43 100644 --- a/mpp/include/mpp_domains_util.inc +++ b/mpp/include/mpp_domains_util.inc @@ -1738,6 +1738,7 @@ end subroutine mpp_get_tile_compute_domains if (associated(domain_in%list)) then starting = lbound(domain_in%list, 1) ending = ubound(domain_in%list, 1) + if (associated(domain_out%list)) deallocate(domain_out%list) !< Check if allocated allocate(domain_out%list(starting:ending)) do i = starting, ending @@ -1843,6 +1844,7 @@ end subroutine mpp_get_tile_compute_domains starting = lbound(domain2D_spec_in%tile_id,1) ending = ubound(domain2D_spec_in%tile_id,1) + if (associated(domain2D_spec_out%tile_id)) deallocate(domain2D_spec_out%tile_id) !< Check if allocated allocate(domain2D_spec_out%tile_id(starting:ending)) domain2D_spec_out%tile_id = domain2D_spec_in%tile_id endif @@ -1851,6 +1853,7 @@ end subroutine mpp_get_tile_compute_domains starting = lbound(domain2D_spec_in%x,1) ending = ubound(domain2D_spec_in%x,1) + if (associated(domain2D_spec_out%x)) deallocate(domain2D_spec_out%x) !< Check if allocated allocate(domain2D_spec_out%x(starting:ending)) do i = starting, ending call mpp_copy_domain1D_spec(domain2D_spec_in%x(i), domain2D_spec_out%x(i)) @@ -1861,6 +1864,7 @@ end subroutine mpp_get_tile_compute_domains starting = lbound(domain2D_spec_in%y,1) ending = ubound(domain2D_spec_in%y,1) + if (associated(domain2D_spec_out%y)) deallocate(domain2D_spec_out%y) !< Check if allocated allocate(domain2D_spec_out%y(starting:ending)) do i = starting, ending call mpp_copy_domain1D_spec(domain2D_spec_in%y(i), domain2D_spec_out%y(i)) diff --git a/mpp/include/mpp_unstruct_domain.inc b/mpp/include/mpp_unstruct_domain.inc index a074cc3f03..2b88c630a1 100644 --- a/mpp/include/mpp_unstruct_domain.inc +++ b/mpp/include/mpp_unstruct_domain.inc @@ -137,6 +137,7 @@ pe_end(n) = te ioff = ioff+ npts_tile(n) enddo + if (associated(UG_domain%list)) deallocate(UG_domain%list) !< Check if allocated allocate(UG_domain%list(0:ndivs-1)) do p = 0, ndivs-1 UG_domain%list(p)%compute%begin = ibegin(p) @@ -185,12 +186,14 @@ UG_domain%global%begin_index = grid_index(pos+1) UG_domain%global%end_index = grid_index(pos+npts_tile(n)) + if (associated(UG_domain%grid_index)) deallocate(UG_domain%grid_index) !< Check if allocated allocate(UG_domain%grid_index(UG_domain%compute%size)) do n = 1, UG_domain%compute%size UG_domain%grid_index(n) = grid_index(pos+UG_domain%compute%begin+n-1) enddo !--- define io_domain + if (associated(UG_domain%io_domain)) deallocate(UG_domain%io_domain) !< Check if allocated allocate(UG_domain%io_domain) tile_id = UG_domain%tile_id UG_domain%io_domain%pe = UG_domain%pe @@ -230,6 +233,7 @@ UG_domain%io_domain%global%size = UG_domain%io_domain%global%end - UG_domain%io_domain%global%begin + 1 npes_in_group = iend(group_id) - ibegin(group_id) + 1 + if (associated(UG_domain%io_domain%list)) deallocate(UG_domain%io_domain%list) !< Check if allocated allocate(UG_domain%io_domain%list(0:npes_in_group-1)) do n = 0, npes_in_group-1 pos = UG_domain%io_domain%tile_root_pe - mpp_root_pe() + n @@ -307,6 +311,7 @@ nrecv = count( recv_cnt > 0 ) UG_domain%SG2UG%nrecv = nrecv + if (associated(UG_domain%SG2UG%recv)) deallocate(UG_domain%SG2UG%recv) !< Check if allocated allocate(UG_domain%SG2UG%recv(nrecv)) nrecv = 0 pos = 0 @@ -351,6 +356,7 @@ nsend = count( recv_cnt(:) > 0 ) UG_domain%SG2UG%nsend = nsend + if (associated(UG_domain%SG2UG%send)) deallocate(UG_domain%SG2UG%send) !< Check if allocated allocate(UG_domain%SG2UG%send(nsend)) nsend = 0 isc = SG_domain%x(1)%compute%begin @@ -610,6 +616,7 @@ return if( .NOT.native )then !initialize domain%list and set null values in message + if (associated(domain%list)) deallocate(domain%list) !< Check if allocated allocate( domain%list(0:listsize-1) ) domain%pe = NULL_PE domain%pos = -1 From 5e130efb968f360a6d6b0dfe6366d9f88520e3d1 Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Tue, 27 Jun 2023 11:46:49 -0400 Subject: [PATCH 26/51] fix: continuation line syntax for fms2_io error messages (#1265) --- fms2_io/include/unpack_data.inc | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/fms2_io/include/unpack_data.inc b/fms2_io/include/unpack_data.inc index c3695c4793..23bc19f8bd 100644 --- a/fms2_io/include/unpack_data.inc +++ b/fms2_io/include/unpack_data.inc @@ -59,8 +59,8 @@ subroutine unpack_data_0d(fileobj, varid, varname, var_data) var_data = var_data + buf_r8_kind class default - call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& - "r4_kind or r8_kind."//trim(msg)) + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be & + &r4_kind or r8_kind."//trim(msg)) end select end if end subroutine @@ -103,8 +103,8 @@ subroutine unpack_data_1d(fileobj, varid, varname, var_data) var_data = var_data + buf_r8_kind class default - call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& - "r4_kind or r8_kind."//trim(msg)) + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be & + &r4_kind or r8_kind."//trim(msg)) end select end if end subroutine @@ -147,8 +147,8 @@ subroutine unpack_data_2d(fileobj, varid, varname, var_data) var_data = var_data + buf_r8_kind class default - call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& - "r4_kind or r8_kind."//trim(msg)) + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be & + &r4_kind or r8_kind."//trim(msg)) end select end if end subroutine @@ -191,8 +191,8 @@ subroutine unpack_data_3d(fileobj, varid, varname, var_data) var_data = var_data + buf_r8_kind class default - call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& - "r4_kind or r8_kind."//trim(msg)) + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be & + &r4_kind or r8_kind."//trim(msg)) end select end if end subroutine @@ -235,8 +235,8 @@ subroutine unpack_data_4d(fileobj, varid, varname, var_data) var_data = var_data + buf_r8_kind class default - call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& - "r4_kind or r8_kind."//trim(msg)) + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be & + &r4_kind or r8_kind."//trim(msg)) end select end if end subroutine @@ -279,8 +279,8 @@ subroutine unpack_data_5d(fileobj, varid, varname, var_data) var_data = var_data + buf_r8_kind class default - call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be"& - "r4_kind or r8_kind."//trim(msg)) + call error("If using the scale_factor and add_offset variable, the buffer reading the data to needs to be & + &r4_kind or r8_kind."//trim(msg)) end select end if end subroutine From 84b330a9f78a1fe7997dca39ff56d6f000a9c3d6 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 29 Jun 2023 08:48:14 -0400 Subject: [PATCH 27/51] fix: update doc site deployment action(#1078) --- .github/workflows/update_docs.yml | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) diff --git a/.github/workflows/update_docs.yml b/.github/workflows/update_docs.yml index 6a4b4bf917..bbf2335811 100644 --- a/.github/workflows/update_docs.yml +++ b/.github/workflows/update_docs.yml @@ -6,7 +6,7 @@ on: types: [published] workflow_dispatch: jobs: - update_docs: + build: runs-on: ubuntu-latest steps: - name: Checkout code @@ -23,8 +23,26 @@ jobs: run: | sudo apt -y install doxygen graphviz doxygen gen_docs/Doxyfile - - name: Deploy - uses: peaceiris/actions-gh-pages@v3 + - name: Upload Pages Artifact + uses: actions/upload-pages-artifact@v1 with: - github_token: ${{ secrets.GITHUB_TOKEN }} - publish_dir: ./gen_docs/html + path: 'gen_docs/html' + deploy: + needs: build + + # Grant GITHUB_TOKEN the permissions required to make a Pages deployment + permissions: + pages: write # to deploy to Pages + id-token: write # to verify the deployment originates from an appropriate source + + # Deploy to the github-pages environment + environment: + name: github-pages + url: ${{ steps.deployment.outputs.page_url }} + + # Specify runner + deployment step + runs-on: ubuntu-latest + steps: + - name: Deploy to GitHub Pages + id: deployment + uses: actions/deploy-pages@v1 From ef8b5e317f2904945da40abfd95021e903a8e401 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 29 Jun 2023 09:00:44 -0400 Subject: [PATCH 28/51] fix: warnings in test_mpp_nesting.F90 (#1118) --- test_fms/mpp/test_mpp_nesting.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/test_fms/mpp/test_mpp_nesting.F90 b/test_fms/mpp/test_mpp_nesting.F90 index d086992c4b..201fd217f0 100644 --- a/test_fms/mpp/test_mpp_nesting.F90 +++ b/test_fms/mpp/test_mpp_nesting.F90 @@ -1406,10 +1406,10 @@ subroutine test_update_nest_domain_r8( type ) if( isw_f .NE. isw_f2 .OR. iew_f .NE. iew_f2 .OR. jsw_f .NE. jsw_f2 .OR. jew_f .NE. jew_f2 .OR. & isw_c .NE. isw_c2 .OR. iew_c .NE. iew_c2 .OR. jsw_c .NE. jsw_c2 .OR. jew_c .NE. jew_c2 ) then - write(5000+mpp_pe(),*), "west buffer fine index = ", isw_f, iew_f, jsw_f, jew_f - write(5000+mpp_pe(),*), "west buffer fine index2 = ", isw_f2, iew_f2, jsw_f2, jew_f2 - write(5000+mpp_pe(),*), "west buffer coarse index = ", isw_c, iew_c, jsw_c, jew_c - write(5000+mpp_pe(),*), "west buffer coarse index2 = ", isw_c2, iew_c2, jsw_c2, jew_c2 + write(5000+mpp_pe(),*) "west buffer fine index = ", isw_f, iew_f, jsw_f, jew_f + write(5000+mpp_pe(),*) "west buffer fine index2 = ", isw_f2, iew_f2, jsw_f2, jew_f2 + write(5000+mpp_pe(),*) "west buffer coarse index = ", isw_c, iew_c, jsw_c, jew_c + write(5000+mpp_pe(),*) "west buffer coarse index2 = ", isw_c2, iew_c2, jsw_c2, jew_c2 call mpp_error(FATAL, "test_mpp_domains: west buffer index mismatch for coarse to fine scalar") endif if( ise_f .NE. ise_f2 .OR. iee_f .NE. iee_f2 .OR. jse_f .NE. jse_f2 .OR. jee_f .NE. jee_f2 .OR. & @@ -3433,10 +3433,10 @@ subroutine test_update_nest_domain_r4( type ) if( isw_f .NE. isw_f2 .OR. iew_f .NE. iew_f2 .OR. jsw_f .NE. jsw_f2 .OR. jew_f .NE. jew_f2 .OR. & isw_c .NE. isw_c2 .OR. iew_c .NE. iew_c2 .OR. jsw_c .NE. jsw_c2 .OR. jew_c .NE. jew_c2 ) then - write(5000+mpp_pe(),*), "west buffer fine index = ", isw_f, iew_f, jsw_f, jew_f - write(5000+mpp_pe(),*), "west buffer fine index2 = ", isw_f2, iew_f2, jsw_f2, jew_f2 - write(5000+mpp_pe(),*), "west buffer coarse index = ", isw_c, iew_c, jsw_c, jew_c - write(5000+mpp_pe(),*), "west buffer coarse index2 = ", isw_c2, iew_c2, jsw_c2, jew_c2 + write(5000+mpp_pe(),*) "west buffer fine index = ", isw_f, iew_f, jsw_f, jew_f + write(5000+mpp_pe(),*) "west buffer fine index2 = ", isw_f2, iew_f2, jsw_f2, jew_f2 + write(5000+mpp_pe(),*) "west buffer coarse index = ", isw_c, iew_c, jsw_c, jew_c + write(5000+mpp_pe(),*) "west buffer coarse index2 = ", isw_c2, iew_c2, jsw_c2, jew_c2 call mpp_error(FATAL, "test_mpp_domains: west buffer index mismatch for coarse to fine scalar") endif if( ise_f .NE. ise_f2 .OR. iee_f .NE. iee_f2 .OR. jse_f .NE. jse_f2 .OR. jee_f .NE. jee_f2 .OR. & From 3138e4ae1f165a8585cdb87834c5e1a0ae0c81db Mon Sep 17 00:00:00 2001 From: Caitlyn McAllister <65364559+mcallic2@users.noreply.github.com> Date: Fri, 30 Jun 2023 14:22:31 -0400 Subject: [PATCH 29/51] chore!: deprecate fms/mpp_io with use_deprecated_io macro (#1064) BREAKING CHANGE: This commit removes mpp_io_mod and fms_io_mod, along with other routines that use the modules, from default compilation. The -Duse_deprecated_io CPP flag or --enable-deprecated-io configure time flag can be used to enable their compilation. --- axis_utils/axis_utils.F90 | 3 +- coupler/coupler_types.F90 | 14 +++- coupler/ensemble_manager.F90 | 4 + fms/fms.F90 | 27 +++++-- fms/fms_io.F90 | 3 +- mosaic/grid.F90 | 3 +- mosaic/mosaic.F90 | 3 +- mpp/mpp_io.F90 | 3 +- test_fms/data_override/test_data_override.F90 | 78 +++++++++++-------- test_fms/diag_manager/test_diag_manager.F90 | 15 ++-- test_fms/fms/test_fms.F90 | 1 + test_fms/interpolator/test_interpolator.F90 | 13 +++- test_fms/mpp/test_global_arrays.F90 | 2 - test_fms/mpp/test_mpp.F90 | 2 - test_fms/mpp/test_mpp_gatscat.F90 | 2 - test_fms/mpp/test_mpp_global_sum_ad.F90 | 2 - test_fms/mpp/test_mpp_sendrecv.F90 | 2 - test_fms/mpp/test_mpp_update_domains_ad.F90 | 2 - test_fms/mpp/test_mpp_update_domains_int.F90 | 1 - test_fms/mpp/test_mpp_update_domains_main.F90 | 2 - .../mpp/test_update_domains_performance.F90 | 2 - test_fms/mpp_io/test_io_R4_R8.F90 | 3 +- test_fms/mpp_io/test_io_mosaic_R4_R8.F90 | 3 +- test_fms/mpp_io/test_mpp_io.F90 | 4 +- test_fms/parser/parser_demo.F90 | 1 - time_interp/time_interp_external.F90 | 3 +- 26 files changed, 122 insertions(+), 76 deletions(-) diff --git a/axis_utils/axis_utils.F90 b/axis_utils/axis_utils.F90 index 3947e370e3..4d746be7f3 100644 --- a/axis_utils/axis_utils.F90 +++ b/axis_utils/axis_utils.F90 @@ -27,6 +27,7 @@ !> @addtogroup axis_utils_mod !> @{ module axis_utils_mod +#ifdef use_deprecated_io use netcdf use mpp_io_mod, only: axistype, atttype, default_axis, default_att, & mpp_get_atts, mpp_get_axis_data, mpp_modify_meta, & @@ -787,7 +788,7 @@ subroutine find_index(grid1, xs, xe, ks, ke) if(ke == 0 ) call mpp_error(FATAL,' xe locate outside of grid1') end subroutine find_index - +#endif end module axis_utils_mod !> @} ! close documentation grouping diff --git a/coupler/coupler_types.F90 b/coupler/coupler_types.F90 index 82d0c97082..d059fe8a27 100644 --- a/coupler/coupler_types.F90 +++ b/coupler/coupler_types.F90 @@ -31,8 +31,10 @@ module coupler_types_mod use fms2_io_mod, only: get_variable_attribute, get_dimension_size, get_dimension_names use fms2_io_mod, only: register_variable_attribute, get_variable_dimension_names use fms2_io_mod, only: get_variable_num_dimensions +#ifdef use_deprecated_io use fms_io_mod, only: restart_file_type, fms_io_register_restart_field=>register_restart_field use fms_io_mod, only: query_initialized, restore_state +#endif use time_manager_mod, only: time_type use diag_manager_mod, only: register_diag_field, send_data use data_override_mod, only: data_override @@ -95,8 +97,10 @@ module coupler_types_mod integer :: atm_tr_index = 0 !< atm_tr_index character(len=128) :: ice_restart_file = ' ' !< ice_restart_file character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file +#ifdef use_deprecated_io type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type !! that is used for this field. +#endif type(FmsNetcdfDomainFile_t), pointer :: fms2_io_rest_type => NULL() !< A pointer to the restart_file_type !! That is used for this field logical :: use_atm_pressure !< use_atm_pressure @@ -149,8 +153,10 @@ module coupler_types_mod integer :: atm_tr_index = 0 !< atm_tr_index character(len=128) :: ice_restart_file = ' ' !< ice_restart_file character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file +#ifdef use_deprecated_io type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type !! that is used for this field. +#endif type(FmsNetcdfDomainFile_t), pointer :: fms2_io_rest_type => NULL() !< A pointer to the restart_file_type !! That is used for this field logical :: use_atm_pressure !< use_atm_pressure @@ -319,9 +325,10 @@ module coupler_types_mod !! in restart files. !> @ingroup coupler_types_mod interface coupler_type_register_restarts +#ifdef use_deprecated_io module procedure mpp_io_CT_register_restarts_2d, mpp_io_CT_register_restarts_3d module procedure mpp_io_CT_register_restarts_to_file_2d, mpp_io_CT_register_restarts_to_file_3d - +#endif module procedure CT_register_restarts_2d, CT_register_restarts_3d end interface coupler_type_register_restarts @@ -329,7 +336,9 @@ module coupler_types_mod !! been saved in restart files. !> @ingroup coupler_types_mod interface coupler_type_restore_state +#ifdef use_deprecated_io module procedure mpp_io_CT_restore_state_2d, mpp_io_CT_restore_state_3d +#endif module procedure CT_restore_state_2d, CT_restore_state_3d end interface coupler_type_restore_state @@ -3743,6 +3752,7 @@ end subroutine CT_destructor_3d !! !! This subroutine registers the fields in a coupler_2d_bc_type to be saved in restart files !! specified in the field table. +#ifdef use_deprecated_io subroutine mpp_io_CT_register_restarts_2d(var, bc_rest_files, num_rest_files, mpp_domain, ocean_restart) type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts type(restart_file_type), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files @@ -4056,7 +4066,7 @@ subroutine mpp_io_CT_restore_state_3d(var, directory, all_or_nothing, all_requir endif endif end subroutine mpp_io_CT_restore_state_3d - +#endif end module coupler_types_mod !> @} ! close documentation grouping diff --git a/coupler/ensemble_manager.F90 b/coupler/ensemble_manager.F90 index 944e859455..257dfed54e 100644 --- a/coupler/ensemble_manager.F90 +++ b/coupler/ensemble_manager.F90 @@ -30,7 +30,9 @@ module ensemble_manager_mod use mpp_mod, only : mpp_pe, mpp_declare_pelist use mpp_mod, only : input_nml_file use fms2_io_mod, only : fms2_io_set_filename_appendix=>set_filename_appendix +#ifdef use_deprecated_io use fms_io_mod, only : fms_io_set_filename_appendix=>set_filename_appendix +#endif IMPLICIT NONE @@ -408,7 +410,9 @@ subroutine ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, !< Both calls are needed for cases where both fms2io/fmsio are used call fms2_io_set_filename_appendix(trim(text)) +#ifdef use_deprecated_io call fms_io_set_filename_appendix(trim(text)) +#endif endif end subroutine ensemble_pelist_setup diff --git a/fms/fms.F90 b/fms/fms.F90 index 7067b86aee..3ec8052148 100644 --- a/fms/fms.F90 +++ b/fms/fms.F90 @@ -143,7 +143,8 @@ module fms_mod mpp_get_compute_domain, mpp_get_global_domain, & mpp_get_data_domain -use mpp_io_mod, only: mpp_io_init, mpp_open, mpp_close, & +#ifdef use_deprecated_io +use mpp_io_mod, only: mpp_io_init, mpp_open, mpp_close, & MPP_ASCII, MPP_NATIVE, MPP_IEEE32, MPP_NETCDF, & MPP_RDONLY, MPP_WRONLY, MPP_APPEND, MPP_OVERWR, & MPP_SEQUENTIAL, MPP_DIRECT, & @@ -158,6 +159,7 @@ module fms_mod open_file, open_direct_file, get_mosaic_tile_grid, & get_mosaic_tile_file, get_global_att_value, file_exist, field_exist, & set_domain, nullify_domain +#endif use fms2_io_mod, only: fms2_io_init use memutils_mod, only: print_memuse_stats, memutils_init use grid2_mod, only: grid_init, grid_end @@ -173,6 +175,7 @@ module fms_mod public :: fms_init, fms_end ! routines for opening/closing specific types of file +#ifdef use_deprecated_io public :: open_namelist_file, open_restart_file, & open_ieee32_file, close_file, & open_file, open_direct_file @@ -186,15 +189,19 @@ module fms_mod public :: get_mosaic_tile_grid, get_mosaic_tile_file ! miscellaneous i/o routines -public :: file_exist, check_nml_error, field_exist, & - error_mesg, fms_error_handler +public :: file_exist, field_exist +#endif +public ::check_nml_error, error_mesg, fms_error_handler + ! version logging routine (originally from fms_io) public :: write_version_number ! miscellaneous utilities (non i/o) public :: lowercase, uppercase, & - string_array_index, monotonic_array, & - set_domain, nullify_domain + string_array_index, monotonic_array +#ifdef use_deprecated_io +public :: set_domain, nullify_domain +#endif ! public mpp interfaces public :: mpp_error, NOTE, WARNING, FATAL, & @@ -213,7 +220,9 @@ module fms_mod public :: string ! public mpp-io interfaces +#ifdef use_deprecated_io public :: do_cf_compliance +#endif interface monotonic_array module procedure :: monotonic_array_r4, monotonic_array_r8 @@ -323,7 +332,9 @@ subroutine fms_init (localcomm, alt_input_nml_path) !--- needed to output the version number of constants_mod to the logfile --- use constants_mod, only: constants_version=>version !pjp: PI not computed +#ifdef use_deprecated_io use fms_io_mod, only: fms_io_version +#endif integer, intent(in), optional :: localcomm character(len=*), intent(in), optional :: alt_input_nml_path @@ -348,10 +359,14 @@ subroutine fms_init (localcomm, alt_input_nml_path) endif endif call mpp_domains_init() +#ifdef use_deprecated_io call fms_io_init() +#endif !! write_version_number is inaccesible from fms_io_mod so write it from here if not written if(.not.fms_io_initialized) then +#ifdef use_deprecated_io call write_version_number("FMS_IO_MOD", fms_io_version) +#endif fms_io_initialized = .true. endif call fms2_io_init() @@ -446,7 +461,9 @@ subroutine fms_end ( ) if (.not.module_is_initialized) return ! return silently ! call fms_io_exit ! now called from coupler_end call grid_end +#ifdef use_deprecated_io call mpp_io_exit +#endif call mpp_domains_exit call mpp_exit module_is_initialized =.FALSE. diff --git a/fms/fms_io.F90 b/fms/fms_io.F90 index ce1069948e..06ca5a0627 100644 --- a/fms/fms_io.F90 +++ b/fms/fms_io.F90 @@ -86,6 +86,7 @@ !> @addtogroup fms_io_mod !> @{ module fms_io_mod +#ifdef use_deprecated_io #include @@ -8706,7 +8707,7 @@ end function get_great_circle_algorithm #include #include !---------- - +#endif end module fms_io_mod !> @} ! close documentation grouping diff --git a/mosaic/grid.F90 b/mosaic/grid.F90 index 6c94e1b733..84fd0d8cb0 100644 --- a/mosaic/grid.F90 +++ b/mosaic/grid.F90 @@ -21,6 +21,7 @@ !> @brief Routines for grid calculations module grid_mod +#ifdef use_deprecated_io use mpp_mod, only : mpp_root_pe, uppercase, lowercase, FATAL, NOTE, mpp_error use constants_mod, only : PI, radius @@ -1030,7 +1031,7 @@ subroutine define_cube_mosaic ( component, domain, layout, halo, maskmap ) deallocate(is2,ie2,js2,je2) end subroutine define_cube_mosaic - +#endif end module grid_mod !> @} ! close documentation grouping diff --git a/mosaic/mosaic.F90 b/mosaic/mosaic.F90 index e8558fc8fa..eb8a698de4 100644 --- a/mosaic/mosaic.F90 +++ b/mosaic/mosaic.F90 @@ -28,6 +28,7 @@ !> @addtogroup mosaic_mod !> @{ module mosaic_mod +#ifdef use_deprecated_io use mpp_mod, only : mpp_error, FATAL, mpp_pe, mpp_root_pe use mpp_io_mod, only : MPP_MULTI @@ -488,7 +489,7 @@ function parse_string(string, set, value) return end function parse_string - +#endif end module mosaic_mod diff --git a/mpp/mpp_io.F90 b/mpp/mpp_io.F90 index 4a8fc1bb0b..297f2df41e 100644 --- a/mpp/mpp_io.F90 +++ b/mpp/mpp_io.F90 @@ -309,6 +309,7 @@ !> @{ module mpp_io_mod +#ifdef use_deprecated_io #define _MAX_FILE_UNITS 1024 @@ -1203,7 +1204,7 @@ module mpp_io_mod #include #include !---------- - +#endif end module mpp_io_mod !> @} ! close documentation grouping diff --git a/test_fms/data_override/test_data_override.F90 b/test_fms/data_override/test_data_override.F90 index eee88eddca..36f22b3143 100644 --- a/test_fms/data_override/test_data_override.F90 +++ b/test_fms/data_override/test_data_override.F90 @@ -46,12 +46,15 @@ program test use mpp_mod, only: input_nml_file, stdout, mpp_chksum use mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_compute_domain, & & mpp_define_layout - use fms_mod, only: fms_init, fms_end, mpp_npes, file_exist, check_nml_error - use fms_mod, only: error_mesg, FATAL, file_exist, field_exist, field_size + use fms_mod, only: fms_init, fms_end, mpp_npes, check_nml_error, error_mesg, FATAL +#ifdef use_deprecated_io + use fms_mod, only: field_exist, field_size, file_exist +#endif use fms_affinity_mod, only: fms_affinity_set - use fms_io_mod, only: read_data, fms_io_exit + use fms2_io_mod, only: read_data, variable_exists, get_variable_size, FmsNetcdfFile_t, open_file use constants_mod, only: constants_init, pi - use time_manager_mod, only: time_type, set_calendar_type, set_date, NOLEAP, JULIAN, operator(+), set_time, print_time + use time_manager_mod, only: time_type, set_calendar_type, set_date, NOLEAP, JULIAN, operator(+), & + set_time, print_time use diag_manager_mod, only: diag_manager_init, diag_manager_end, register_static_field, register_diag_field use diag_manager_mod, only: send_data, diag_axis_init use data_override_mod, only: data_override_init, data_override, data_override_UG @@ -98,7 +101,7 @@ program test integer, allocatable :: is_win(:), js_win(:) integer :: nx_dom, ny_dom, nx_win, ny_win type(domain2d) :: Domain - integer :: nlon, nlat, siz(4) + integer :: nlon, nlat, siz(2) real, allocatable, dimension(:) :: x, y real, allocatable, dimension(:,:) :: lon, lat real, allocatable, dimension(:,:) :: sst, ice @@ -117,6 +120,9 @@ program test integer :: nwindows integer :: nx_cubic=90, ny_cubic=90, nx_latlon=90, ny_latlon=90 integer :: test_num=1 !* 1 for unstruct cubic grid, 2 for unstruct latlon-grid + + type(FmsNetcdfFile_t) :: fileobj_grid, fileobj_solo_mosaic, fileobj_tile + namelist / test_data_override_nml / layout, window, nthreads, nx_cubic, ny_cubic, nx_latlon, ny_latlon, test_num call fms_init @@ -131,23 +137,27 @@ program test read (input_nml_file, test_data_override_nml, iostat=io) ierr = check_nml_error(io, 'test_data_override_nml') - if(field_exist(grid_file, "x_T" ) ) then - call field_size(grid_file, 'x_T', siz) + if (.not. open_file(fileobj_grid, grid_file, "read")) call error_mesg('test_data_override', & + 'The grid_file does not exist', FATAL) + if(variable_exists(fileobj_grid, "x_T" ) ) then + call get_variable_size(fileobj_grid, 'x_T', siz) nlon = siz(1) nlat = siz(2) - else if(field_exist(grid_file, "geolon_t" ) ) then - call field_size(grid_file, 'geolon_t', siz) + else if(variable_exists(fileobj_grid, "geolon_t" ) ) then + call get_variable_size(fileobj_grid, 'geolon_t', siz) nlon = siz(1) nlat = siz(2) - else if (field_exist(grid_file, "ocn_mosaic_file" )) then - call read_data(grid_file, 'ocn_mosaic_file', solo_mosaic_file) + else if (variable_exists(fileobj_grid, "ocn_mosaic_file" )) then + call read_data(fileobj_grid, 'ocn_mosaic_file', solo_mosaic_file) solo_mosaic_file = 'INPUT/'//trim(solo_mosaic_file) - call field_size(solo_mosaic_file, 'gridfiles', siz) - if( siz(2) .NE. 1) & - call error_mesg('test_data_override', 'only support single tile mosaic, contact developer', FATAL) - call read_data(solo_mosaic_file, 'gridfiles', tile_file) + if (.not. open_file(fileobj_solo_mosaic, solo_mosaic_file, "read")) call error_mesg('test_data_override', & + 'The solo_mosaic fike does not exist', FATAL) + call get_variable_size(fileobj_solo_mosaic, 'gridfiles', siz) + call read_data(fileobj_solo_mosaic, 'gridfiles', tile_file) tile_file = 'INPUT/'//trim(tile_file) - call field_size(tile_file, 'area', siz) + if(.not. open_file(fileobj_tile, tile_file, "read")) call error_mesg('test_data_override', & + 'The tile_file does not exist', FATAL) + call get_variable_size(fileobj_tile, 'area', siz) if(mod(siz(1),2) .NE. 0 .OR. mod(siz(2),2) .NE. 0 ) call error_mesg('test_data_override', & "test_data_override: supergrid size can not be divided by 2", FATAL) nlon = siz(1)/2 @@ -306,41 +316,43 @@ program test !------------------------------------------------------------------------------------------------------- call diag_manager_end(Time) - call fms_io_exit call fms_end contains -!====================================================================================================================== +!==================================================================================================================== subroutine get_grid real, allocatable, dimension(:,:,:) :: lon_vert_glo, lat_vert_glo real, allocatable, dimension(:,:) :: lon_global, lat_global - integer, dimension(4) :: siz + integer, dimension(2) :: siz character(len=128) :: message + type(FmsNetcdfFile_t) :: fileobj_grid, fileobj_solo_mosaic, fileobj_tile - if(field_exist(grid_file, 'x_T')) then - call field_size(grid_file, 'x_T', siz) + if (.not. open_file(fileobj_grid, grid_file, "read")) call error_mesg('test_data_override', & + 'The grid_file does not exist', FATAL) + if(variable_exists(fileobj_grid, 'x_T')) then + call get_variable_size(fileobj_grid, 'x_T', siz) if(siz(1) /= nlon .or. siz(2) /= nlat) then write(message,'(a,2i4)') 'x_T is wrong shape. shape(x_T)=',siz(1:2) call error_mesg('test_data_override', trim(message), FATAL) endif allocate(lon_vert_glo(nlon,nlat,4), lat_vert_glo(nlon,nlat,4) ) allocate(lon_global (nlon,nlat ), lat_global (nlon,nlat ) ) - call read_data(trim(grid_file), 'x_vert_T', lon_vert_glo, no_domain=.true.) - call read_data(trim(grid_file), 'y_vert_T', lat_vert_glo, no_domain=.true.) + call read_data(fileobj_grid, 'x_vert_T', lon_vert_glo) + call read_data(fileobj_grid, 'y_vert_T', lat_vert_glo) lon_global(:,:) = (lon_vert_glo(:,:,1) + lon_vert_glo(:,:,2) + lon_vert_glo(:,:,3) + lon_vert_glo(:,:,4))*0.25 lat_global(:,:) = (lat_vert_glo(:,:,1) + lat_vert_glo(:,:,2) + lat_vert_glo(:,:,3) + lat_vert_glo(:,:,4))*0.25 - else if(field_exist(grid_file, "geolon_t" ) ) then - call field_size(grid_file, 'geolon_vert_t', siz) + else if(variable_exists(fileobj_grid, "geolon_t" ) ) then + call get_variable_size(fileobj_grid, 'geolon_vert_t', siz) if(siz(1) /= nlon+1 .or. siz(2) /= nlat+1) then write(message,'(a,2i4)') 'geolon_vert_t is wrong shape. shape(geolon_vert_t)=',siz(1:2) call error_mesg('test_data_override', trim(message), FATAL) endif allocate(lon_vert_glo(nlon+1,nlat+1,1), lat_vert_glo(nlon+1,nlat+1,1)) allocate(lon_global (nlon, nlat ), lat_global (nlon, nlat )) - call read_data(trim(grid_file), 'geolon_vert_t', lon_vert_glo, no_domain=.true.) - call read_data(trim(grid_file), 'geolat_vert_t', lat_vert_glo, no_domain=.true.) + call read_data(fileobj_grid, 'geolon_vert_t', lon_vert_glo) + call read_data(fileobj_grid, 'geolat_vert_t', lat_vert_glo) do i = 1, nlon do j = 1, nlat @@ -350,16 +362,18 @@ subroutine get_grid lat_vert_glo(i+1,j+1,1) + lat_vert_glo(i,j+1,1))*0.25 enddo enddo - else if( field_exist(grid_file, "ocn_mosaic_file") ) then ! reading from mosaic file - call field_size(tile_file, 'area', siz) + else if( variable_exists(fileobj_grid, "ocn_mosaic_file") ) then ! reading from mosaic file + if(.not. open_file(fileobj_tile, tile_file, "read")) call error_mesg('test_data_override', & + 'The tile_file does not exist', FATAL) + call get_variable_size(fileobj_tile, 'area', siz) if(siz(1) /= nlon*2 .or. siz(2) /= nlat*2) then write(message,'(a,2i4)') 'area is wrong shape. shape(area)=',siz(1:2) call error_mesg('test_data_override', trim(message), FATAL) endif allocate(lon_vert_glo(siz(1)+1,siz(2)+1,1), lat_vert_glo(siz(1)+1,siz(2)+1,1)) allocate(lon_global (nlon, nlat ), lat_global (nlon, nlat )) - call read_data( tile_file, 'x', lon_vert_glo, no_domain=.true.) - call read_data( tile_file, 'y', lat_vert_glo, no_domain=.true.) + call read_data(fileobj_tile, 'x', lon_vert_glo) + call read_data(fileobj_tile, 'y', lat_vert_glo) do j = 1, nlat do i = 1, nlon lon_global(i,j) = lon_vert_glo(i*2,j*2,1) @@ -824,5 +838,5 @@ subroutine define_cubic_mosaic(type, domain, ni, nj, global_indices, layout, pe_ end subroutine define_cubic_mosaic -!====================================================================================================================== +!==================================================================================================================== end program test diff --git a/test_fms/diag_manager/test_diag_manager.F90 b/test_fms/diag_manager/test_diag_manager.F90 index b943cb38af..8c6ef4745c 100644 --- a/test_fms/diag_manager/test_diag_manager.F90 +++ b/test_fms/diag_manager/test_diag_manager.F90 @@ -223,15 +223,16 @@ PROGRAM test ! Because of this, the calls to all of those routines differ depending on the test. USE mpp_mod, ONLY: mpp_pe, mpp_root_pe, mpp_debug, mpp_set_stack_size - USE mpp_io_mod, ONLY: mpp_io_init USE mpp_domains_mod, ONLY: domain2d, mpp_define_domains, mpp_get_compute_domain USE mpp_domains_mod, ONLY: mpp_define_io_domain, mpp_define_layout USE mpp_domains_mod, ONLY: mpp_domains_init, mpp_domains_set_stack_size - USE fms_mod, ONLY: fms_init, fms_end, mpp_npes, file_exist, check_nml_error, open_file + USE fms_mod, ONLY: fms_init, fms_end, mpp_npes, check_nml_error USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdlog, stdout USE mpp_mod, ONLY: input_nml_file - USE fms_io_mod, ONLY: fms_io_init +#ifdef use_deprecated_io + USE fms_io_mod, ONLY: fms_io_init, file_exist, open_file USE fms_io_mod, ONLY: fms_io_exit, set_filename_appendix +#endif USE constants_mod, ONLY: constants_init, PI, RAD_TO_DEG USE time_manager_mod, ONLY: time_type, set_calendar_type, set_date, decrement_date, OPERATOR(+), set_time @@ -374,14 +375,13 @@ PROGRAM test endif !Initialize the mpp_io module. +#ifdef use_deprecated_io if (debug) then call mpp_io_init(MPP_DEBUG) else call mpp_io_init() endif - - !Initialize the fms_io module. - call fms_io_init() +#endif !Set the mpp and mpp_domains stack sizes. call mpp_set_stack_size(stackmax) @@ -546,7 +546,9 @@ PROGRAM test IF ( test_number == 16 ) THEN ! Test 16 tests the filename appendix +#ifdef use_deprecated_io CALL set_filename_appendix('g01') +#endif END IF id_dat1 = register_diag_field('test_diag_manager_mod', 'dat1', (/id_lon1,id_lat1,id_pfull/), Time, 'sample data','K') IF ( test_number == 18 ) THEN @@ -1002,7 +1004,6 @@ PROGRAM test CALL diag_manager_end(Time) END SELECT ! End of case handling opened for test 12. - CALL fms_io_exit CALL fms_end CONTAINS diff --git a/test_fms/fms/test_fms.F90 b/test_fms/fms/test_fms.F90 index faffd998eb..0827e3c91c 100644 --- a/test_fms/fms/test_fms.F90 +++ b/test_fms/fms/test_fms.F90 @@ -79,6 +79,7 @@ program test_fms contains + #include "test_fms_r4.fh" #include "test_fms_r8.fh" diff --git a/test_fms/interpolator/test_interpolator.F90 b/test_fms/interpolator/test_interpolator.F90 index 367ceefa4a..6a5c0b5f02 100644 --- a/test_fms/interpolator/test_interpolator.F90 +++ b/test_fms/interpolator/test_interpolator.F90 @@ -43,6 +43,7 @@ program test_interpolator use interpolator_mod use constants_mod use time_interp_mod, only : time_interp_init +use fms2_io_mod, only : open_file, FmsNetcdfFile_t implicit none integer, parameter :: nsteps_per_day = 8, ndays = 16 @@ -255,8 +256,12 @@ subroutine sulfate_init(aerosol,lonb, latb, names, data_out_of_bounds, vert_inte integer, intent(in) :: data_out_of_bounds(:) integer, intent(in), optional :: vert_interp(:) character(len=*), intent(out),optional :: units(:) +character(len=128) :: filename_aerosol -if (.not. file_exist("INPUT/aerosol.climatology.nc") ) return +type(FmsNetcdfFile_t) :: fileobj_aerosol + +filename_aerosol = "INPUT/aerosol.climatology.nc" +if (.not. open_file(fileobj_aerosol, filename_aerosol, "read") ) return call interpolator_init( aerosol, "aerosol.climatology.nc", lonb, latb, & data_names=names, data_out_of_bounds=data_out_of_bounds, & vert_interp=vert_interp, clim_units=units ) @@ -287,8 +292,12 @@ subroutine ozone_init( o3, lonb, latb, axes, model_time, data_out_of_bounds, ver type(interpolate_type),intent(inout) :: o3 integer, intent(in) :: data_out_of_bounds(:) integer, intent(in), optional :: vert_interp(:) +character(len=128) :: filename_o3 + +type(FmsNetcdfFile_t) :: fileobj_o3 -if (.not. file_exist("INPUT/o3.climatology.nc") ) return +filename_o3 = "INPUT/o3.climatology.nc" +if (.not. open_file(fileobj_o3, filename_o3, "read") ) return call interpolator_init( o3, "o3.climatology.nc", lonb, latb, & data_out_of_bounds=data_out_of_bounds, vert_interp=vert_interp ) diff --git a/test_fms/mpp/test_global_arrays.F90 b/test_fms/mpp/test_global_arrays.F90 index edb3605df6..ce2b125cb4 100644 --- a/test_fms/mpp/test_global_arrays.F90 +++ b/test_fms/mpp/test_global_arrays.F90 @@ -28,7 +28,6 @@ program test_global_arrays use mpp_mod, only: mpp_set_stack_size, mpp_sync, mpp_sync_self use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_send, mpp_recv, WARNING use mpp_mod, only: mpp_init_test_init_true_only, mpp_set_root_pe - use mpp_io_mod, only: mpp_io_init use mpp_domains_mod, only: mpp_domains_init, mpp_define_domains, domain2d use mpp_domains_mod, only: mpp_define_layout, mpp_domains_set_stack_size use mpp_domains_mod, only: mpp_get_global_domain, mpp_global_max @@ -58,7 +57,6 @@ program test_global_arrays real(r8_kind), parameter :: tol4 = 1e-4, tol8 = 1e-6!> tolerance for real comparisons call mpp_init(mpp_init_test_init_true_only) - call mpp_io_init() call mpp_domains_init() call mpp_set_stack_size(3145746) call mpp_domains_set_stack_size(3145746) diff --git a/test_fms/mpp/test_mpp.F90 b/test_fms/mpp/test_mpp.F90 index 6e0e609f92..034ff3a850 100644 --- a/test_fms/mpp/test_mpp.F90 +++ b/test_fms/mpp/test_mpp.F90 @@ -27,7 +27,6 @@ program test !test various aspects of mpp_mod use mpp_mod, only : mpp_declare_pelist, mpp_set_current_pelist, mpp_set_stack_size use mpp_mod, only : mpp_broadcast, mpp_transmit, mpp_sum, mpp_max, mpp_chksum, ALL_PES use mpp_mod, only : mpp_gather, mpp_error, FATAL, mpp_sync_self - use mpp_io_mod, only: mpp_io_init, mpp_flush use platform_mod implicit none @@ -42,7 +41,6 @@ program test !test various aspects of mpp_mod real :: dt call mpp_init() - call mpp_io_init() call mpp_set_stack_size(3145746) pe = mpp_pe() npes = mpp_npes() diff --git a/test_fms/mpp/test_mpp_gatscat.F90 b/test_fms/mpp/test_mpp_gatscat.F90 index 47ff6cf81c..d5709b91c7 100644 --- a/test_fms/mpp/test_mpp_gatscat.F90 +++ b/test_fms/mpp/test_mpp_gatscat.F90 @@ -34,7 +34,6 @@ program test_mpp_gatscat use mpp_mod, only : mpp_sync use mpp_mod, only : mpp_declare_pelist, mpp_set_current_pelist, mpp_set_stack_size use mpp_mod, only : mpp_gather, mpp_scatter, mpp_error, FATAL - use mpp_io_mod, only: mpp_io_init, mpp_flush use mpp_mod, only : mpp_init_test_requests_allocated use platform_mod @@ -59,7 +58,6 @@ program test_mpp_gatscat integer :: ierr call mpp_init(mpp_init_test_requests_allocated) - call mpp_io_init() call mpp_set_stack_size(3145746) pe = mpp_pe() npes = mpp_npes() diff --git a/test_fms/mpp/test_mpp_global_sum_ad.F90 b/test_fms/mpp/test_mpp_global_sum_ad.F90 index 696d732d40..c50f9a060e 100644 --- a/test_fms/mpp/test_mpp_global_sum_ad.F90 +++ b/test_fms/mpp/test_mpp_global_sum_ad.F90 @@ -38,7 +38,6 @@ program test_mpp_global_sum_ad use mpp_domains_mod, only : mpp_define_layout, mpp_define_domains use mpp_domains_mod, only : NORTH, EAST, CORNER, CENTER use mpp_domains_mod, only : mpp_global_sum_ad - use mpp_io_mod, only : mpp_io_init use platform_mod @@ -51,7 +50,6 @@ program test_mpp_global_sum_ad call mpp_init(test_level=mpp_init_test_requests_allocated) call mpp_domains_init(MPP_DEBUG) - call mpp_io_init() call mpp_domains_set_stack_size(stackmax) pe = mpp_pe() diff --git a/test_fms/mpp/test_mpp_sendrecv.F90 b/test_fms/mpp/test_mpp_sendrecv.F90 index d6c315994e..5f82683e14 100644 --- a/test_fms/mpp/test_mpp_sendrecv.F90 +++ b/test_fms/mpp/test_mpp_sendrecv.F90 @@ -34,7 +34,6 @@ program test_mpp_sendrecv use mpp_mod, only : mpp_sync use mpp_mod, only : mpp_declare_pelist, mpp_set_current_pelist, mpp_set_stack_size use mpp_mod, only : mpp_send, mpp_recv, mpp_error, FATAL - use mpp_io_mod, only: mpp_io_init, mpp_flush use mpp_mod, only : mpp_init_test_requests_allocated use platform_mod @@ -59,7 +58,6 @@ program test_mpp_sendrecv integer :: ierr call mpp_init(mpp_init_test_requests_allocated) - call mpp_io_init() call mpp_set_stack_size(3145746) pe = mpp_pe() npes = mpp_npes() diff --git a/test_fms/mpp/test_mpp_update_domains_ad.F90 b/test_fms/mpp/test_mpp_update_domains_ad.F90 index 07739e8e65..aeaf253528 100644 --- a/test_fms/mpp/test_mpp_update_domains_ad.F90 +++ b/test_fms/mpp/test_mpp_update_domains_ad.F90 @@ -33,7 +33,6 @@ program test_mpp_update_domains_ad use mpp_domains_mod, only : mpp_update_domains, mpp_update_domains_ad, mpp_check_field use mpp_domains_mod, only : mpp_define_layout, mpp_define_domains, mpp_modify_domain use mpp_domains_mod, only : mpp_get_global_domain - use mpp_io_mod, only : mpp_io_init use platform_mod, only : r4_kind, r8_kind implicit none @@ -48,7 +47,6 @@ program test_mpp_update_domains_ad !> Initialize mpp and mpp IO modules call mpp_init(test_level=mpp_init_test_requests_allocated) call mpp_domains_init(MPP_DOMAIN_TIME) - call mpp_io_init() call mpp_domains_set_stack_size(stackmax) pe = mpp_pe() npes = mpp_npes() diff --git a/test_fms/mpp/test_mpp_update_domains_int.F90 b/test_fms/mpp/test_mpp_update_domains_int.F90 index 611894af3f..11e3e80aa6 100644 --- a/test_fms/mpp/test_mpp_update_domains_int.F90 +++ b/test_fms/mpp/test_mpp_update_domains_int.F90 @@ -47,7 +47,6 @@ module test_mpp_update_domains_int use mpp_domains_mod, only : SOUTH, SOUTH_WEST, WEST, NORTH_WEST, mpp_define_mosaic_pelist use mpp_domains_mod, only : mpp_get_global_domain, ZERO, NINETY, MINUS_NINETY use mpp_domains_mod, only : mpp_deallocate_domain - use mpp_io_mod, only: mpp_io_init use platform_mod, only: i4_kind, i8_kind implicit none diff --git a/test_fms/mpp/test_mpp_update_domains_main.F90 b/test_fms/mpp/test_mpp_update_domains_main.F90 index 0eb5223df1..c1c094fbc9 100644 --- a/test_fms/mpp/test_mpp_update_domains_main.F90 +++ b/test_fms/mpp/test_mpp_update_domains_main.F90 @@ -31,7 +31,6 @@ program test_mpp_update_domains_main use mpp_mod, only : mpp_init_test_requests_allocated use mpp_domains_mod, only : MPP_DOMAIN_TIME, mpp_domains_set_stack_size use mpp_domains_mod, only : mpp_domains_init, mpp_domains_exit - use mpp_io_mod, only: mpp_io_init use platform_mod implicit none @@ -41,7 +40,6 @@ program test_mpp_update_domains_main !> Initialize mpp and mpp IO modules call mpp_init(test_level=mpp_init_test_requests_allocated) call mpp_domains_init(MPP_DOMAIN_TIME) - call mpp_io_init() call mpp_domains_set_stack_size(stackmax) !> run the tests !> run the tests diff --git a/test_fms/mpp/test_update_domains_performance.F90 b/test_fms/mpp/test_update_domains_performance.F90 index 32bfcdd121..a0a81443e2 100644 --- a/test_fms/mpp/test_update_domains_performance.F90 +++ b/test_fms/mpp/test_update_domains_performance.F90 @@ -38,7 +38,6 @@ program test_update_domains_performance use mpp_domains_mod, only : NORTH, SOUTH, WEST, EAST, CENTER use mpp_domains_mod, only : mpp_get_global_domain, ZERO use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains - use mpp_io_mod, only: mpp_io_init use platform_mod implicit none @@ -65,7 +64,6 @@ program test_update_domains_performance logical :: mix_2D_3D = .false. !> Initialize mpp and mpp IO modules call mpp_init(test_level=mpp_init_test_requests_allocated) - call mpp_io_init() call mpp_domains_init(MPP_DOMAIN_TIME) call mpp_domains_set_stack_size(stackmax) pe = mpp_pe() diff --git a/test_fms/mpp_io/test_io_R4_R8.F90 b/test_fms/mpp_io/test_io_R4_R8.F90 index 49c17e0b4d..37282cf970 100644 --- a/test_fms/mpp_io/test_io_R4_R8.F90 +++ b/test_fms/mpp_io/test_io_R4_R8.F90 @@ -22,6 +22,7 @@ !> @description Tests mpp_write and mpp_read for reads/writes !> with mixed precision reals on non-mosaic files program test_io_R4_R8 +#ifdef use_deprecated_io use platform_mod, only : r4_kind, r8_kind, i8_kind use mpp_mod, only : mpp_init, mpp_pe, mpp_npes, mpp_root_pe, mpp_error, mpp_sync_self @@ -513,5 +514,5 @@ subroutine test_netcdf_io_R8(type) deallocate( rdata8, gdata8, data8) end subroutine test_netcdf_io_R8 - +#endif end program test_io_R4_R8 diff --git a/test_fms/mpp_io/test_io_mosaic_R4_R8.F90 b/test_fms/mpp_io/test_io_mosaic_R4_R8.F90 index 8360bd2523..b76dac7f77 100644 --- a/test_fms/mpp_io/test_io_mosaic_R4_R8.F90 +++ b/test_fms/mpp_io/test_io_mosaic_R4_R8.F90 @@ -23,6 +23,7 @@ !> @description Performs reads and writes on mosaic files using mpp_write !> and mpp_read using 32 and 64 bit reals program test_io_mosaic_R4_R8 +#ifdef use_deprecated_io use platform_mod use mpp_mod, only : mpp_init, mpp_pe, mpp_npes, mpp_root_pe, mpp_error, mpp_sync_self @@ -413,5 +414,5 @@ subroutine test_netcdf_io_mosaic_R8(type, layout, ntiles_x, ntiles_y, io_layout) call mpp_deallocate_domain(domain) end subroutine test_netcdf_io_mosaic_R8 - +#endif end program test_io_mosaic_R4_R8 diff --git a/test_fms/mpp_io/test_mpp_io.F90 b/test_fms/mpp_io/test_mpp_io.F90 index 907d45600b..46cefef2d7 100644 --- a/test_fms/mpp_io/test_mpp_io.F90 +++ b/test_fms/mpp_io/test_mpp_io.F90 @@ -17,7 +17,7 @@ !* License along with FMS. If not, see . !*********************************************************************** program test - +#ifdef use_deprecated_io use platform_mod, only : i8_kind, r8_kind use mpp_mod, only : mpp_init, mpp_pe, mpp_npes, mpp_root_pe, mpp_error, mpp_sync_self use mpp_mod, only : FATAL, NOTE, mpp_chksum, MPP_DEBUG, mpp_set_stack_size, MPP_CLOCK_SYNC @@ -565,5 +565,5 @@ subroutine test_netcdf_io_mosaic(type, layout, ntiles_x, ntiles_y, io_layout) call mpp_deallocate_domain(domain) end subroutine test_netcdf_io_mosaic - +#endif end program test diff --git a/test_fms/parser/parser_demo.F90 b/test_fms/parser/parser_demo.F90 index 16bc1c81ac..5b4ccfd88e 100644 --- a/test_fms/parser/parser_demo.F90 +++ b/test_fms/parser/parser_demo.F90 @@ -115,5 +115,4 @@ program parser_demo deallocate(file_ids) #endif - end program parser_demo diff --git a/time_interp/time_interp_external.F90 b/time_interp/time_interp_external.F90 index c25f694dea..7c446f4c52 100644 --- a/time_interp/time_interp_external.F90 +++ b/time_interp/time_interp_external.F90 @@ -32,6 +32,7 @@ !> @addtogroup time_interp_external_mod !> @{ module time_interp_external_mod +#ifdef use_deprecated_io #include ! !M.J. Harrison @@ -1417,7 +1418,7 @@ subroutine time_interp_external_exit() end subroutine time_interp_external_exit ! NAME="time_interp_external_exit" - +#endif end module time_interp_external_mod !> @} ! close documentation grouping From cbceb9fe72fe6f67a8c9b75cdc6dd8ce1be1c59a Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Fri, 30 Jun 2023 14:34:15 -0400 Subject: [PATCH 30/51] fix: field exists check for io update (#1193) --- time_interp/time_interp_external2.F90 | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/time_interp/time_interp_external2.F90 b/time_interp/time_interp_external2.F90 index fbe2f9e6f1..7716e17ea4 100644 --- a/time_interp/time_interp_external2.F90 +++ b/time_interp/time_interp_external2.F90 @@ -408,15 +408,6 @@ function init_external_field(file,fieldname,domain,desired_units,& init_external_field = -1 nfields_orig = num_fields - tavg = -1.0 - tstart = tstamp - tend = tstamp - if(variable_att_exists(fileobj, fieldname, 'time_avg_info')) then - if(variable_exists(fileobj, 'average_T1')) call read_data(fileobj, 'average_T1', tstart) - if(variable_exists(fileobj, 'average_T2')) call read_data(fileobj, 'average_T2', tend) - if(variable_exists(fileobj, 'average_DT')) call read_data(fileobj, 'average_DT', tavg) - endif - if (.not. variable_exists(fileobj, fieldname) ) then if (present(ierr)) then ierr = ERR_FIELD_NOT_FOUND @@ -426,6 +417,15 @@ function init_external_field(file,fieldname,domain,desired_units,& endif endif + tavg = -1.0 + tstart = tstamp + tend = tstamp + if(variable_att_exists(fileobj, fieldname, 'time_avg_info')) then + if(variable_exists(fileobj, 'average_T1')) call read_data(fileobj, 'average_T1', tstart) + if(variable_exists(fileobj, 'average_T2')) call read_data(fileobj, 'average_T2', tend) + if(variable_exists(fileobj, 'average_DT')) call read_data(fileobj, 'average_DT', tavg) + endif + num_fields = num_fields + 1 if(num_fields > max_fields) then !--- z1l: For the case of multiple thread, realoc_fields will cause memory leak. From 46e55f2b1bb8fa998ae8f9ae66042ba2dd9092bd Mon Sep 17 00:00:00 2001 From: Miguel R Zuniga <42479054+ngs333@users.noreply.github.com> Date: Fri, 30 Jun 2023 14:48:29 -0400 Subject: [PATCH 31/51] fix: diag_fieldbuff_update module dependency in Makefile.am (#1266) --- diag_manager/Makefile.am | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 37759e838f..13ea77d8b7 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -57,8 +57,9 @@ fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_ fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) -fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ - fms_diag_elem_weight_procs_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) +fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ + fms_diag_outfield_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ + fms_diag_bbox_mod.$(FC_MODEXT) diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ From 8c73bd18dc1d580f2ee524c37cf903ff54d40501 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Fri, 30 Jun 2023 15:17:46 -0400 Subject: [PATCH 32/51] chore: add deprecated io options to build systems and CI (#1063) --- .github/workflows/build_cmake_gnu.yml | 3 ++- .github/workflows/build_ubuntu_gnu.yml | 3 ++- CMakeLists.txt | 5 +++++ configure.ac | 17 ++++++++++++++++- test_fms/mpp_io/Makefile.am | 4 ++++ 5 files changed, 29 insertions(+), 3 deletions(-) diff --git a/.github/workflows/build_cmake_gnu.yml b/.github/workflows/build_cmake_gnu.yml index f649345d8a..d4f7e2a248 100644 --- a/.github/workflows/build_cmake_gnu.yml +++ b/.github/workflows/build_cmake_gnu.yml @@ -9,10 +9,11 @@ jobs: matrix: omp-flags: [ -DOPENMP=on, -DOPENMP=off ] libyaml-flag: [ "", -DWITH_YAML=on ] + io-flag: [ "", -DUSE_DEPRECATED_IO=on ] container: image: noaagfdl/hpc-me.ubuntu-minimal:cmake env: - CMAKE_FLAGS: "${{ matrix.omp-flags }} ${{ matrix.libyaml-flag }} -D64BIT=on" + CMAKE_FLAGS: "${{ matrix.omp-flags }} ${{ matrix.io-flag }} ${{ matrix.libyaml-flag }} -D64BIT=on" steps: - name: Checkout code uses: actions/checkout@v2 diff --git a/.github/workflows/build_ubuntu_gnu.yml b/.github/workflows/build_ubuntu_gnu.yml index f4dc48225f..7c53895b15 100644 --- a/.github/workflows/build_ubuntu_gnu.yml +++ b/.github/workflows/build_ubuntu_gnu.yml @@ -12,11 +12,12 @@ jobs: matrix: conf-flags: [--disable-openmp, --enable-mixed-mode, --disable-setting-flags, --with-mpi=no] input-flag: [--with-yaml, --enable-test-input=/home/unit_tests_input] + io-flag: [ --enable-deprecated-io, --disable-deprecated-io] container: image: noaagfdl/hpc-me.ubuntu-minimal:gnu-input env: TEST_VERBOSE: 1 - DISTCHECK_CONFIGURE_FLAGS: "${{ matrix.conf-flags }} ${{ matrix.input-flag }}" + DISTCHECK_CONFIGURE_FLAGS: "${{ matrix.conf-flags }} ${{ matrix.input-flag }} ${{ matrix.io-flag }}" steps: - name: Checkout code uses: actions/checkout@v2 diff --git a/CMakeLists.txt b/CMakeLists.txt index cc60d914c2..270539cd4d 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -66,6 +66,7 @@ option(ENABLE_QUAD_PRECISION "Enable compiler definition -DENABLE_QUAD_PRECISION option(GFS_PHYS "Enable compiler definition -DGFS_PHYS" OFF) option(LARGEFILE "Enable compiler definition -Duse_LARGEFILE" OFF) option(WITH_YAML "Enable compiler definition -Duse_yaml" OFF) +option(USE_DEPRECATED_IO "Enable compiler definition -Duse_deprecated_io (compile with fms_io/mpp_io)" OFF) if(32BIT) list(APPEND kinds "r4") @@ -246,6 +247,10 @@ if(WITH_YAML) list(APPEND fms_defs use_yaml) endif() +if(USE_DEPRECATED_IO) + list(APPEND fms_defs use_deprecated_io) +endif() + if(INTERNAL_FILE_NML) list(APPEND fms_defs INTERNAL_FILE_NML) endif() diff --git a/configure.ac b/configure.ac index 241e08d079..82588b6c84 100644 --- a/configure.ac +++ b/configure.ac @@ -110,6 +110,13 @@ AS_IF([test ${enable_8byte_int:-no} = yes], [enable_8byte_int=yes], [enable_8byte_int=no]) +AC_ARG_ENABLE([deprecated-io], + [AS_HELP_STRING([--enable-deprecated-io], + [Enables compilation of deprecated mpp_io and fms_io modules in addition to the updated fms2_io modules (default no)])]) +AS_IF([test ${enable_deprecated_io:-no} = yes], + [enable_deprecated_io=yes], + [enable_deprecated_io=no]) + # user enabled testing with input files AC_MSG_CHECKING([whether to enable tests with input files]) AC_ARG_ENABLE([test-input], @@ -203,7 +210,6 @@ AC_MSG_CHECKING([if netCDF was built with HDF5]) AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [[ #include #if !(NC_HAS_NC4) - choke me #endif]])], [nc_has_nc4=yes], [nc_has_nc4=no]) AC_MSG_RESULT([$nc_has_nc4]) if test $nc_has_nc4 = no; then @@ -281,6 +287,15 @@ if test $with_mpi = yes; then AC_DEFINE([use_libMPI], [1], [This is required for the library to build]) fi +# check if compiling old io +if test $enable_deprecated_io = yes; then + #If the test pass, define use_deprecated_io macro and skip it's unit tests + AC_DEFINE([use_deprecated_io], [1], [This is required to use mpp_io and fms_io modules]) + AM_CONDITIONAL([SKIP_DEPRECATED_IO_TESTS], true) +else + AM_CONDITIONAL([SKIP_DEPRECATED_IO_TESTS], false) +fi + # Set any required compile flags. This will not be done if the user wants to # define all their own flags. if test $enable_setting_flags = yes; then diff --git a/test_fms/mpp_io/Makefile.am b/test_fms/mpp_io/Makefile.am index af5ec8d488..2357549cfa 100644 --- a/test_fms/mpp_io/Makefile.am +++ b/test_fms/mpp_io/Makefile.am @@ -38,6 +38,10 @@ test_mpp_io_SOURCES = test_mpp_io.F90 test_io_R4_R8_SOURCES = test_io_R4_R8.F90 test_io_mosaic_R4_R8_SOURCES = test_io_mosaic_R4_R8.F90 +if SKIP_DEPRECATED_IO_TESTS +TESTS_ENVIRONMENT= SKIP_TESTS="test_mpp_io2.1 test_io_R4_R8.1 test_io_mosaic_R4_R8.1" +endif + # Run the test program. TESTS = test_mpp_io2.sh \ test_io_R4_R8.sh \ From dbed2ceb9c9acfd392eb18bd00e758cde31b55df Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Wed, 5 Jul 2023 13:50:17 -0400 Subject: [PATCH 33/51] fix: test errors from io flag (#1271) --- test_fms/diag_manager/test_diag_manager.F90 | 1 + test_fms/interpolator/test_interpolator.F90 | 4 ++++ 2 files changed, 5 insertions(+) diff --git a/test_fms/diag_manager/test_diag_manager.F90 b/test_fms/diag_manager/test_diag_manager.F90 index 8c6ef4745c..dd263d2e3f 100644 --- a/test_fms/diag_manager/test_diag_manager.F90 +++ b/test_fms/diag_manager/test_diag_manager.F90 @@ -232,6 +232,7 @@ PROGRAM test #ifdef use_deprecated_io USE fms_io_mod, ONLY: fms_io_init, file_exist, open_file USE fms_io_mod, ONLY: fms_io_exit, set_filename_appendix + use mpp_io_mod, only: mpp_io_init #endif USE constants_mod, ONLY: constants_init, PI, RAD_TO_DEG diff --git a/test_fms/interpolator/test_interpolator.F90 b/test_fms/interpolator/test_interpolator.F90 index 6a5c0b5f02..4636cde918 100644 --- a/test_fms/interpolator/test_interpolator.F90 +++ b/test_fms/interpolator/test_interpolator.F90 @@ -37,7 +37,11 @@ program test_interpolator use mpp_mod use mpp_domains_mod +#ifdef use_deprecated_io +use fms_mod, old_open_file => open_file +#else use fms_mod +#endif use time_manager_mod use diag_manager_mod use interpolator_mod From 7831d2e036c9f3920b2304677454d2e1e58d6798 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Tue, 11 Jul 2023 09:43:17 -0400 Subject: [PATCH 34/51] CI: update oneapi container version (#1277) --- .github/workflows/intel_pr.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/intel_pr.yml b/.github/workflows/intel_pr.yml index d95519fbf2..62a15361ea 100644 --- a/.github/workflows/intel_pr.yml +++ b/.github/workflows/intel_pr.yml @@ -3,7 +3,7 @@ jobs: intel-autotools: runs-on: ubuntu-latest container: - image: intel/oneapi-hpckit:2022.2-devel-ubuntu20.04 + image: intel/oneapi-hpckit:2023.1.0-devel-ubuntu20.04 env: CC: mpiicc FC: mpiifort @@ -22,7 +22,7 @@ jobs: path: /libs key: ${{ runner.os }}-intel-libs - name: Install packages for building - run: apt update && apt install -y autoconf libtool automake zlibc zlib1g-dev + run: apt-get update && apt-get install -y autoconf libtool automake zlibc zlib1g-dev - if: steps.cache.outputs.cache-hit != 'true' name: Build netcdf run: | @@ -50,4 +50,4 @@ jobs: - name: Compile run: make -j || make - name: Run test suite - run: make check LD_LIBRARY_PATH="/libs/lib:$LD_LIBRARY_PATH" SKIP_TESTS="$SKIP_TESTS" VERBOSE=1 + run: make check LD_LIBRARY_PATH="/libs/lib:$LD_LIBRARY_PATH" TEST_VERBOSE=1 From 05337ea4e9f9e01339dce8149d2ac033c04d90c5 Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Thu, 13 Jul 2023 13:16:11 -0400 Subject: [PATCH 35/51] refactor: `monin_obukhov_stable_mix` calls from `stable_mix_1d` (#1268) --- monin_obukhov/monin_obukhov.F90 | 53 ++++++++++++++++----------------- 1 file changed, 26 insertions(+), 27 deletions(-) diff --git a/monin_obukhov/monin_obukhov.F90 b/monin_obukhov/monin_obukhov.F90 index 883e4cbe34..ac8a89075f 100644 --- a/monin_obukhov/monin_obukhov.F90 +++ b/monin_obukhov/monin_obukhov.F90 @@ -274,16 +274,18 @@ subroutine stable_mix_3d(rich, mix) real, intent(in) , dimension(:,:,:) :: rich real, intent(out), dimension(:,:,:) :: mix +integer :: n2 !< Size of dimension 2 of mix and rich +integer :: n3 !< Size of dimension 3 of mix and rich +integer :: i, j !< Loop indices -integer :: n, ier - -if(.not.module_is_initialized) call error_mesg('stable_mix_3d in monin_obukhov_mod', & - 'monin_obukhov_init has not been called', FATAL) - -n = size(rich,1)*size(rich,2)*size(rich,3) -call monin_obukhov_stable_mix(stable_option, rich_crit, zeta_trans, & - & n, rich, mix, ier) +n2 = size(mix, 2) +n3 = size(mix, 3) +do j=1, n3 + do i=1, n2 + call stable_mix(rich(:, i, j), mix(:, i, j)) + enddo +enddo end subroutine stable_mix_3d @@ -943,16 +945,15 @@ subroutine stable_mix_2d(rich, mix) real, intent(in) , dimension(:,:) :: rich real, intent(out), dimension(:,:) :: mix +integer :: n2 !< Size of dimension 2 of mix and rich +integer :: i !< Loop index -real, dimension(size(rich,1),size(rich,2),1) :: rich_3d, mix_3d - -rich_3d(:,:,1) = rich +n2 = size(mix, 2) -call stable_mix_3d(rich_3d, mix_3d) - -mix = mix_3d(:,:,1) +do i=1, n2 + call stable_mix(rich(:, i), mix(:, i)) +enddo -return end subroutine stable_mix_2d @@ -962,16 +963,17 @@ subroutine stable_mix_1d(rich, mix) real, intent(in) , dimension(:) :: rich real, intent(out), dimension(:) :: mix +integer :: n !< Size of mix and rich +integer :: ierr !< Error code set by monin_obukhov_stable_mix -real, dimension(size(rich),1,1) :: rich_3d, mix_3d - -rich_3d(:,1,1) = rich +if (.not.module_is_initialized) call error_mesg('stable_mix in monin_obukhov_mod', & + 'monin_obukhov_init has not been called', FATAL) -call stable_mix_3d(rich_3d, mix_3d) +n = size(mix) -mix = mix_3d(:,1,1) +call monin_obukhov_stable_mix(stable_option, rich_crit, zeta_trans, & + & n, rich, mix, ierr) -return end subroutine stable_mix_1d !======================================================================= @@ -981,15 +983,12 @@ subroutine stable_mix_0d(rich, mix) real, intent(in) :: rich real, intent(out) :: mix -real, dimension(1,1,1) :: rich_3d, mix_3d - -rich_3d(1,1,1) = rich +real, dimension(1) :: mix_1d !< Representation of mix as a dimension(1) array -call stable_mix_3d(rich_3d, mix_3d) +call stable_mix([rich], mix_1d) -mix = mix_3d(1,1,1) +mix = mix_1d(1) -return end subroutine stable_mix_0d !======================================================================= From 0463dd122cb53418848a9798e12fa6641d8c2483 Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Thu, 13 Jul 2023 13:30:34 -0400 Subject: [PATCH 36/51] fix: out-of-bounds memory access in axis_utils2 (#1157) --- axis_utils/include/axis_utils2.inc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/axis_utils/include/axis_utils2.inc b/axis_utils/include/axis_utils2.inc index 21deca9fb4..3acd69b28c 100644 --- a/axis_utils/include/axis_utils2.inc +++ b/axis_utils/include/axis_utils2.inc @@ -213,7 +213,7 @@ endif lon_strt = lon(1) - do i=2,len+1 + do i=2,len lon(i) = lon_in_range(lon(i),lon_strt) lon_strt = lon(i) enddo From 8eb24f8bcdd65d1e061bff5578b928013e375de2 Mon Sep 17 00:00:00 2001 From: Jesse Lentz <42011922+J-Lentz@users.noreply.github.com> Date: Thu, 13 Jul 2023 13:44:53 -0400 Subject: [PATCH 37/51] fix: maximize system stacksize limit in fms_init (#1233) --- fms/Makefile.am | 1 + fms/fms.F90 | 9 +++++++++ fms/fms_stacksize.c | 33 +++++++++++++++++++++++++++++++++ 3 files changed, 43 insertions(+) create mode 100644 fms/fms_stacksize.c diff --git a/fms/Makefile.am b/fms/Makefile.am index 8f8c58525b..ca8b107941 100644 --- a/fms/Makefile.am +++ b/fms/Makefile.am @@ -32,6 +32,7 @@ noinst_LTLIBRARIES = libfms.la # Each convenience library depends on its source. libfms_la_SOURCES = \ fms.F90 \ + fms_stacksize.c \ include/fms.inc \ include/fms_r4.fh \ include/fms_r8.fh \ diff --git a/fms/fms.F90 b/fms/fms.F90 index 3ec8052148..2ac9393b48 100644 --- a/fms/fms.F90 +++ b/fms/fms.F90 @@ -336,6 +336,11 @@ subroutine fms_init (localcomm, alt_input_nml_path) use fms_io_mod, only: fms_io_version #endif + interface + subroutine maximize_system_stacksize_limit() bind(C) + end subroutine + end interface + integer, intent(in), optional :: localcomm character(len=*), intent(in), optional :: alt_input_nml_path integer :: ierr, io @@ -344,6 +349,10 @@ subroutine fms_init (localcomm, alt_input_nml_path) if (module_is_initialized) return ! return silently if already called module_is_initialized = .true. + +!---- Raise the system stack size limit to its maximum permissible value ---- + call maximize_system_stacksize_limit + !---- initialize mpp routines ---- if(present(localcomm)) then if(present(alt_input_nml_path)) then diff --git a/fms/fms_stacksize.c b/fms/fms_stacksize.c new file mode 100644 index 0000000000..7631656475 --- /dev/null +++ b/fms/fms_stacksize.c @@ -0,0 +1,33 @@ +/*********************************************************************** + * GNU Lesser General Public License + * + * This file is part of the GFDL Flexible Modeling System (FMS). + * + * FMS is free software: you can redistribute it and/or modify it under + * the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or (at + * your option) any later version. + * + * FMS is distributed in the hope that it will be useful, but WITHOUT + * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + * for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with FMS. If not, see . + **********************************************************************/ + +#include + +/* + * Set the stack size limit to its maximum permissible value + */ + +void maximize_system_stacksize_limit() +{ + struct rlimit stacksize; + + getrlimit(RLIMIT_STACK, &stacksize); + stacksize.rlim_cur = stacksize.rlim_max; + setrlimit(RLIMIT_STACK, &stacksize); +} From a2471c86e7b0c4596428f36a31de8ce13727db1a Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 13 Jul 2023 14:14:55 -0400 Subject: [PATCH 38/51] test: remove stack limit checks in test scripts (#1280) --- test_fms/fms2_io/test_fms2_io.sh | 10 ---------- test_fms/mpp/test_mpp_chksum.sh | 5 ----- test_fms/test-lib.sh.in | 5 ----- 3 files changed, 20 deletions(-) diff --git a/test_fms/fms2_io/test_fms2_io.sh b/test_fms/fms2_io/test_fms2_io.sh index 8a604e6655..5e0bd31c0e 100755 --- a/test_fms/fms2_io/test_fms2_io.sh +++ b/test_fms/fms2_io/test_fms2_io.sh @@ -31,16 +31,6 @@ # Create and enter output directory output_dir -# use smaller arrays if system stack size is limited -if [ $STACK_LIMITED ]; then - cat <<_EOF > input.nml -&test_fms2_io_nml - nx = 32 - ny = 32 - nz = 10 -/ -_EOF -fi touch input.nml # run the tests diff --git a/test_fms/mpp/test_mpp_chksum.sh b/test_fms/mpp/test_mpp_chksum.sh index 03d252794b..bea691aa5f 100755 --- a/test_fms/mpp/test_mpp_chksum.sh +++ b/test_fms/mpp/test_mpp_chksum.sh @@ -29,11 +29,6 @@ echo "&test_mpp_chksum_nml" > input.nml echo "test_num = 1" >> input.nml -# replaces defaults with smaller sizes if stack size is limited -if [ $STACK_LIMITED ]; then - echo "nx = 64" >> input.nml - echo "ny = 64" >> input.nml -fi echo "/" >> input.nml test_expect_success "mpp_chksum simple functionality" ' diff --git a/test_fms/test-lib.sh.in b/test_fms/test-lib.sh.in index a2cfe8ebf8..b983b48d84 100644 --- a/test_fms/test-lib.sh.in +++ b/test_fms/test-lib.sh.in @@ -33,11 +33,6 @@ TEST_NAME="$(basename "$0" .sh)" TEST_NUMBER="${TEST_NAME%%-*}" TEST_NUMBER="${TEST_NUMBER#t}" -# if using intel with a limited stack size, sets to run smaller tests -if [ "$($FC --version | grep ifort)" -a "$(ulimit -s)" != "unlimited" 2> /dev/null ]; then - STACK_LIMITED=1 -fi - exec 7>&2 # For now, write all output #if test -n "$VERBOSE" From 6693a4fdd67e490864c55b05c2ec5bf699341c45 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 13 Jul 2023 14:37:47 -0400 Subject: [PATCH 39/51] fix: mpp global arrays test fixes (#1174) --- test_fms/mpp/test_global_arrays.F90 | 491 +++++++++++++--------------- test_fms/mpp/test_global_arrays.sh | 22 +- test_fms/mpp/test_mpp_domains.F90 | 117 ------- 3 files changed, 246 insertions(+), 384 deletions(-) diff --git a/test_fms/mpp/test_global_arrays.F90 b/test_fms/mpp/test_global_arrays.F90 index ce2b125cb4..4f27b0c666 100644 --- a/test_fms/mpp/test_global_arrays.F90 +++ b/test_fms/mpp/test_global_arrays.F90 @@ -34,21 +34,24 @@ program test_global_arrays use mpp_domains_mod, only: mpp_global_min, mpp_get_data_domain,mpp_get_compute_domain use mpp_domains_mod, only: mpp_domains_exit, mpp_update_domains use mpp_domains_mod, only: mpp_get_domain_shift, mpp_global_sum + use mpp_domains_mod, only: CYCLIC_GLOBAL_DOMAIN, NORTH, EAST, CENTER, CORNER, BITWISE_EXACT_SUM + use mpp_mod, only: MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, mpp_clock_id, mpp_clock_begin, mpp_clock_end + use fms_mod, only: check_nml_error, input_nml_file implicit none integer, parameter :: length=64 - integer :: id, pe, npes, root, i, j, icount, jcount - integer(i4_kind) :: maxI4, minI4, ierr, sumI4, sumI4_5d - integer(i8_kind) :: maxI8, minI8, sumI8, sumI8_5d - integer(i4_kind), allocatable :: dataI4(:,:), dataI4_5d(:,:,:,:,:), dataI4_shuf(:,:) - integer(i8_kind), allocatable :: dataI8(:,:), dataI8_5d(:,:,:,:,:), dataI8_shuf(:,:) - real(r4_kind), allocatable :: dataR4(:,:), dataR4_5d(:,:,:,:,:), dataR4_shuf(:,:) - real(r8_kind), allocatable :: dataR8(:,:), dataR8_5d(:,:,:,:,:), dataR8_shuf(:,:) + integer :: id, pe, npes, root, i, j, icount, jcount, io + integer(i4_kind) :: maxI4, minI4, ierr, sumI4, sumI4_5d, sumI4_shuf + integer(i8_kind) :: maxI8, minI8, sumI8, sumI8_5d, sumI8_shuf + integer(i4_kind), allocatable :: dataI4(:,:), dataI4_shuf(:,:), recv_data_i4(:,:) + integer(i8_kind), allocatable :: dataI8(:,:), dataI8_shuf(:,:), recv_data_i8(:,:) + real(r4_kind), allocatable :: dataR4(:,:), dataR4_shuf(:,:), recv_data_r4(:,:) + real(r8_kind), allocatable :: dataR8(:,:), dataR8_shuf(:,:), recv_data_r8(:,:) real, allocatable :: rands(:) type(domain2D) :: domain - real(r8_kind) :: rcoef, maxR8, minR8, sumR8, sumR8_5d - real(r4_kind) :: maxR4, minR4, sumR4, sumR4_5d + real(r8_kind) :: rcoef, maxR8, minR8, sumR8, sumR8_shuf + real(r4_kind) :: maxR4, minR4, sumR4, sumR4_shuf integer :: isc, iec, jsc, jec integer :: isd, ied, jsd, jed character(len=32) :: strTmp1, strTmp2 @@ -56,22 +59,60 @@ program test_global_arrays integer(i8_kind), parameter :: randmaxI8 = 4096 real(r8_kind), parameter :: tol4 = 1e-4, tol8 = 1e-6!> tolerance for real comparisons - call mpp_init(mpp_init_test_init_true_only) + ! namelist variables - just logicals to enable individual tests + ! simple just does normal max/min + sums across a domain + ! full does max/min+sums with halos and symmetry + logical :: test_simple= .false. , test_full = .false. + namelist / test_global_arrays_nml / test_simple, test_full + + call mpp_init() + call mpp_domains_init() - call mpp_set_stack_size(3145746) - call mpp_domains_set_stack_size(3145746) + !call mpp_set_stack_size(3145746) + call mpp_domains_set_stack_size(4000000) + + read(input_nml_file, nml=test_global_arrays_nml, iostat=io) + ierr = check_nml_error(io, 'test_global_arrays_nml') pe = mpp_pe() npes = mpp_npes() call mpp_set_root_pe(0) root = mpp_root_pe() + if( test_simple) then + call test_mpp_global_simple() + deallocate(dataI4, dataI8, dataR4, dataR8, rands) + deallocate(dataR4_shuf, dataR8_shuf,dataI4_shuf, dataI8_shuf) + else if(test_full) then + call test_global_reduce( 'Simple') + call test_global_reduce( 'Simple symmetry center') + call test_global_reduce( 'Simple symmetry corner') + call test_global_reduce( 'Simple symmetry east') + call test_global_reduce( 'Simple symmetry north') + call test_global_reduce( 'Cyclic symmetry center') + call test_global_reduce( 'Cyclic symmetry corner') + call test_global_reduce( 'Cyclic symmetry east') + call test_global_reduce( 'Cyclic symmetry north') + else + call mpp_error(FATAL, "test_global_arrays: either test_sum or test_max_min must be true in input.nml") + endif + call mpp_sync() + + call mpp_domains_exit() + call MPI_FINALIZE(ierr) + + contains + +subroutine test_mpp_global_simple() + !> define domains and allocate - call mpp_define_domains( (/1,length,1,length/), (/4,2/), domain, xhalo=0) + call mpp_define_domains( (/1,length,1,length/), (/1,8/), domain, xhalo=0) call mpp_get_compute_domain(domain, jsc, jec, isc, iec) call mpp_get_data_domain(domain, jsd, jed, isd, ied) allocate(dataI4(jsd:jed, isd:ied),dataI8(jsd:jed, isd:ied), rands(length*length)) allocate(dataR4(jsd:jed, isd:ied), dataR8(jsd:jed, isd:ied)) allocate(dataR4_shuf(jsd:jed, isd:ied), dataR8_shuf(jsd:jed, isd:ied)) allocate(dataI4_shuf(jsd:jed, isd:ied), dataI8_shuf(jsd:jed, isd:ied)) + allocate(recv_data_r4(jsd:jed, isd:ied), recv_data_r8(jsd:jed, isd:ied)) + allocate(recv_data_i4(jsd:jed, isd:ied), recv_data_i8(jsd:jed, isd:ied)) dataI4 = 0; dataI8 = 0; dataR4 = 0.0; dataR8 = 0.0 dataR8_shuf=0.0; dataR4_shuf=0.0;dataI8_shuf=0; dataI4_shuf=0 @@ -166,97 +207,92 @@ program test_global_arrays NEW_LINE('a')//"Sum: "// strTmp1 ) endif - !> shuffle real data ordering and copy into array with 5 ranks - dataR4_shuf = dataR4 - dataR8_shuf = dataR8 - call shuffleDataR4(dataR4_shuf) - call shuffleDataR8(dataR8_shuf) - allocate(dataR4_5d(jsd:jed, isd:ied, 1, 1, 1), dataR8_5d(jsd:jed,isd:ied, 1, 1, 1)) - - dataR4_5d = 0.0 - dataR8_5d = 0.0 - - do i=isc,iec - do j=jsc,jec - dataR4_5d(j, i, 1, 1, 1) = dataR4_shuf(j, i) - dataR8_5d(j, i, 1, 1, 1) = dataR8_shuf(j, i) - end do - end do + !> moves the data into different pe's and checks the sum still matches + dataR4_shuf = dataR4 ; dataR8_shuf = dataR8 + dataI4_shuf = dataI4 ; dataI8_shuf = dataI8 + !! swap data with neighboring pe + if(modulo(pe, 2) .eq. 0) then + print *, pe, pe+1, SUM(dataR8_shuf) + call mpp_send(dataR4_shuf, SIZE(dataR4_shuf), pe+1) + call mpp_recv(recv_data_r4, SIZE(dataR4_shuf), pe+1) + call mpp_sync() + call mpp_send(dataR8_shuf, SIZE(dataR8_shuf), pe+1) + call mpp_recv(recv_data_r8, SIZE(dataR8_shuf), pe+1) + call mpp_sync() + call mpp_send(dataI4_shuf, SIZE(dataI4_shuf), pe+1) + call mpp_recv(recv_data_I4, SIZE(dataI4_shuf), pe+1) + call mpp_sync() + call mpp_send(dataI8_shuf, SIZE(dataI8_shuf), pe+1) + call mpp_recv(recv_data_I8, SIZE(dataI8_shuf), pe+1) + else + print *, pe, pe-1, SUM(dataR8_shuf) + call mpp_recv(recv_data_r4, SIZE(dataR4_shuf), pe-1) + call mpp_send(dataR4_shuf, SIZE(dataR4_shuf), pe-1) + call mpp_sync() + call mpp_recv(recv_data_r8, SIZE(dataR8_shuf), pe-1) + call mpp_send(dataR8_shuf, SIZE(dataR8_shuf), pe-1) + call mpp_sync() + call mpp_send(dataI4_shuf, SIZE(dataI4_shuf), pe-1) + call mpp_recv(recv_data_I4, SIZE(dataI4_shuf), pe-1) + call mpp_sync() + call mpp_send(dataI8_shuf, SIZE(dataI8_shuf), pe-1) + call mpp_recv(recv_data_I8, SIZE(dataI8_shuf), pe-1) + endif call mpp_sync() + dataR4_shuf = recv_data_r4 + dataR8_shuf = recv_data_r8 - call mpp_error(NOTE, "----------Testing 32-bit real mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataR4_5d, domain) - sumR4_5d = mpp_global_sum(domain, dataR4_5d) + call mpp_error(NOTE, "----------Testing 32-bit real mpp_global_sum with reordering----------") + call mpp_update_domains(dataR4_shuf, domain) + sumR4_shuf = mpp_global_sum(domain, dataR4_shuf) ! check that shuffled array results are approximately the same as the original array - if(abs(sumR4-sumR4_5d) .gt. 1E-4 ) then + if(abs(sumR4-sumR4_shuf) .gt. 1E-4 ) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumR4_5d + write(strTmp1,*) sumR4_shuf write(strTmp2,*) sumR4 call mpp_error(FATAL,"test_global_arrays: invalid 32-bit real answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - call mpp_error(NOTE, "----------Testing 64-bit real mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataR8_5d, domain) - sumR8_5d = mpp_global_sum(domain, dataR8_5d) + call mpp_sync() + call mpp_error(NOTE, "----------Testing 64-bit real mpp_global_sum with reordering----------") + call mpp_update_domains(dataR8_shuf, domain) + sumR8_shuf = mpp_global_sum(domain, dataR8_shuf) ! check that shuffled array results are approximately the same as the original array - if(abs(sumR8-sumR8_5d) .gt. 1E-7) then + if(abs(sumR8-sumR8_shuf) .gt. 1E-7) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumR8_5d + write(strTmp1,*) sumR8_shuf write(strTmp2,*) sumR8 call mpp_error(FATAL,"test_global_arrays: invalid 64-bit real answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - !> shuffle integer data ordering and copy into array with 5 ranks - dataI4_shuf = dataI4 - dataI8_shuf = dataI8 - call shuffleDataI4(dataI4_shuf) - call shuffleDataI8(dataI8_shuf) - allocate(dataI4_5d(jsd:jed, isd:ied, 1, 1, 1), dataI8_5d(jsd:jed,isd:ied, 1, 1, 1)) - - dataI4_5d = 0 - dataI8_5d = 0 - do i=isc,iec - do j=jsc,jec - dataI4_5d(j, i, 1, 1, 1) = dataI4_shuf(j, i) - dataI8_5d(j, i, 1, 1, 1) = dataI8_shuf(j, i) - end do - end do - call mpp_sync() - - call mpp_error(NOTE, "----------Testing 32-bit integer mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataI4_5d, domain) - sumI4_5d = mpp_global_sum(domain, dataI4_5d) + call mpp_error(NOTE, "----------Testing 32-bit integer mpp_global_sum with reordering----------") + call mpp_update_domains(dataI4_shuf, domain) + sumI4_shuf = mpp_global_sum(domain, dataI4_shuf) ! check that shuffled array results are approximately the same as the original array - if(sumI4 .ne. sumI4_5d) then + if(sumI4 .ne. sumI4_shuf) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumI4_5d + write(strTmp1,*) sumI4_shuf write(strTmp2,*) sumI4 call mpp_error(FATAL,"test_global_arrays: invalid 32-bit integer answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - call mpp_error(NOTE, "----------Testing 64-bit integer mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataI8_5d, domain) - sumI8_5d = mpp_global_sum(domain, dataI8_5d) + call mpp_error(NOTE, "----------Testing 64-bit integer mpp_global_sum with reordering----------") + call mpp_update_domains(dataI8_shuf, domain) + sumI8_shuf = mpp_global_sum(domain, dataI8_shuf) ! check that shuffled array results are approximately the same as the original array - if(sumI8 .ne. sumI8_5d) then + if(sumI8 .ne. sumI8_shuf) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumI8_5d + write(strTmp1,*) sumI8_shuf write(strTmp2,*) sumI8 call mpp_error(FATAL,"test_global_arrays: invalid 64-bit integer answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - - deallocate(dataI4, dataI8, dataR4, dataR8, rands, dataI4_5d, dataI8_5d, dataR4_5d, dataR8_5d) - deallocate(dataR4_shuf, dataR8_shuf,dataI4_shuf, dataI8_shuf) - call mpp_domains_exit() - call MPI_FINALIZE(ierr) - - contains +end subroutine test_mpp_global_simple !> true if all pes return the same result and have a lower/higher local max/min function checkResultInt4(res) @@ -368,7 +404,6 @@ function checkSumReal4(gsum) real(r4_kind),intent(in) :: gsum real(r4_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 real(r4_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -402,7 +437,6 @@ function checkSumReal8(gsum) real(r8_kind),intent(in) :: gsum real(r8_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 real(r8_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -436,7 +470,6 @@ function checkSumInt4(gsum) integer(i4_kind),intent(in) :: gsum integer(i4_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 integer(i4_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -470,7 +503,6 @@ function checkSumInt8(gsum) integer(i8_kind),intent(in) :: gsum integer(i8_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 integer(i8_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -497,192 +529,123 @@ function checkSumInt8(gsum) deallocate(recv) end function checkSumInt8 -!> aggregates data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataI4(dataI4) - integer(i4_kind), intent(INOUT) :: dataI4(:,:) - integer(i4_kind), allocatable :: trans(:,:), shuffled(:),tmp - integer :: rind - - allocate(trans(SIZE(dataI4,1), SIZE(dataI4,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataI4)) = RESHAPE(dataI4, (/SIZE(dataI4)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataI4) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataI4 = trans - endif - end do - else - call mpp_send(dataI4, SIZE(dataI4), root) - call mpp_recv(trans, SIZE(dataI4), root) - dataI4 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataI4 - -!> aggregates data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataI8(dataI8) - integer(i8_kind), intent(INOUT) :: dataI8(:,:) - integer(i8_kind), allocatable :: trans(:,:), shuffled(:), tmp - integer :: rind - - allocate(trans(SIZE(dataI8,1), SIZE(dataI8,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataI8)) = RESHAPE(dataI8, (/SIZE(dataI8)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataI8) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataI8 = trans - endif - end do - else - call mpp_send(dataI8, SIZE(dataI8), root) - call mpp_recv(trans, SIZE(dataI8), root) - dataI8 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataI8 - -!> aggregates 32-bit real data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataR4(dataR4) - real(r4_kind), intent(INOUT) :: dataR4(:,:) - real(r4_kind), allocatable :: trans(:,:), shuffled(:), tmp - integer :: rind - - allocate(trans(SIZE(dataR4,1), SIZE(dataR4,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataR4)) = RESHAPE(dataR4, (/SIZE(dataR4)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataR4) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataR4 = trans - endif - end do - else - call mpp_send(dataR4, SIZE(dataR4), root) - call mpp_recv(trans, SIZE(dataR4), root) - dataR4 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataR4 - -!> aggregates 64-bit real data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataR8(dataR8) - real(r8_kind), intent(INOUT) :: dataR8(:,:) - real(r8_kind), allocatable :: trans(:,:), shuffled(:), tmp - integer :: rind - - allocate(trans(SIZE(dataR8,1), SIZE(dataR8,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataR8)) = RESHAPE(dataR8, (/SIZE(dataR8)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataR8) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataR8 = trans - endif - end do - else - call mpp_send(dataR8, SIZE(dataR8), root) - call mpp_recv(trans, SIZE(dataR8), root) - dataR8 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataR8 + !--- test mpp_global_sum, mpp_global_min and mpp_global_max + subroutine test_global_reduce (type) + character(len=*), intent(in) :: type + real :: lsum, gsum, lmax, gmax, lmin, gmin + integer :: ni, nj, ishift, jshift, position, k + integer :: is, ie, js, je !, isd, ied, jsd, jed + integer :: nx=128, ny=128, nz=40, stackmax=4000000 + integer :: layout(2) + integer :: whalo = 2, ehalo = 2, shalo = 2, nhalo = 2 + real, allocatable, dimension(:,:,:) :: global1, x + real, allocatable, dimension(:,:) :: global2D + !--- set up domain + call mpp_define_layout( (/1,nx,1,ny/), npes, layout ) + select case(type) + case( 'Simple' ) + call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & + shalo=shalo, nhalo=nhalo, name=type ) + case( 'Simple symmetry center', 'Simple symmetry corner', 'Simple symmetry east', 'Simple symmetry north' ) + call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & + shalo=shalo, nhalo=nhalo, name=type, symmetry = .true. ) + case( 'Cyclic symmetry center', 'Cyclic symmetry corner', 'Cyclic symmetry east', 'Cyclic symmetry north' ) + call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo,& + name=type, symmetry = .true., xflags=CYCLIC_GLOBAL_DOMAIN, & + & yflags=CYCLIC_GLOBAL_DOMAIN ) + case default + call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type//' in test_global_field' ) + end select + call mpp_get_compute_domain( domain, is, ie, js, je ) + call mpp_get_data_domain ( domain, isd, ied, jsd, jed ) + + !--- determine if an extra point is needed + ishift = 0; jshift = 0; position = CENTER + select case(type) + case ('Simple symmetry corner', 'Cyclic symmetry corner') + ishift = 1; jshift = 1; position = CORNER + case ('Simple symmetry east', 'Cyclic symmetry east' ) + ishift = 1; jshift = 0; position = EAST + case ('Simple symmetry north', 'Cyclic symmetry north') + ishift = 0; jshift = 1; position = NORTH + end select + + ie = ie+ishift; je = je+jshift + ied = ied+ishift; jed = jed+jshift + ni = nx+ishift; nj = ny+jshift + allocate(global1(1-whalo:ni+ehalo, 1-shalo:nj+nhalo, nz)) + global1 = 0.0 + do k = 1,nz + do j = 1,nj + do i = 1,ni + global1(i,j,k) = k + i*1e-3 + j*1e-6 + end do + end do + enddo + + !--- NOTE: even though the domain is cyclic, no need to apply cyclic condition on the global data + + allocate( x (isd:ied,jsd:jed,nz) ) + allocate( global2D(ni,nj)) + + x(:,:,:) = global1(isd:ied,jsd:jed,:) + do j = 1, nj + do i = 1, ni + global2D(i,j) = sum(global1(i,j,:)) + enddo + enddo + !test mpp_global_sum + + if(type(1:6) == 'Simple') then + gsum = sum( global2D(1:ni,1:nj) ) + else + gsum = sum( global2D(1:nx, 1:ny) ) + endif + id = mpp_clock_id( type//' sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lsum = mpp_global_sum( domain, x, position = position ) + call mpp_clock_end (id) + if( pe.EQ.mpp_root_pe() )print '(a,2es15.8,a,es12.4)', type//' Fast sum=', lsum, gsum + + !test exact mpp_global_sum + id = mpp_clock_id( type//' exact sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lsum = mpp_global_sum( domain, x, BITWISE_EXACT_SUM, position = position ) + call mpp_clock_end (id) + !--- The following check will fail on altix in normal mode, but it is ok + !--- in debugging mode. It is ok on irix. + call compare_data_scalar(lsum, gsum, FATAL, type//' mpp_global_exact_sum') + + !test mpp_global_min + gmin = minval(global1(1:ni, 1:nj, :)) + id = mpp_clock_id( type//' min', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lmin = mpp_global_min( domain, x, position = position ) + call mpp_clock_end (id) + call compare_data_scalar(lmin, gmin, FATAL, type//' mpp_global_min') + + !test mpp_global_max + gmax = maxval(global1(1:ni, 1:nj, :)) + id = mpp_clock_id( type//' max', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lmax = mpp_global_max( domain, x, position = position ) + call mpp_clock_end (id) + call compare_data_scalar(lmax, gmax, FATAL, type//' mpp_global_max' ) + + deallocate(global1, x) + + end subroutine test_global_reduce + + subroutine compare_data_scalar( a, b, action, string ) + real, intent(in) :: a, b + integer, intent(in) :: action + character(len=*), intent(in) :: string + if( a .EQ. b)then + if( pe.EQ.mpp_root_pe() )call mpp_error( NOTE, trim(string)//': data comparison are OK.' ) + else + call mpp_error( action, trim(string)//': data comparison are not OK.' ) + end if + + end subroutine compare_data_scalar end program test_global_arrays diff --git a/test_fms/mpp/test_global_arrays.sh b/test_fms/mpp/test_global_arrays.sh index 596d1ecb0a..18390415e5 100755 --- a/test_fms/mpp/test_global_arrays.sh +++ b/test_fms/mpp/test_global_arrays.sh @@ -27,10 +27,26 @@ # Set common test settings. . ../test-lib.sh -# ensure input.nml file present -touch input.nml +cat <<_EOF > input.nml +&test_global_arrays_nml + test_simple = .true. + test_full = .false. +/ +_EOF -test_expect_success "global array functions with mixed precision" ' +test_expect_success "mpp_global_sum/max/min with simple domain" ' mpirun -n 8 ./test_global_arrays ' + +cat <<_EOF > input.nml +&test_global_arrays_nml + test_simple = .false. + test_full = .true. +/ +_EOF + +test_expect_success "mpp_global_sum/max/min with symmetry and halos" ' + mpirun -n 6 ./test_global_arrays +' + test_done diff --git a/test_fms/mpp/test_mpp_domains.F90 b/test_fms/mpp/test_mpp_domains.F90 index ab9ba1a447..1ae1d904da 100644 --- a/test_fms/mpp/test_mpp_domains.F90 +++ b/test_fms/mpp/test_mpp_domains.F90 @@ -250,17 +250,6 @@ program test_mpp_domains call test_uniform_mosaic('Cubic-Grid') ! 6 tiles. call test_nonuniform_mosaic('Five-Tile') - if(.not. wide_halo) then - call test_global_reduce( 'Simple') - call test_global_reduce( 'Simple symmetry center') - call test_global_reduce( 'Simple symmetry corner') - call test_global_reduce( 'Simple symmetry east') - call test_global_reduce( 'Simple symmetry north') - call test_global_reduce( 'Cyclic symmetry center') - call test_global_reduce( 'Cyclic symmetry corner') - call test_global_reduce( 'Cyclic symmetry east') - call test_global_reduce( 'Cyclic symmetry north') - endif call test_redistribute( 'Complete pelist' ) call test_redistribute( 'Overlap pelist' ) @@ -6057,112 +6046,6 @@ subroutine test_cyclic_offset( type ) end subroutine test_cyclic_offset - !--- test mpp_global_sum, mpp_global_min and mpp_global_max - subroutine test_global_reduce (type) - character(len=*), intent(in) :: type - real :: lsum, gsum, lmax, gmax, lmin, gmin - integer :: ni, nj, ishift, jshift, position - integer :: is, ie, js, je, isd, ied, jsd, jed - - type(domain2D) :: domain - real, allocatable, dimension(:,:,:) :: global1, x - real, allocatable, dimension(:,:) :: global2D - !--- set up domain - call mpp_define_layout( (/1,nx,1,ny/), npes, layout ) - select case(type) - case( 'Simple' ) - call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & - shalo=shalo, nhalo=nhalo, name=type ) - case( 'Simple symmetry center', 'Simple symmetry corner', 'Simple symmetry east', 'Simple symmetry north' ) - call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & - shalo=shalo, nhalo=nhalo, name=type, symmetry = .true. ) - case( 'Cyclic symmetry center', 'Cyclic symmetry corner', 'Cyclic symmetry east', 'Cyclic symmetry north' ) - call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo,& - name=type, symmetry = .true., xflags=CYCLIC_GLOBAL_DOMAIN, & - & yflags=CYCLIC_GLOBAL_DOMAIN ) - case default - call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type//' in test_global_field' ) - end select - call mpp_get_compute_domain( domain, is, ie, js, je ) - call mpp_get_data_domain ( domain, isd, ied, jsd, jed ) - - !--- determine if an extra point is needed - ishift = 0; jshift = 0; position = CENTER - select case(type) - case ('Simple symmetry corner', 'Cyclic symmetry corner') - ishift = 1; jshift = 1; position = CORNER - case ('Simple symmetry east', 'Cyclic symmetry east' ) - ishift = 1; jshift = 0; position = EAST - case ('Simple symmetry north', 'Cyclic symmetry north') - ishift = 0; jshift = 1; position = NORTH - end select - - ie = ie+ishift; je = je+jshift - ied = ied+ishift; jed = jed+jshift - ni = nx+ishift; nj = ny+jshift - allocate(global1(1-whalo:ni+ehalo, 1-shalo:nj+nhalo, nz)) - global1 = 0.0 - do k = 1,nz - do j = 1,nj - do i = 1,ni - global1(i,j,k) = k + i*1e-3 + j*1e-6 - end do - end do - enddo - - !--- NOTE: even though the domain is cyclic, no need to apply cyclic condition on the global data - - allocate( x (isd:ied,jsd:jed,nz) ) - allocate( global2D(ni,nj)) - - x(:,:,:) = global1(isd:ied,jsd:jed,:) - do j = 1, nj - do i = 1, ni - global2D(i,j) = sum(global1(i,j,:)) - enddo - enddo - !test mpp_global_sum - - if(type(1:6) == 'Simple') then - gsum = sum( global2D(1:ni,1:nj) ) - else - gsum = sum( global2D(1:nx, 1:ny) ) - endif - id = mpp_clock_id( type//' sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lsum = mpp_global_sum( domain, x, position = position ) - call mpp_clock_end (id) - if( pe.EQ.mpp_root_pe() )print '(a,2es15.8,a,es12.4)', type//' Fast sum=', lsum, gsum - - !test exact mpp_global_sum - id = mpp_clock_id( type//' exact sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lsum = mpp_global_sum( domain, x, BITWISE_EXACT_SUM, position = position ) - call mpp_clock_end (id) - !--- The following check will fail on altix in normal mode, but it is ok - !--- in debugging mode. It is ok on irix. - call compare_data_scalar(lsum, gsum, FATAL, type//' mpp_global_exact_sum') - - !test mpp_global_min - gmin = minval(global1(1:ni, 1:nj, :)) - id = mpp_clock_id( type//' min', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lmin = mpp_global_min( domain, x, position = position ) - call mpp_clock_end (id) - call compare_data_scalar(lmin, gmin, FATAL, type//' mpp_global_min') - - !test mpp_global_max - gmax = maxval(global1(1:ni, 1:nj, :)) - id = mpp_clock_id( type//' max', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lmax = mpp_global_max( domain, x, position = position ) - call mpp_clock_end (id) - call compare_data_scalar(lmax, gmax, FATAL, type//' mpp_global_max' ) - - deallocate(global1, x) - - end subroutine test_global_reduce - subroutine test_parallel_2D ( ) integer :: npes, layout(2), i, j, k,is, ie, js, je, isd, ied, jsd, jed From e6225adaef3008355746a3a07fc0675b22132325 Mon Sep 17 00:00:00 2001 From: JONG KIM Date: Thu, 13 Jul 2023 14:53:04 -0400 Subject: [PATCH 40/51] feat: update mpp_do_update_ad.fh to resolve JEDI requirement (#1225) --- mpp/include/mpp_do_global_field_ad.fh | 4 +- mpp/include/mpp_do_updateV_ad.fh | 2 +- mpp/include/mpp_do_update_ad.fh | 173 ++++++++++++++++++------- mpp/include/mpp_get_boundary_ad.fh | 2 +- mpp/include/mpp_global_field_ad.fh | 4 +- mpp/include/mpp_sum_mpi_ad.fh | 2 +- mpp/include/mpp_sum_nocomm_ad.fh | 2 +- mpp/include/mpp_update_domains2D_ad.fh | 16 +-- 8 files changed, 143 insertions(+), 62 deletions(-) diff --git a/mpp/include/mpp_do_global_field_ad.fh b/mpp/include/mpp_do_global_field_ad.fh index 5c72b5adbf..d32e6aa4b8 100644 --- a/mpp/include/mpp_do_global_field_ad.fh +++ b/mpp/include/mpp_do_global_field_ad.fh @@ -22,8 +22,8 @@ !> @addtogroup mpp_domains_mod !> @{ - !> Gets a global field from a local field - !! local field may be on compute OR data domain + !> Gets a local ad field from a global field + !! global field may be on compute OR data domain subroutine MPP_DO_GLOBAL_FIELD_3D_AD_( domain, local, global, tile, ishift, jshift, flags, default_data) type(domain2D), intent(in) :: domain MPP_TYPE_, intent(inout) :: local(:,:,:) diff --git a/mpp/include/mpp_do_updateV_ad.fh b/mpp/include/mpp_do_updateV_ad.fh index d6cce14abf..8d230f501c 100644 --- a/mpp/include/mpp_do_updateV_ad.fh +++ b/mpp/include/mpp_do_updateV_ad.fh @@ -21,7 +21,7 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - !> Updates data domain of 3D field whose computational domains have been computed + !> Updates data domain of 3D ad field whose computational domains have been computed subroutine MPP_DO_UPDATE_AD_3D_V_(f_addrsx,f_addrsy, domain, update_x, update_y, & d_type, ke, gridtype, flags) integer(i8_kind), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) diff --git a/mpp/include/mpp_do_update_ad.fh b/mpp/include/mpp_do_update_ad.fh index 7afbe8317d..7e7382dcb8 100644 --- a/mpp/include/mpp_do_update_ad.fh +++ b/mpp/include/mpp_do_update_ad.fh @@ -1,6 +1,4 @@ ! -*-f90-*- - - !*********************************************************************** !* GNU Lesser General Public License !* @@ -21,8 +19,12 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - - !> Updates data domain of 3D field whose computational domains have been computed + !> Updates data domain of 3D ad field whose computational domains have been computed + !! @brief Applies linear adjoint operation to 3D field based on duality of MPP_DO_UPDATE_3D_ + !! @note Adjoint duality exists between MPI SEND and MPI_RECV. + !! However, checkpoint is needed for forward buffer information. + !! ref: BN. Cheng, A Duality between Forward and Adjoint MPI Communication Routines + !! COMPUTATIONAL METHODS IN SCIENCE AND TECHNOLOGY Special Issue 2006, 23-24 subroutine MPP_DO_UPDATE_AD_3D_( f_addrs, domain, update, d_type, ke, flags) integer(i8_kind), intent(in) :: f_addrs(:,:) type(domain2D), intent(in) :: domain @@ -35,6 +37,7 @@ pointer(ptr_field, field) integer :: update_flags type(overlap_type), pointer :: overPtr => NULL() + character(len=8) :: text !equate to mpp_domains_stack MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) @@ -43,13 +46,16 @@ !receive domains saved here for unpacking !for non-blocking version, could be recomputed - integer, allocatable :: msg1(:), msg2(:) + integer, allocatable :: msg1(:), msg2(:), msg3(:) logical :: send(8), recv(8), update_edge_only - integer :: to_pe, from_pe, pos, msgsize, msgsize_send + integer :: to_pe, from_pe, pos, msgsize integer :: n, l_size, l, m, i, j, k integer :: is, ie, js, je, tMe, dir integer :: buffer_recv_size, nlist, outunit - + integer :: send_start_pos !>Send buffer start location + !!This serves as ad recv buffer start location + integer :: send_msgsize(MAXLIST) !>Send buffer msg size storage + !!This should be checkpointed for reverse ad communication outunit = stdout() ptr = LOC(mpp_domains_stack) @@ -80,9 +86,10 @@ if(debug_message_passing) then nlist = size(domain%list(:)) - allocate(msg1(0:nlist-1), msg2(0:nlist-1) ) + allocate(msg1(0:nlist-1), msg2(0:nlist-1), msg3(0:nlist-1) ) msg1 = 0 msg2 = 0 + msg3 = 0 do m = 1, update%nrecv overPtr => update%recv(m) msgsize = 0 @@ -96,7 +103,6 @@ end do from_pe = update%recv(m)%pe l = from_pe-mpp_root_pe() - call mpp_recv( msg1(l), glen=1, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_1 ) msg2(l) = msgsize enddo @@ -111,9 +117,13 @@ msgsize = msgsize + (ie-is+1)*(je-js+1) end if end do - call mpp_send( msgsize, plen=1, to_pe=overPtr%pe, tag=COMM_TAG_1 ) + l = overPtr%pe - mpp_root_pe() + msg3(l) = msgsize enddo - call mpp_sync_self(check=EVENT_RECV) + ! mpp_sync_self is desirable but keep mpp_alltoall + ! to exactly follow the duality of mpp_do_update.fh + ! all-to-all may have scaling issues on very large systems + call mpp_alltoall(msg3, 1, msg1, 1) do m = 0, nlist-1 if(msg1(m) .NE. msg2(m)) then @@ -122,14 +132,16 @@ call mpp_error(FATAL, "mpp_do_update: mismatch on send and recv size") endif enddo - call mpp_sync_self() write(outunit,*)"NOTE from mpp_do_update: message sizes are matched between send and recv for domain " & //trim(domain%name) - deallocate(msg1, msg2) + deallocate(msg1, msg2, msg3) endif - !recv + ! Duality of ad code requires checkpoint info: buffer recv size and send pos and msgsize + ! from the forward recv portion of mpp_do_update.fh + ! ref above in line 26 buffer_pos = 0 + do m = 1, update%nrecv overPtr => update%recv(m) if( overPtr%count == 0 )cycle @@ -137,38 +149,24 @@ do n = 1, overPtr%count dir = overPtr%dir(n) if(recv(dir)) then - tMe = overPtr%tileMe(n) is = overPtr%is(n); ie = overPtr%ie(n) js = overPtr%js(n); je = overPtr%je(n) msgsize = msgsize + (ie-is+1)*(je-js+1) - msgsize_send = (ie-is+1)*(je-js+1)*ke*l_size - pos = buffer_pos + msgsize_send - do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) - do k = ke,1,-1 - do j = je, js, -1 - do i = ie, is, -1 - buffer(pos) = field(i,j,k) - field(i,j,k) = 0. - pos = pos - 1 - end do - end do - end do - end do end if end do msgsize = msgsize*ke*l_size if( msgsize.GT.0 )then - to_pe = overPtr%pe - call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=to_pe, tag=COMM_TAG_2 ) buffer_pos = buffer_pos + msgsize end if - end do ! end do m = 1, update%nrecv + end do buffer_recv_size = buffer_pos + send_start_pos = buffer_pos - ! send + ! checkpoint send_msgsize + buffer_pos = buffer_recv_size do m = 1, update%nsend + send_msgsize(m) = 0 overPtr => update%send(m) if( overPtr%count == 0 )cycle pos = buffer_pos @@ -179,19 +177,99 @@ enddo if( msgsize.GT.0 )then msgsize = msgsize*ke*l_size - msgsize_send = msgsize + end if + + do n = 1, overPtr%count + dir = overPtr%dir(n) + if( send(dir) ) then + tMe = overPtr%tileMe(n) + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + pos = pos + (ie-is+1)*(je-js+1)*ke*l_size + endif + end do + + send_msgsize(m) = pos-buffer_pos + buffer_pos = pos + end do + + ! bufferize for backward communication + ! using pack procedures of recv in mpp_do_update.fh + buffer_pos = buffer_recv_size + do m = update%nrecv, 1, -1 + overPtr => update%recv(m) + if( overPtr%count == 0 )cycle + pos = buffer_pos + do n = overPtr%count, 1, -1 + dir = overPtr%dir(n) + if( recv(dir) ) then + tMe = overPtr%tileMe(n) + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + msgsize = (ie-is+1)*(je-js+1)*ke*l_size + pos = buffer_pos - msgsize + buffer_pos = pos + do l=1,l_size ! loop over number of fields + ptr_field = f_addrs(l, tMe) + do k = 1,ke + do j = js, je + do i = is, ie + pos = pos + 1 + buffer(pos) = field(i,j,k) + end do + end do + end do + end do + endif + end do + end do + + ! for duality, mpp_send of mpp_do_update.sh becomes mpp_recv in adjoint + buffer_pos = send_start_pos + do m = 1, update%nsend + msgsize = send_msgsize(m) + if(msgsize == 0) cycle + to_pe = update%send(m)%pe + call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=to_pe, block=.FALSE., tag=COMM_TAG_2 ) + buffer_pos = buffer_pos + msgsize + end do + + ! for duality, mpp_recv of mpp_do_update.sh becomes mpp_send in adjoint + buffer_pos = 0 + do m = 1, update%nrecv + overPtr => update%recv(m) + if( overPtr%count == 0 )cycle + msgsize = 0 + do n = 1, overPtr%count + dir = overPtr%dir(n) + if(recv(dir)) then + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + msgsize = msgsize + (ie-is+1)*(je-js+1) + end if + end do + + msgsize = msgsize*ke*l_size + if( msgsize.GT.0 )then from_pe = overPtr%pe - call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_2 ) + mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize) ) + if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then + write( text,'(i8)' )mpp_domains_stack_hwm + call mpp_error( FATAL, 'MPP_DO_UPDATE: mpp_domains_stack overflow, '// & + 'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.' ) + end if + call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=from_pe, tag=COMM_TAG_2 ) buffer_pos = buffer_pos + msgsize end if - end do ! end do ist = 0,nlist-1 + end do call mpp_sync_self(check=EVENT_RECV) + ! unpack and linear adjoint operation + ! in reverse order of pack process of mpp_do_update.fh buffer_pos = buffer_recv_size - - ! send do m = 1, update%nsend + send_msgsize(m) = 0 overPtr => update%send(m) if( overPtr%count == 0 )cycle pos = buffer_pos @@ -201,7 +279,13 @@ if( send(dir) ) msgsize = msgsize + overPtr%msgsize(n) enddo if( msgsize.GT.0 )then - buffer_pos = pos + msgsize = msgsize*ke*l_size + mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, pos+msgsize ) + if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then + write( text,'(i8)' )mpp_domains_stack_hwm + call mpp_error( FATAL, 'MPP_START_UPDATE_DOMAINS: mpp_domains_stack overflow, ' // & + 'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.') + end if end if do n = 1, overPtr%count @@ -259,15 +343,12 @@ end do end do end do - end select + end select endif end do ! do n = 1, overPtr%count - - msgsize = pos - buffer_pos - if( msgsize.GT.0 )then - buffer_pos = pos - end if - end do ! end do ist = 0,nlist-1 + send_msgsize(m) = pos-buffer_pos + buffer_pos = pos + end do call mpp_sync_self() diff --git a/mpp/include/mpp_get_boundary_ad.fh b/mpp/include/mpp_get_boundary_ad.fh index 56a18120e6..6701d375dd 100644 --- a/mpp/include/mpp_get_boundary_ad.fh +++ b/mpp/include/mpp_get_boundary_ad.fh @@ -21,7 +21,7 @@ !> @addtogroup mpp_domains_mod !> @{ -!> This routine is used to retrieve scalar boundary data for symmetric domain. +!> This routine is used to retrieve scalar ad boundary data for symmetric domain. subroutine MPP_GET_BOUNDARY_AD_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffer, flags, & position, complete, tile_count) type(domain2D), intent(in) :: domain diff --git a/mpp/include/mpp_global_field_ad.fh b/mpp/include/mpp_global_field_ad.fh index 7d948f9366..712d12e48e 100644 --- a/mpp/include/mpp_global_field_ad.fh +++ b/mpp/include/mpp_global_field_ad.fh @@ -21,8 +21,8 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - !> Get a global field from a local field - !! local field may be on compute OR data domain + !> Get a local ad field from a global ad field + !! global field may be on compute OR data domain subroutine MPP_GLOBAL_FIELD_2D_AD_( domain, local, global, flags, position,tile_count, default_data) type(domain2D), intent(in) :: domain MPP_TYPE_, intent(out) :: local(:,:) diff --git a/mpp/include/mpp_sum_mpi_ad.fh b/mpp/include/mpp_sum_mpi_ad.fh index 9b61b9457b..ee28d6c4bf 100644 --- a/mpp/include/mpp_sum_mpi_ad.fh +++ b/mpp/include/mpp_sum_mpi_ad.fh @@ -20,7 +20,7 @@ !* License along with FMS. If not, see . !*********************************************************************** !> Sums array a over the PEs in pelist (all PEs if this argument is omitted) - !! result is also automatically broadcast: all PEs have the sum in a at the end + !! forward array is already summed and broadcasted: all PEs already have the ad sum !! we are using f77-style call: array passed by address and not descriptor; further, !! the f90 conformance check is avoided. !> @ingroup mpp_mod diff --git a/mpp/include/mpp_sum_nocomm_ad.fh b/mpp/include/mpp_sum_nocomm_ad.fh index 9a427aa9d0..263bfde8d6 100644 --- a/mpp/include/mpp_sum_nocomm_ad.fh +++ b/mpp/include/mpp_sum_nocomm_ad.fh @@ -21,7 +21,7 @@ !*********************************************************************** !> Sums array a over the PEs in pelist (all PEs if this argument is omitted) - !! result is also automatically broadcast: all PEs have the sum in a at the end + !! forward array is already summed and broadcasted: all PEs already have the ad sum !! we are using f77-style call: array passed by address and not descriptor; further, !! the f90 conformance check is avoided. subroutine MPP_SUM_AD_( a, length, pelist ) diff --git a/mpp/include/mpp_update_domains2D_ad.fh b/mpp/include/mpp_update_domains2D_ad.fh index e5fc6e7af3..8a876fdba5 100644 --- a/mpp/include/mpp_update_domains2D_ad.fh +++ b/mpp/include/mpp_update_domains2D_ad.fh @@ -19,7 +19,7 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - !> Updates data domain of 2D field whose computational domains have been computed + !> Updates data domain of 2D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_2D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count) MPP_TYPE_, intent(inout) :: field(:,:) @@ -39,7 +39,7 @@ return end subroutine MPP_UPDATE_DOMAINS_AD_2D_ - !> Updates data domain of 3D field whose computational domains have been computed + !> Updates data domain of 3D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_3D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count) MPP_TYPE_, intent(inout) :: field(:,:,:) @@ -176,7 +176,7 @@ end subroutine MPP_UPDATE_DOMAINS_AD_3D_ - !> Updates data domain of 4D field whose computational domains have been computed + !> Updates data domain of 4D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_4D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) MPP_TYPE_, intent(inout) :: field(:,:,:,:) @@ -196,7 +196,7 @@ return end subroutine MPP_UPDATE_DOMAINS_AD_4D_ - !> Updates data domain of 5D field whose computational domains have been computed + !> Updates data domain of 5D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_5D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) MPP_TYPE_, intent(inout) :: field(:,:,:,:,:) @@ -224,7 +224,7 @@ !vector fields subroutine MPP_UPDATE_DOMAINS_AD_2D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) -!updates data domain of 2D field whose computational domains have been computed +!updates data domain of 2D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:), fieldy(:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype @@ -247,7 +247,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_3D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) -!updates data domain of 3D field whose computational domains have been computed +!updates data domain of 3D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype @@ -422,7 +422,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_4D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count ) -!updates data domain of 4D field whose computational domains have been computed +!updates data domain of 4D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype @@ -445,7 +445,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_5D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count ) -!updates data domain of 5D field whose computational domains have been computed +!updates data domain of 5D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype From 2be8aa452ad3e5f43e92c38a64f12d1ae6c43fb8 Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 13 Jul 2023 14:57:40 -0400 Subject: [PATCH 41/51] chore: add prefixed aliases for libfms routines (#1262) BREAKING CHANGE: Any code using the global fms module (libFMS.F90) will break as this adds prefixes to all names in that module. --- libFMS.F90 | 947 +++++++++++++++------- test_fms/mpp/test_domains_utility_mod.F90 | 4 +- test_fms/mpp/test_mpp_chksum.F90 | 5 +- test_fms/mpp/test_mpp_domains.F90 | 2 +- test_fms/mpp/test_mpp_nesting.F90 | 4 +- 5 files changed, 682 insertions(+), 280 deletions(-) diff --git a/libFMS.F90 b/libFMS.F90 index 872c587a8c..02b54df82a 100644 --- a/libFMS.F90 +++ b/libFMS.F90 @@ -28,11 +28,18 @@ !! and routines. Overloaded type operators/assignments cannot be imported individually !! (ie. `use fms, only: OPERATOR(*)` includes any defined '*' operators within FMS). !! -!! Remappings due to conflicts: +!! Renaming scheme: +!! Routines and variables: fms__routine_name +!! Types: FmsModuleNameTypeName !! -!! get_mosaic_tile_grid from mosaic2(fms2_io) => mosaic2_get_mosaic_tile_grid +!! Exceptions (mainly for rep: +!! - Parameter values are kept their original names +!! - If module name is already included (like in init routines) only fms prefix will be added. +!! - Similarly if theres a redundant module name included already included it will not be repeated +!! (ie. mpp_update_domains => fms_mpp_domains_update_domains) +!! - Override interfaces for operators and assignment are provided !! -!! read_data from interpolator_mod(fms2_io) => interpolator_read_data +!! Remappings due to name conflicts: !! !! ZERO from interpolator_mod(mpp_parameter) => INTERPOLATOR_ZERO !! @@ -41,7 +48,7 @@ !! Not in this module: !! !! axis_utils_mod, fms_io_mod, time_interp_external_mod -!! get_grid_version_mpp_mod, mpp_io_mod, mosaic_mod, +!! get_grid_version_mpp_mod, mpp_io_mod, mosaic_mod, & !! fms_mod(partial, old io excluded), drifters modules !! constants_mod (FMSconstants should be used externally) !! grid_mod, mosaic_mod @@ -65,215 +72,458 @@ module fms fms_affinity_set !> amip_interp - use amip_interp_mod, only: amip_interp_init, get_amip_sst, get_amip_ice, & - amip_interp_new,amip_interp_del, amip_interp_type, & - assignment(=), i_sst, j_sst, sst_ncep, sst_anom, & - forecast_mode, use_ncep_sst + use amip_interp_mod, only: fms_amip_interp_init => amip_interp_init, & + fms_amip_interp_get_amip_sst => get_amip_sst, & + fms_amip_interp_get_amip_ice => get_amip_ice, & + fms_amip_interp_new => amip_interp_new, & + fms_amip_interp_del => amip_interp_del, & + FmsAmipInterp_type => amip_interp_type, & + assignment(=), & + fms_amip_interp_i_sst => i_sst, & + fms_amip_interp_j_sst => j_sst, & + fms_amip_interp_sst_ncep => sst_ncep, & + fms_amip_interp_sst_anom => sst_anom, & + fms_amip_interp_forecast_mode=> forecast_mode, & + fms_amip_interp_use_ncep_sst => use_ncep_sst !> astronomy - use astronomy_mod, only: astronomy_init, get_period, set_period, & - set_orbital_parameters, get_orbital_parameters, & - set_ref_date_of_ae, get_ref_date_of_ae, & - diurnal_solar, daily_mean_solar, annual_mean_solar, & - astronomy_end, universal_time, orbital_time + use astronomy_mod, only: fms_astronomy_init => astronomy_init, & + fms_astronomy_get_period => get_period, & + fms_astronomy_set_period => set_period, & + fms_astronomy_set_orbital_parameters => set_orbital_parameters, & + fms_astronomy_get_orbital_parameters => get_orbital_parameters, & + fms_astronomy_set_ref_date_of_ae => set_ref_date_of_ae, & + fms_astronomy_get_ref_date_of_ae => get_ref_date_of_ae, & + fms_astronomy_diurnal_solar => diurnal_solar, & + fms_astronomy_daily_mean_solar => daily_mean_solar, & + fms_astronomy_annual_mean_solar => annual_mean_solar, & + fms_astronomy_end => astronomy_end, & + fms_astronomy_universal_time => universal_time, & + fms_astronomy_orbital_time => orbital_time !> axis_utils - use axis_utils2_mod, only: get_axis_cart, get_axis_modulo, lon_in_range, & - tranlon, frac_index, nearest_index, interp_1d, & - get_axis_modulo_times, axis_edges + use axis_utils2_mod, only: fms_axis_utils2_get_axis_cart => get_axis_cart, & + fms_axis_utils2_get_axis_modulo => get_axis_modulo, & + fms_axis_utils2_lon_in_range => lon_in_range, & + fms_axis_utils2_tranlon => tranlon, & + fms_axis_utils2_frac_index => frac_index, & + fms_axis_utils2_nearest_index => nearest_index, & + fms_axis_utils2_interp_1d => interp_1d, & + fms_axis_utils2_get_axis_modulo_times => get_axis_modulo_times, & + fms_axis_utils2_axis_edges => axis_edges !>block_control - use block_control_mod, only: block_control_type, define_blocks, & - define_blocks_packed + use block_control_mod, only: FmsBlockControl_type => block_control_type, & + fms_block_control_define_blocks => define_blocks, & + fms_block_control_define_blocks_packed => define_blocks_packed !> column_diagnostics - use column_diagnostics_mod, only: column_diagnostics_init, & - initialize_diagnostic_columns, & - column_diagnostics_header, & - close_column_diagnostics_units + use column_diagnostics_mod, only: fms_column_diagnostics_init => column_diagnostics_init, & + fms_column_diagnostics_initialize_diagnostic_columns => & + initialize_diagnostic_columns, & + fms_column_diagnostics_header => column_diagnostics_header, & + fms_column_diagnostics_close_units => close_column_diagnostics_units !> coupler - use coupler_types_mod, only: coupler_types_init, coupler_type_copy, & - coupler_type_spawn, coupler_type_set_diags, & - coupler_type_write_chksums, coupler_type_send_data, & - coupler_type_data_override, coupler_type_register_restarts, & - coupler_type_restore_state, coupler_type_increment_data, & - coupler_type_rescale_data, coupler_type_copy_data, & - coupler_type_redistribute_data, coupler_type_destructor, & - coupler_type_initialized, coupler_type_extract_data, & - coupler_type_set_data,coupler_type_copy_1d_2d, & - coupler_type_copy_1d_3d, coupler_3d_values_type, & - coupler_3d_field_type, coupler_3d_bc_type, & - coupler_2d_values_type, coupler_2d_field_type, & - coupler_2d_bc_type, coupler_1d_values_type, & - coupler_1d_field_type, coupler_1d_bc_type, & - ind_pcair, ind_u10, ind_psurf, ind_alpha, ind_csurf, & - ind_sc_no, ind_flux, ind_deltap, ind_kw, ind_flux0, & - ind_deposition, ind_runoff - use ensemble_manager_mod, only: ensemble_manager_init, get_ensemble_id, get_ensemble_size, & - get_ensemble_pelist, ensemble_pelist_setup, & - get_ensemble_filter_pelist - use atmos_ocean_fluxes_mod, only: atmos_ocean_fluxes_init, atmos_ocean_type_fluxes_init, & - aof_set_coupler_flux + use coupler_types_mod, only: fms_coupler_types_init => coupler_types_init, & + fms_coupler_type_copy => coupler_type_copy, & + fms_coupler_type_spawn => coupler_type_spawn, & + fms_coupler_type_set_diags => coupler_type_set_diags, & + fms_coupler_type_write_chksums => coupler_type_write_chksums, & + fms_coupler_type_send_data => coupler_type_send_data, & + fms_coupler_type_data_override => coupler_type_data_override, & + fms_coupler_type_register_restarts => coupler_type_register_restarts, & + fms_coupler_type_restore_state => coupler_type_restore_state, & + fms_coupler_type_increment_data => coupler_type_increment_data, & + fms_coupler_type_rescale_data => coupler_type_rescale_data, & + fms_coupler_type_copy_data => coupler_type_copy_data, & + fms_coupler_type_redistribute_data => coupler_type_redistribute_data, & + fms_coupler_type_destructor => coupler_type_destructor, & + fms_coupler_type_initialized => coupler_type_initialized, & + fms_coupler_type_extract_data => coupler_type_extract_data, & + fms_coupler_type_set_data => coupler_type_set_data, & + fms_coupler_type_copy_1d_2d => coupler_type_copy_1d_2d, & + fms_coupler_type_copy_1d_3d => coupler_type_copy_1d_3d, & + FmsCoupler3dValues_type => coupler_3d_values_type, & + FmsCoupler3dField_type => coupler_3d_field_type, & + FmsCoupler3dBC_type => coupler_3d_bc_type, & + FmsCoupler2dValues_type => coupler_2d_values_type, & + FmsCoupler2dField_type => coupler_2d_field_type, & + FmsCoupler2dBC_type => coupler_2d_bc_type, & + FmsCoupler1dValues_type => coupler_1d_values_type, & + FmsCoupler1dField_type => coupler_1d_field_type, & + FmsCoupler1dBC_type => coupler_1d_bc_type, & + fms_coupler_ind_pcair => ind_pcair, & + fms_coupler_ind_u10 => ind_u10, & + fms_coupler_ind_psurf => ind_psurf, & + fms_coupler_ind_alpha => ind_alpha, & + fms_coupler_ind_csurf => ind_csurf, & + fms_coupler_ind_sc_no => ind_sc_no, & + fms_coupler_ind_flux => ind_flux, & + fms_coupler_ind_deltap => ind_deltap, & + fms_coupler_ind_kw => ind_kw, & + fms_coupler_ind_flux0 => ind_flux0, & + fms_coupler_ind_deposition => ind_deposition,& + fms_coupler_ind_runoff => ind_runoff + use ensemble_manager_mod, only: fms_ensemble_manager_init => ensemble_manager_init, & + fms_ensemble_manager_get_ensemble_id => get_ensemble_id, & + fms_ensemble_manager_get_ensemble_size => get_ensemble_size, & + fms_ensemble_manager_get_ensemble_pelist => get_ensemble_pelist, & + fms_ensemble_manager_ensemble_pelist_setup => ensemble_pelist_setup, & + fms_ensemble_manager_get_ensemble_filter_pelist => get_ensemble_filter_pelist + use atmos_ocean_fluxes_mod, only: fms_atmos_ocean_fluxes_init => atmos_ocean_fluxes_init, & + fms_atmos_ocean_type_fluxes_init => atmos_ocean_type_fluxes_init, & + fms_atmos_ocean_fluxes_set_coupler_flux => aof_set_coupler_flux !> data_override - use data_override_mod, only: data_override_init, data_override, & - data_override_unset_domains, data_override_UG + use data_override_mod, only: fms_data_override_init => data_override_init, & + fms_data_override => data_override, & + fms_data_override_unset_domains => data_override_unset_domains, & + fms_data_override_UG => data_override_UG !> diag_integral - use diag_integral_mod, only: diag_integral_init, diag_integral_field_init, & - sum_diag_integral_field, diag_integral_output, & - diag_integral_end + use diag_integral_mod, only: fms_diag_integral_init => diag_integral_init, & + fms_diag_integral_field_init => diag_integral_field_init, & + fms_sum_diag_integral_field => sum_diag_integral_field, & + fms_diag_integral_output => diag_integral_output, & + fms_diag_integral_end => diag_integral_end !> diag_manager !! includes imports from submodules made public - use diag_manager_mod, only: diag_manager_init, send_data, send_tile_averaged_data, & - diag_manager_end, register_diag_field, register_static_field, & - diag_axis_init, get_base_time, get_base_date, need_data, & - DIAG_ALL, DIAG_OCEAN, DIAG_OTHER, get_date_dif, DIAG_SECONDS,& - DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, & - get_diag_global_att, set_diag_global_att, diag_field_add_attribute, & - diag_field_add_cell_measures, get_diag_field_id, & - diag_axis_add_attribute, diag_grid_init, diag_grid_end, & - diag_manager_set_time_end, diag_send_complete, & - diag_send_complete_instant, DIAG_FIELD_NOT_FOUND, & - CMOR_MISSING_VALUE, null_axis_id + use diag_manager_mod, only: fms_diag_init => diag_manager_init, & + fms_diag_send_data => send_data, & + fms_diag_send_tile_averaged_data => send_tile_averaged_data, & + fms_diag_end => diag_manager_end, & + fms_diag_register_diag_field => register_diag_field, & + fms_diag_register_static_field => register_static_field, & + fms_diag_axis_init => diag_axis_init, & + fms_diag_get_base_time => get_base_time, & + fms_diag_get_base_date => get_base_date, & + fms_diag_need_data => need_data, & + DIAG_ALL, & + DIAG_OCEAN, & + DIAG_OTHER, & + fms_get_date_dif => get_date_dif, & + DIAG_SECONDS,& + DIAG_MINUTES, & + DIAG_HOURS, & + DIAG_DAYS, & + DIAG_MONTHS, & + DIAG_YEARS, & + fms_diag_get_global_att => get_diag_global_att, & + fms_diag_set_global_att => set_diag_global_att, & + fms_diag_field_add_attribute => diag_field_add_attribute, & + fms_diag_field_add_cell_measures => diag_field_add_cell_measures, & + fms_diag_get_field_id => get_diag_field_id, & + fms_diag_axis_add_attribute => diag_axis_add_attribute, & + fms_diag_grid_init => diag_grid_init, & + fms_diag_grid_end => diag_grid_end, & + fms_diag_set_time_end => diag_manager_set_time_end, & + fms_diag_send_complete => diag_send_complete, & + fms_diag_send_complete_instant => diag_send_complete_instant, & + DIAG_FIELD_NOT_FOUND, & + CMOR_MISSING_VALUE, & + null_axis_id !> exchange - use xgrid_mod, only: xmap_type, setup_xmap, set_frac_area, put_to_xgrid, & - get_from_xgrid, xgrid_count, some, conservation_check, & - xgrid_init, AREA_ATM_SPHERE, AREA_OCN_SPHERE, AREA_ATM_MODEL, & - AREA_OCN_MODEL, get_ocean_model_area_elements, grid_box_type, & - get_xmap_grid_area, put_to_xgrid_ug, get_from_xgrid_ug, & - set_frac_area_ug, FIRST_ORDER, SECOND_ORDER, stock_move_ug, & - stock_move, stock_type, stock_print, get_index_range, & - stock_integrate_2d + use xgrid_mod, only: FmsXgridXmap_type => xmap_type, & + fms_xgrid_setup_xmap => setup_xmap, & + fms_xgrid_set_frac_area => set_frac_area, & + fms_xgrid_put_to_xgrid => put_to_xgrid, & + fms_xgrid_get_from_xgrid => get_from_xgrid, & + fms_xgrid_count => xgrid_count, & + fms_xgrid_some => some, & + fms_xgrid_conservation_check => conservation_check, & + fms_xgrid_init => xgrid_init, & + AREA_ATM_SPHERE, AREA_OCN_SPHERE, AREA_ATM_MODEL, AREA_OCN_MODEL, & + fms_xgrid_get_ocean_model_area_elements => get_ocean_model_area_elements, & + FmsXgridGridBox_type => grid_box_type, & + fms_xgrid_get_xmap_grid_area => get_xmap_grid_area, & + fms_xgrid_put_to_xgrid_ug => put_to_xgrid_ug, & + fms_xgrid_get_from_xgrid_ug => get_from_xgrid_ug, & + fms_xgrid_set_frac_area_ug => set_frac_area_ug, & + FIRST_ORDER, SECOND_ORDER, & + fms_xgrid_stock_move_ug => stock_move_ug, & + fms_xgrid_stock_move => stock_move, & + FmsXgridStock_type => stock_type, & + fms_xgrid_stock_print => stock_print, & + fms_xgrid_get_index_range => get_index_range, & + fms_xgrid_stock_integrate_2d => stock_integrate_2d use stock_constants_mod, only: NELEMS, ISTOCK_WATER, ISTOCK_HEAT, ISTOCK_SALT, & - ISTOCK_TOP, ISTOCK_BOTTOM, ISTOCK_SIDE, stocks_file, & - stocks_report, stocks_report_init, stocks_set_init_time, & - atm_stock, ocn_stock, lnd_stock, ice_stock + ISTOCK_TOP, ISTOCK_BOTTOM, ISTOCK_SIDE, & + fms_stock_constants_stocks_file => stocks_file, & + fms_stock_constants_stocks_report => stocks_report, & + fms_stocks_report_init => stocks_report_init, & + fms_stocks_set_init_time => stocks_set_init_time, & + fms_stock_constants_atm_stock => atm_stock, & + fms_stock_constants_ocn_stock => ocn_stock, & + fms_stock_constants_lnd_stock => lnd_stock, & + fms_stock_constants_ice_stock => ice_stock !> field manager - use field_manager_mod, only: field_manager_init, field_manager_end, find_field_index, & - get_field_info, & - get_field_method, get_field_methods, parse, fm_change_list, & - fm_change_root, fm_dump_list, fm_exists, fm_get_index, & - fm_get_current_list, fm_get_length, fm_get_type, fm_get_value, & - fm_init_loop, & - fm_loop_over_list, fm_new_list, fm_new_value, & - fm_reset_loop, fm_return_root, & - fm_modify_name, fm_query_method, fm_find_methods, fm_copy_list, & - fm_field_name_len, fm_path_name_len, & - fm_string_len, fm_type_name_len, NUM_MODELS, NO_FIELD, & - MODEL_ATMOS, MODEL_OCEAN, MODEL_LAND, MODEL_ICE, MODEL_COUPLER, & - method_type, method_type_short, & - method_type_very_short, fm_list_iter_type, default_method - use fm_util_mod, only: fm_util_start_namelist, fm_util_end_namelist, & - fm_util_check_for_bad_fields, fm_util_set_caller, & - fm_util_reset_caller, fm_util_set_no_overwrite, & - fm_util_reset_no_overwrite, fm_util_set_good_name_list, & - fm_util_reset_good_name_list, fm_util_get_length, & - fm_util_get_integer, fm_util_get_logical, fm_util_get_real, & - fm_util_get_string, fm_util_get_integer_array, & - fm_util_get_logical_array, fm_util_get_real_array, & - fm_util_get_string_array, fm_util_set_value, & - fm_util_set_value_integer_array, fm_util_set_value_logical_array, & - fm_util_set_value_real_array, fm_util_set_value_string_array, & - fm_util_set_value_integer, fm_util_set_value_logical, & - fm_util_set_value_real, fm_util_set_value_string, & - fm_util_get_index_list, fm_util_get_index_string, & - fm_util_default_caller + use field_manager_mod, only: fms_field_manager_init => field_manager_init, & + fms_field_manager_end => field_manager_end, & + fms_field_manager_find_field_index => find_field_index, & + fms_field_manager_get_field_info => get_field_info, & + fms_field_manager_get_field_method => get_field_method, & + fms_field_manager_get_field_methods => get_field_methods, & + fms_field_manager_parse => parse, & + fms_field_manager_fm_change_list => fm_change_list, & + fms_field_manager_fm_change_root => fm_change_root, & + fms_field_manager_fm_dump_list => fm_dump_list, & + fms_field_manager_fm_exists => fm_exists, & + fms_field_manager_fm_get_index => fm_get_index, & + fms_field_manager_fm_get_current_list => fm_get_current_list, & + fms_field_manager_fm_get_length => fm_get_length, & + fms_field_manager_fm_get_type => fm_get_type, & + fms_field_manager_fm_get_value => fm_get_value, & + fms_field_manager_fm_init_loop => fm_init_loop, & + fms_field_manager_fm_loop_over_list => fm_loop_over_list, & + fms_field_manager_fm_new_list => fm_new_list, & + fms_field_manager_fm_new_value => fm_new_value, & + fms_field_manager_fm_reset_loop => fm_reset_loop, & + fms_field_manager_fm_return_root => fm_return_root, & + fms_field_manager_fm_modify_name => fm_modify_name, & + fms_field_manager_fm_query_method => fm_query_method, & + fms_field_manager_fm_find_methods => fm_find_methods, & + fms_field_manager_fm_copy_list => fm_copy_list, & + fms_field_manager_fm_field_name_len => fm_field_name_len, & + fms_field_manager_fm_path_name_len => fm_path_name_len, & + fms_field_manager_fm_string_len => fm_string_len, & + fms_field_manager_fm_type_name_len => fm_type_name_len, & + NUM_MODELS, NO_FIELD, MODEL_ATMOS, MODEL_OCEAN, MODEL_LAND, MODEL_ICE, MODEL_COUPLER, & + FmsFieldManagerMethod_type => method_type, & + FmsFieldManagerMethodShort_type => method_type_short, & + FmsFieldManagerMethodVeryShort_type => method_type_very_short, & + FmsFieldManagerListIterator_type => fm_list_iter_type, & + fms_field_manager_default_method => default_method + use fm_util_mod, only: fms_fm_util_start_namelist => fm_util_start_namelist, & + fms_fm_util_end_namelist => fm_util_end_namelist, & + fms_fm_util_check_for_bad_fields => fm_util_check_for_bad_fields, & + fms_fm_util_set_caller => fm_util_set_caller, & + fms_fm_util_reset_caller => fm_util_reset_caller, & + fms_fm_util_set_no_overwrite => fm_util_set_no_overwrite, & + fms_fm_util_reset_no_overwrite => fm_util_reset_no_overwrite, & + fms_fm_util_set_good_name_list => fm_util_set_good_name_list, & + fms_fm_util_reset_good_name_list => fm_util_reset_good_name_list, & + fms_fm_util_get_length => fm_util_get_length, & + fms_fm_util_get_integer => fm_util_get_integer, & + fms_fm_util_get_logical => fm_util_get_logical, & + fms_fm_util_get_real => fm_util_get_real, & + fms_fm_util_get_string => fm_util_get_string, & + fms_fm_util_get_integer_array => fm_util_get_integer_array, & + fms_fm_util_get_logical_array => fm_util_get_logical_array, & + fms_fm_util_get_real_array => fm_util_get_real_array, & + fms_fm_util_get_string_array => fm_util_get_string_array, & + fms_fm_util_set_value => fm_util_set_value, & + fms_fm_util_set_value_integer_array => fm_util_set_value_integer_array, & + fms_fm_util_set_value_logical_array => fm_util_set_value_logical_array, & + fms_fm_util_set_value_real_array => fm_util_set_value_real_array, & + fms_fm_util_set_value_string_array => fm_util_set_value_string_array, & + fms_fm_util_set_value_integer => fm_util_set_value_integer, & + fms_fm_util_set_value_logical => fm_util_set_value_logical, & + fms_fm_util_set_value_real => fm_util_set_value_real, & + fms_fm_util_set_value_string => fm_util_set_value_string, & + fms_fm_util_get_index_list => fm_util_get_index_list, & + fms_fm_util_get_index_string => fm_util_get_index_string, & + fms_fm_util_default_caller => fm_util_default_caller !> fms2_io + !! TODO need to see opinions on these + !! not sure if we need fms_ prefix for routines + !! types do not follow our typical naming convention(no _type and uses camel case instead of _ spacing) use fms2_io_mod, only: unlimited, FmsNetcdfFile_t, FmsNetcdfDomainFile_t, & - FmsNetcdfUnstructuredDomainFile_t, open_file, open_virtual_file, & - close_file, register_axis, register_field, register_restart_field, & - write_data, read_data, write_restart, write_new_restart, & - read_restart, read_new_restart, global_att_exists, & - variable_att_exists, register_global_attribute, & - register_variable_attribute, get_global_attribute, & - get_variable_attribute, get_num_dimensions, & - get_dimension_names, dimension_exists, is_dimension_unlimited, & - get_dimension_size, get_num_variables, get_variable_names, & - variable_exists, get_variable_num_dimensions, & - get_variable_dimension_names, get_variable_size, & - get_compute_domain_dimension_indices, & - get_global_io_domain_indices, Valid_t, get_valid, is_valid, & - get_unlimited_dimension_name, get_variable_unlimited_dimension_index, & - file_exists, compressed_start_and_count, get_variable_sense, & - get_variable_missing, get_variable_units, get_time_calendar, & - open_check, is_registered_to_restart, check_if_open, & - set_fileobj_time_name, is_dimension_registered, & - fms2_io_init, get_mosaic_tile_grid, & - write_restart_bc, read_restart_bc, get_filename_appendix, & !> 2021.02-a1 - set_filename_appendix, get_instance_filename, & - nullify_filename_appendix, ascii_read, get_mosaic_tile_file, & - parse_mask_table + FmsNetcdfUnstructuredDomainFile_t, & + Valid_t, & + fms2_io_open_file => open_file, & + fms2_io_open_virtual_file => open_virtual_file, & + fms2_io_close_file => close_file, & + fms2_io_register_axis => register_axis, & + fms2_io_register_field => register_field, & + fms2_io_register_restart_field => register_restart_field, & + fms2_io_write_data => write_data, & + fms2_io_read_data => read_data, & + fms2_io_write_restart => write_restart, & + fms2_io_write_new_restart => write_new_restart, & + fms2_io_read_restart => read_restart, & + fms2_io_read_new_restart => read_new_restart, & + fms2_io_global_att_exists => global_att_exists, & + fms2_io_variable_att_exists => variable_att_exists, & + fms2_io_register_global_attribute => register_global_attribute, & + fms2_io_register_variable_attribute => register_variable_attribute, & + fms2_io_get_global_attribute => get_global_attribute, & + fms2_io_get_variable_attribute => get_variable_attribute, & + fms2_io_get_num_dimensions => get_num_dimensions, & + fms2_io_get_dimension_names => get_dimension_names, & + fms2_io_dimension_exists => dimension_exists, & + fms2_io_is_dimension_unlimited => is_dimension_unlimited, & + fms2_io_get_dimension_size => get_dimension_size, & + fms2_io_get_num_variables => get_num_variables, & + fms2_io_get_variable_names => get_variable_names, & + fms2_io_variable_exists => variable_exists, & + fms2_io_get_variable_num_dimensions => get_variable_num_dimensions, & + fms2_io_get_variable_dimension_names => get_variable_dimension_names, & + fms2_io_get_variable_size => get_variable_size, & + fms2_io_get_compute_domain_dimension_indices => get_compute_domain_dimension_indices, & + fms2_io_get_global_io_domain_indices => get_global_io_domain_indices, & + fms2_io_get_valid => get_valid, & + fms2_io_is_valid => is_valid, & + fms2_io_get_unlimited_dimension_name => get_unlimited_dimension_name, & + fms2_io_get_variable_unlimited_dimension_index => get_variable_unlimited_dimension_index, & + fms2_io_file_exists => file_exists, & + fms2_io_compressed_start_and_count => compressed_start_and_count, & + fms2_io_get_variable_sense => get_variable_sense, & + fms2_io_get_variable_missing => get_variable_missing, & + fms2_io_get_variable_units => get_variable_units, & + fms2_io_get_time_calendar => get_time_calendar, & + fms2_io_open_check => open_check, & + fms2_io_is_registered_to_restart => is_registered_to_restart, & + fms2_io_check_if_open => check_if_open, & + fms2_io_set_fileobj_time_name => set_fileobj_time_name, & + fms2_io_is_dimension_registered => is_dimension_registered, & + fms2_io_fms2_io_init => fms2_io_init, & + fms2_io_get_mosaic_tile_grid => get_mosaic_tile_grid, & + fms2_io_write_restart_bc => write_restart_bc, & + fms2_io_read_restart_bc => read_restart_bc, & + fms2_io_get_filename_appendix => get_filename_appendix, & + fms2_io_set_filename_appendix => set_filename_appendix, & + fms2_io_get_instance_filename => get_instance_filename, & + fms2_io_nullify_filename_appendix => nullify_filename_appendix, & + fms2_io_ascii_read => ascii_read, & + fms2_io_get_mosaic_tile_file => get_mosaic_tile_file, & + fms2_io_parse_mask_table => parse_mask_table ! used via fms2_io - ! fms_io_utils_mod, fms_netcdf_domain_io_mod, netcdf_io_mod, + ! fms_io_utils_mod, fms_netcdf_domain_io_mod, netcdf_io_mod, & ! fms_netcdf_unstructured_domain_io_mod, blackboxio !> fms !! routines that don't conflict with fms2_io - use fms_mod, only: fms_init, fms_end, error_mesg, fms_error_handler, check_nml_error, & - monotonic_array, string_array_index, clock_flag_default, & - print_memory_usage, write_version_number + use fms_mod, only: fms_init, fms_end, error_mesg, fms_error_handler, & + check_nml_error, & + fms_monotonic_array => monotonic_array, fms_string_array_index => string_array_index, & + fms_clock_flag_default => clock_flag_default, fms_print_memory_usage => print_memory_usage, & + fms_write_version_number => write_version_number !> horiz_interp - use horiz_interp_mod, only: horiz_interp, horiz_interp_new, horiz_interp_del, & - horiz_interp_init, horiz_interp_end - use horiz_interp_type_mod, only: horiz_interp_type, assignment(=), CONSERVE, & - BILINEAR, SPHERICA, BICUBIC, stats + use horiz_interp_mod, only: fms_horiz_interp => horiz_interp, fms_horiz_interp_new => horiz_interp_new, & + fms_horiz_interp_del => horiz_interp_del, fms_horiz_interp_init => horiz_interp_init, & + fms_horiz_interp_end => horiz_interp_end + use horiz_interp_type_mod, only: FmsHorizInterp_type => horiz_interp_type, & + assignment(=), CONSERVE, BILINEAR, SPHERICA, BICUBIC, & + fms_horiz_interp_type_stats => stats !! used via horiz_interp ! horiz_interp_bicubic_mod, horiz_interp_bilinear_mod ! horiz_interp_conserve_mod, horiz_interp_spherical_mod !> interpolator - use interpolator_mod, only: interpolator_init, interpolator, interpolate_type_eq, & - obtain_interpolator_time_slices, unset_interpolator_time_flag, & - interpolator_end, init_clim_diag, query_interpolator, & - interpolate_type, CONSTANT, & - INTERP_WEIGHTED_P, INTERP_LINEAR_P, INTERP_LOG_P, & - INTERPOLATOR_ZERO=>ZERO, & !! conflicts with mpp_parameter's ZERO - interpolator_read_data=>read_data !! conflicts with fms2_io interface + use interpolator_mod, only: fms_interpolator_init => interpolator_init, & + fms_interpolator => interpolator, & + fms_interpolate_type_eq => interpolate_type_eq, & + fms_interpolator_obtain_interpolator_time_slices => obtain_interpolator_time_slices, & + fms_interpolator_unset_interpolator_time_flag => unset_interpolator_time_flag, & + fms_interpolator_end => interpolator_end, & + fms_interpolator_init_clim_diag => init_clim_diag, & + fms_interpolator_query_interpolator => query_interpolator, & + FmsInterpolate_type => interpolate_type, & + CONSTANT, INTERP_WEIGHTED_P, INTERP_LINEAR_P, INTERP_LOG_P, & + FMS_INTERPOLATOR_ZERO=>ZERO, & !! conflicts with mpp_parameter's ZERO + fms_interpolator_read_data=>read_data !> memutils - use memutils_mod, only: memutils_init, print_memuse_stats + use memutils_mod, only: fms_memutils_init => memutils_init, & + fms_memutils_print_memuse_stats => print_memuse_stats !> monin_obukhov - use monin_obukhov_mod, only: monin_obukhov_init, monin_obukhov_end, & - mo_drag, mo_profile, mo_diff, stable_mix - use monin_obukhov_inter, only: monin_obukhov_diff, monin_obukhov_drag_1d, & - monin_obukhov_solve_zeta, monin_obukhov_derivative_t, & - monin_obukhov_derivative_m, monin_obukhov_profile_1d, & - monin_obukhov_integral_m, monin_obukhov_integral_tq, & - monin_obukhov_stable_mix + use monin_obukhov_mod, only: fms_monin_obukhov_init => monin_obukhov_init, & + fms_monin_obukhov_end => monin_obukhov_end, & + fms_monin_obukhov_mo_drag => mo_drag, & + fms_monin_obukhov_mo_profile => mo_profile, & + fms_monin_obukhov_mo_diff => mo_diff, & + fms_monin_obukhov_stable_mix => stable_mix + use monin_obukhov_inter, only: fms_monin_obukhov_inter_diff => monin_obukhov_diff, & + fms_monin_obukhov_inter_drag_1d => monin_obukhov_drag_1d, & + fms_monin_obukhov_inter_solve_zeta => monin_obukhov_solve_zeta, & + fms_monin_obukhov_inter_derivative_t => monin_obukhov_derivative_t, & + fms_monin_obukhov_inter_derivative_m => monin_obukhov_derivative_m, & + fms_monin_obukhov_inter_profile_1d => monin_obukhov_profile_1d, & + fms_monin_obukhov_inter_integral_m => monin_obukhov_integral_m, & + fms_monin_obukhov_inter_integral_tq => monin_obukhov_integral_tq, & + fms_monin_obukhov_inter_stable_mix => monin_obukhov_stable_mix !> mosaic - use mosaic2_mod, only: get_mosaic_ntiles, get_mosaic_ncontacts, & - get_mosaic_grid_sizes, get_mosaic_contact, & - get_mosaic_xgrid_size, get_mosaic_xgrid, & - calc_mosaic_grid_area, calc_mosaic_grid_great_circle_area, & - is_inside_polygon, & - mosaic2_get_mosaic_tile_grid => get_mosaic_tile_grid !overloaded in fms2_io - use grid2_mod, only: get_grid_ntiles, get_grid_size, get_grid_cell_centers, & - get_grid_cell_vertices, get_grid_cell_Area, get_grid_comp_area, & - define_cube_mosaic, get_great_circle_algorithm, grid_init, grid_end - use gradient_mod, only: gradient_cubic, calc_cubic_grid_info + use mosaic2_mod, only: fms_mosaic2_get_mosaic_ntiles => get_mosaic_ntiles, & + fms_mosaic2_get_mosaic_ncontacts => get_mosaic_ncontacts, & + fms_mosaic2_get_mosaic_grid_sizes => get_mosaic_grid_sizes, & + fms_mosaic2_get_mosaic_contact => get_mosaic_contact, & + fms_mosaic2_get_mosaic_xgrid_size => get_mosaic_xgrid_size, & + fms_mosaic2_get_mosaic_xgrid => get_mosaic_xgrid, & + fms_mosaic2_calc_mosaic_grid_area => calc_mosaic_grid_area, & + fms_mosaic2_calc_mosaic_grid_great_circle_area => calc_mosaic_grid_great_circle_area, & + fms_mosaic2_is_inside_polygon => is_inside_polygon, & + fms_mosaic2_get_mosaic_tile_grid => get_mosaic_tile_grid !overloaded in fms2_io + use grid2_mod, only: fms_grid2_get_grid_ntiles => get_grid_ntiles, & + fms_grid2_get_grid_size => get_grid_size, & + fms_grid2_get_grid_cell_centers => get_grid_cell_centers, & + fms_grid2_get_grid_cell_vertices => get_grid_cell_vertices, & + fms_grid2_get_grid_cell_Area => get_grid_cell_Area, & + fms_grid2_get_grid_comp_area => get_grid_comp_area, & + fms_grid2_define_cube_mosaic => define_cube_mosaic, & + fms_grid2_get_great_circle_algorithm => get_great_circle_algorithm, & + fms_grid2_grid_init => grid_init, & + fms_grid2_end => grid_end + use gradient_mod, only: fms_gradient_cubic => gradient_cubic, & + fms_gradient_calc_cubic_grid_info => calc_cubic_grid_info !> mpp - use mpp_mod, only: stdin, stdout, stderr, & - stdlog, lowercase, uppercase, mpp_error, mpp_error_state, & - mpp_set_warn_level, mpp_sync, mpp_sync_self, mpp_set_stack_size, & - mpp_pe, mpp_npes, mpp_root_pe, mpp_set_root_pe, mpp_declare_pelist, & - mpp_get_current_pelist, mpp_set_current_pelist, & - mpp_get_current_pelist_name, mpp_clock_id, mpp_clock_set_grain, & - mpp_record_timing_data, get_unit, read_ascii_file, read_input_nml, & - mpp_clock_begin, mpp_clock_end, get_ascii_file_num_lines, & - mpp_record_time_start, mpp_record_time_end, mpp_chksum, & - mpp_max, mpp_min, mpp_sum, mpp_transmit, mpp_send, mpp_recv, & - mpp_sum_ad, mpp_broadcast, mpp_init, mpp_exit, mpp_gather, & - mpp_scatter, mpp_alltoall, mpp_type, mpp_byte, mpp_type_create, & - mpp_type_free, input_nml_file + use mpp_mod, only: fms_mpp_stdin => stdin, & + fms_mpp_stdout => stdout, & + fms_mpp_stderr => stderr, & + fms_mpp_stdlog => stdlog, & + fms_mpp_lowercase => lowercase, & + fms_mpp_uppercase => uppercase, & + fms_mpp_error => mpp_error, & + fms_mpp_error_state => mpp_error_state, & + fms_mpp_set_warn_level => mpp_set_warn_level, & + fms_mpp_sync => mpp_sync, & + fms_mpp_sync_self => mpp_sync_self, & + fms_mpp_set_stack_size => mpp_set_stack_size, & + fms_mpp_pe => mpp_pe, & + fms_mpp_npes => mpp_npes, & + fms_mpp_root_pe => mpp_root_pe, & + fms_mpp_set_root_pe => mpp_set_root_pe, & + fms_mpp_declare_pelist => mpp_declare_pelist, & + fms_mpp_get_current_pelist => mpp_get_current_pelist, & + fms_mpp_set_current_pelist => mpp_set_current_pelist, & + fms_mpp_get_current_pelist_name => mpp_get_current_pelist_name, & + fms_mpp_clock_id => mpp_clock_id, & + fms_mpp_clock_set_grain => mpp_clock_set_grain, & + fms_mpp_record_timing_data => mpp_record_timing_data, & + fms_mpp_get_unit => get_unit, & + fms_mpp_read_ascii_file => read_ascii_file, & + fms_mpp_read_input_nml => read_input_nml, & + fms_mpp_clock_begin => mpp_clock_begin, & + fms_mpp_clock_end => mpp_clock_end, & + fms_mpp_get_ascii_file_num_lines => get_ascii_file_num_lines, & + fms_mpp_record_time_start => mpp_record_time_start, & + fms_mpp_record_time_end => mpp_record_time_end, & + fms_mpp_chksum => mpp_chksum, & + fms_mpp_max => mpp_max, & + fms_mpp_min => mpp_min, & + fms_mpp_sum => mpp_sum, & + fms_mpp_transmit => mpp_transmit, & + fms_mpp_send => mpp_send, & + fms_mpp_recv => mpp_recv, & + fms_mpp_sum_ad => mpp_sum_ad, & + fms_mpp_broadcast => mpp_broadcast, & + fms_mpp_init => mpp_init, & + fms_mpp_exit => mpp_exit, & + fms_mpp_gather => mpp_gather, & + fms_mpp_scatter => mpp_scatter, & + fms_mpp_alltoall => mpp_alltoall, & + FmsMpp_type => mpp_type, & + FmsMpp_byte => mpp_byte, & + fms_mpp_type_create => mpp_type_create, & + fms_mpp_type_free => mpp_type_free, & + fms_mpp_input_nml_file => input_nml_file use mpp_parameter_mod,only:MAXPES, MPP_VERBOSE, MPP_DEBUG, ALL_PES, ANY_PE, NULL_PE, & NOTE, WARNING, FATAL, MPP_WAIT, MPP_READY, MAX_CLOCKS, & MAX_EVENT_TYPES, MAX_EVENTS, MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, & @@ -298,74 +548,161 @@ module fms MAX_DOMAIN_FIELDS, MAX_TILES, ZERO, NINETY, MINUS_NINETY, & ONE_HUNDRED_EIGHTY, NONBLOCK_UPDATE_TAG, EDGEUPDATE, EDGEONLY, & NONSYMEDGEUPDATE, NONSYMEDGE - use mpp_data_mod, only: stat, mpp_stack, ptr_stack, status, ptr_status, sync, & - ptr_sync, mpp_from_pe, ptr_from, remote_Data_loc, & - ptr_remote, mpp_domains_stack, ptr_domains_stack, & - mpp_domains_stack_nonblock, ptr_domains_stack_nonblock - use mpp_utilities_mod, only: mpp_array_global_min_max - use mpp_memutils_mod, only: mpp_print_memuse_stats, mpp_mem_dump, & - mpp_memuse_begin, mpp_memuse_end - use mpp_efp_mod, only: mpp_reproducing_sum, mpp_efp_list_sum_across_PEs, & - mpp_efp_plus, mpp_efp_minus, mpp_efp_to_real, & - mpp_real_to_efp, mpp_efp_real_diff, operator(+), & - operator(-), assignment(=), mpp_query_efp_overflow_error, & - mpp_reset_efp_overflow_error, mpp_efp_type - use mpp_domains_mod, only: domain_axis_spec, domain1D, domain2D, DomainCommunicator2D, & - nest_domain_type, mpp_group_update_type, & - mpp_domains_set_stack_size, mpp_get_compute_domain, & - mpp_get_compute_domains, mpp_get_data_domain, & - mpp_get_global_domain, mpp_get_domain_components, & - mpp_get_layout, mpp_get_pelist, operator(.EQ.), operator(.NE.), & - mpp_domain_is_symmetry, mpp_domain_is_initialized, & - mpp_get_neighbor_pe, mpp_nullify_domain_list, & - mpp_set_compute_domain, mpp_set_data_domain, mpp_set_global_domain, & - mpp_get_memory_domain, mpp_get_domain_shift, & - mpp_domain_is_tile_root_pe, mpp_get_tile_id, & - mpp_get_domain_extents, mpp_get_current_ntile, & - mpp_get_ntile_count, mpp_get_tile_list, mpp_get_tile_npes, & - mpp_get_domain_root_pe, mpp_get_tile_pelist, & - mpp_get_tile_compute_domains, mpp_get_num_overlap, & - mpp_get_overlap, mpp_get_io_domain, mpp_get_domain_pe, & - mpp_get_domain_tile_root_pe, mpp_get_domain_name, & - mpp_get_io_domain_layout, mpp_copy_domain, mpp_set_domain_symmetry, & - mpp_get_update_pelist, mpp_get_update_size, & - mpp_get_domain_npes, mpp_get_domain_pelist, & - mpp_clear_group_update, mpp_group_update_initialized, & - mpp_group_update_is_set, mpp_get_global_domains, & - mpp_global_field, mpp_global_max, mpp_global_min, mpp_global_sum, & - mpp_global_sum_tl, mpp_global_sum_ad, mpp_broadcast_domain, & - mpp_domains_init, mpp_domains_exit, mpp_redistribute, & - mpp_update_domains, mpp_check_field, mpp_start_update_domains, & - mpp_complete_update_domains, mpp_create_group_update, & - mpp_do_group_update, mpp_start_group_update, & - mpp_complete_group_update, mpp_reset_group_update_field, & - mpp_update_nest_fine, mpp_update_nest_coarse, mpp_get_boundary, & - mpp_update_domains_ad, mpp_get_boundary_ad, mpp_pass_SG_to_UG, & - mpp_pass_UG_to_SG, mpp_define_layout, mpp_define_domains, & - mpp_modify_domain, mpp_define_mosaic, mpp_define_mosaic_pelist, & - mpp_define_null_domain, mpp_mosaic_defined, & - mpp_define_io_domain, mpp_deallocate_domain, & - mpp_compute_extent, mpp_compute_block_extent, & - mpp_define_unstruct_domain, domainUG, mpp_get_UG_io_domain, & - mpp_get_UG_domain_npes, mpp_get_UG_compute_domain, & - mpp_get_UG_domain_tile_id, mpp_get_UG_domain_pelist, & - mpp_get_ug_domain_grid_index, mpp_get_UG_domain_ntiles, & - mpp_get_UG_global_domain, mpp_global_field_ug, & - mpp_get_ug_domain_tile_list, mpp_get_UG_compute_domains, & - mpp_define_null_UG_domain, NULL_DOMAINUG, mpp_get_UG_domains_index, & - mpp_get_UG_SG_domain, mpp_get_UG_domain_tile_pe_inf, & - mpp_define_nest_domains, mpp_get_C2F_index, mpp_get_F2C_index, & - mpp_get_nest_coarse_domain, mpp_get_nest_fine_domain, & - mpp_is_nest_coarse, mpp_is_nest_fine, & - mpp_get_nest_pelist, mpp_get_nest_npes, & - mpp_get_nest_fine_pelist, mpp_get_nest_fine_npes, & - mpp_domain_UG_is_tile_root_pe, mpp_deallocate_domainUG, & - mpp_get_io_domain_UG_layout, NULL_DOMAIN1D, NULL_DOMAIN2D, & - mpp_create_super_grid_domain, mpp_shift_nest_domains + ! this should really only be used internally + !use mpp_data_mod, only: stat, mpp_stack, ptr_stack, status, ptr_status, sync, & + ! ptr_sync, mpp_from_pe, ptr_from, remote_Data_loc, & + ! ptr_remote, mpp_domains_stack, ptr_domains_stack, & + ! mpp_domains_stack_nonblock, ptr_domains_stack_nonblock + use mpp_utilities_mod, only: fms_mpp_utilities_array_global_min_max => mpp_array_global_min_max + use mpp_memutils_mod, only: fms_mpp_memutils_print_memuse_stats => mpp_print_memuse_stats, & + fms_mpp_memutils_mem_dump => mpp_mem_dump, & + fms_mpp_memutils_memuse_begin => mpp_memuse_begin, & + fms_mpp_memutils_memuse_end => mpp_memuse_end + use mpp_efp_mod, only: fms_mpp_efp_reproducing_sum => mpp_reproducing_sum, & + fms_mpp_efp_list_sum_across_PEs => mpp_efp_list_sum_across_PEs, & + fms_mpp_efp_plus => mpp_efp_plus, & + fms_mpp_efp_minus => mpp_efp_minus, & + fms_mpp_efp_to_real => mpp_efp_to_real, & + fms_mpp_efp_real_to_efp => mpp_real_to_efp, & + fms_mpp_efp_real_diff => mpp_efp_real_diff, & + operator(+), operator(-), assignment(=), & + fms_mpp_efp_query_overflow_error => mpp_query_efp_overflow_error, & + fms_mpp_efp_reset_overflow_error => mpp_reset_efp_overflow_error, & + FmsMppEfp_type => mpp_efp_type + use mpp_domains_mod, only: FmsMppDomains_axis_spec => domain_axis_spec, & + FmsMppDomain1D => domain1D, & + FmsMppDomain2D => domain2D, & + FmsMppDomainCommunicator2D => DomainCommunicator2D, & + FmsMppDomainsNestDomain_type => nest_domain_type, & + FmsMppDomainsGroupUpdate_type => mpp_group_update_type, & + fms_mpp_domains_domains_set_stack_size => mpp_domains_set_stack_size, & + fms_mpp_domains_get_compute_domain => mpp_get_compute_domain, & + fms_mpp_domains_get_compute_domains => mpp_get_compute_domains, & + fms_mpp_domains_get_data_domain => mpp_get_data_domain, & + fms_mpp_domains_get_global_domain => mpp_get_global_domain, & + fms_mpp_domains_get_domain_components => mpp_get_domain_components, & + fms_mpp_domains_get_layout => mpp_get_layout, & + fms_mpp_domains_get_pelist => mpp_get_pelist, & + operator(.EQ.), operator(.NE.), & + fms_mpp_domains_domain_is_symmetry => mpp_domain_is_symmetry, & + fms_mpp_domains_domain_is_initialized => mpp_domain_is_initialized, & + fms_mpp_domains_get_neighbor_pe => mpp_get_neighbor_pe, & + fms_mpp_domains_nullify_domain_list => mpp_nullify_domain_list, & + fms_mpp_domains_set_compute_domain => mpp_set_compute_domain, & + fms_mpp_domains_set_data_domain => mpp_set_data_domain, & + fms_mpp_domains_set_global_domain => mpp_set_global_domain, & + fms_mpp_domains_get_memory_domain => mpp_get_memory_domain, & + fms_mpp_domains_get_domain_shift => mpp_get_domain_shift, & + fms_mpp_domains_domain_is_tile_root_pe => mpp_domain_is_tile_root_pe, & + fms_mpp_domains_get_tile_id => mpp_get_tile_id, & + fms_mpp_domains_get_domain_extents => mpp_get_domain_extents, & + fms_mpp_domains_get_current_ntile => mpp_get_current_ntile, & + fms_mpp_domains_get_ntile_count => mpp_get_ntile_count, & + fms_mpp_domains_get_tile_list => mpp_get_tile_list, & + fms_mpp_domains_get_tile_npes => mpp_get_tile_npes, & + fms_mpp_domains_get_domain_root_pe => mpp_get_domain_root_pe, & + fms_mpp_domains_get_tile_pelist => mpp_get_tile_pelist, & + fms_mpp_domains_get_tile_compute_domains => mpp_get_tile_compute_domains, & + fms_mpp_domains_get_num_overlap => mpp_get_num_overlap, & + fms_mpp_domains_get_overlap => mpp_get_overlap, & + fms_mpp_domains_get_io_domain => mpp_get_io_domain, & + fms_mpp_domains_get_domain_pe => mpp_get_domain_pe, & + fms_mpp_domains_get_domain_tile_root_pe => mpp_get_domain_tile_root_pe, & + fms_mpp_domains_get_domain_name => mpp_get_domain_name, & + fms_mpp_domains_get_io_domain_layout => mpp_get_io_domain_layout, & + fms_mpp_domains_copy_domain => mpp_copy_domain, & + fms_mpp_domains_set_domain_symmetry => mpp_set_domain_symmetry, & + fms_mpp_domains_get_update_pelist => mpp_get_update_pelist, & + fms_mpp_domains_get_update_size => mpp_get_update_size, & + fms_mpp_domains_get_domain_npes => mpp_get_domain_npes, & + fms_mpp_domains_get_domain_pelist => mpp_get_domain_pelist, & + fms_mpp_domains_clear_group_update => mpp_clear_group_update, & + fms_mpp_domains_group_update_initialized => mpp_group_update_initialized, & + fms_mpp_domains_group_update_is_set => mpp_group_update_is_set, & + fms_mpp_domains_get_global_domains => mpp_get_global_domains, & + fms_mpp_domains_global_field => mpp_global_field, & + fms_mpp_domains_global_max => mpp_global_max, & + fms_mpp_domains_global_min => mpp_global_min, & + fms_mpp_domains_global_sum => mpp_global_sum, & + fms_mpp_domains_global_sum_tl => mpp_global_sum_tl, & + fms_mpp_domains_global_sum_ad => mpp_global_sum_ad, & + fms_mpp_domains_broadcast_domain => mpp_broadcast_domain, & + fms_mpp_domains_init => mpp_domains_init, & + fms_mpp_domains_exit => mpp_domains_exit, & + fms_mpp_domains_redistribute => mpp_redistribute, & + fms_mpp_domains_update_domains => mpp_update_domains, & + fms_mpp_domains_check_field => mpp_check_field, & + fms_mpp_domains_start_update_domains => mpp_start_update_domains, & + fms_mpp_domains_complete_update_domains => mpp_complete_update_domains, & + fms_mpp_domains_create_group_update => mpp_create_group_update, & + fms_mpp_domains_do_group_update => mpp_do_group_update, & + fms_mpp_domains_start_group_update => mpp_start_group_update, & + fms_mpp_domains_complete_group_update => mpp_complete_group_update, & + fms_mpp_domains_reset_group_update_field => mpp_reset_group_update_field, & + fms_mpp_domains_update_nest_fine => mpp_update_nest_fine, & + fms_mpp_domains_update_nest_coarse => mpp_update_nest_coarse, & + fms_mpp_domains_get_boundary => mpp_get_boundary, & + fms_mpp_domains_update_domains_ad => mpp_update_domains_ad, & + fms_mpp_domains_get_boundary_ad => mpp_get_boundary_ad, & + fms_mpp_domains_pass_SG_to_UG => mpp_pass_SG_to_UG, & + fms_mpp_domains_pass_UG_to_SG => mpp_pass_UG_to_SG, & + fms_mpp_domains_define_layout => mpp_define_layout, & + fms_mpp_domains_define_domains => mpp_define_domains, & + fms_mpp_domains_modify_domain => mpp_modify_domain, & + fms_mpp_domains_define_mosaic => mpp_define_mosaic, & + fms_mpp_domains_define_mosaic_pelist => mpp_define_mosaic_pelist, & + fms_mpp_domains_define_null_domain => mpp_define_null_domain, & + fms_mpp_domains_mosaic_defined => mpp_mosaic_defined, & + fms_mpp_domains_define_io_domain => mpp_define_io_domain, & + fms_mpp_domains_deallocate_domain => mpp_deallocate_domain, & + fms_mpp_domains_compute_extent => mpp_compute_extent, & + fms_mpp_domains_compute_block_extent => mpp_compute_block_extent, & + fms_mpp_domains_define_unstruct_domain => mpp_define_unstruct_domain, & + fmsMppDomainUG => domainUG, & + fms_mpp_domains_get_UG_io_domain => mpp_get_UG_io_domain, & + fms_mpp_domains_get_UG_domain_npes => mpp_get_UG_domain_npes, & + fms_mpp_domains_get_UG_compute_domain => mpp_get_UG_compute_domain, & + fms_mpp_domains_get_UG_domain_tile_id => mpp_get_UG_domain_tile_id, & + fms_mpp_domains_get_UG_domain_pelist => mpp_get_UG_domain_pelist, & + fms_mpp_domains_get_ug_domain_grid_index => mpp_get_ug_domain_grid_index, & + fms_mpp_domains_get_UG_domain_ntiles => mpp_get_UG_domain_ntiles, & + fms_mpp_domains_get_UG_global_domain => mpp_get_UG_global_domain, & + fms_mpp_domains_global_field_ug => mpp_global_field_ug, & + fms_mpp_domains_get_ug_domain_tile_list => mpp_get_ug_domain_tile_list, & + fms_mpp_domains_get_UG_compute_domains => mpp_get_UG_compute_domains, & + fms_mpp_domains_define_null_UG_domain => mpp_define_null_UG_domain, & + fms_mpp_domains_NULL_DOMAINUG => NULL_DOMAINUG, & + fms_mpp_domains_get_UG_domains_index => mpp_get_UG_domains_index, & + fms_mpp_domains_get_UG_SG_domain => mpp_get_UG_SG_domain, & + fms_mpp_domains_get_UG_domain_tile_pe_inf => mpp_get_UG_domain_tile_pe_inf, & + fms_mpp_domains_define_nest_domains => mpp_define_nest_domains, & + fms_mpp_domains_get_C2F_index => mpp_get_C2F_index, & + fms_mpp_domains_get_F2C_index => mpp_get_F2C_index, & + fms_mpp_domains_get_nest_coarse_domain => mpp_get_nest_coarse_domain, & + fms_mpp_domains_get_nest_fine_domain => mpp_get_nest_fine_domain, & + fms_mpp_domains_is_nest_coarse => mpp_is_nest_coarse, & + fms_mpp_domains_is_nest_fine => mpp_is_nest_fine, & + fms_mpp_domains_get_nest_pelist => mpp_get_nest_pelist, & + fms_mpp_domains_get_nest_npes => mpp_get_nest_npes, & + fms_mpp_domains_get_nest_fine_pelist => mpp_get_nest_fine_pelist, & + fms_mpp_domains_get_nest_fine_npes => mpp_get_nest_fine_npes, & + fms_mpp_domains_domain_UG_is_tile_root_pe => mpp_domain_UG_is_tile_root_pe, & + fms_mpp_domains_deallocate_domainUG => mpp_deallocate_domainUG, & + fms_mpp_domains_get_io_domain_UG_layout => mpp_get_io_domain_UG_layout, & + NULL_DOMAIN1D, & + NULL_DOMAIN2D, & + fms_mpp_domains_create_super_grid_domain => mpp_create_super_grid_domain, & + fms_mpp_domains_shift_nest_domains => mpp_shift_nest_domains !> parser #ifdef use_yaml - use yaml_parser_mod, only: open_and_parse_file, get_num_blocks, get_block_ids, get_value_from_key, & - get_nkeys, get_key_ids, get_key_name, get_key_value + use yaml_parser_mod, only: fms_yaml_parser_open_and_parse_file => open_and_parse_file, & + fms_yaml_parser_get_num_blocks => get_num_blocks, & + fms_yaml_parser_get_block_ids => get_block_ids, & + fms_yaml_parser_get_value_from_key => get_value_from_key, & + fms_yaml_parser_get_nkeys => get_nkeys, & + fms_yaml_parser_get_key_ids => get_key_ids, & + fms_yaml_parser_get_key_name => get_key_name, & + fms_yaml_parser_get_key_value => get_key_value #endif !> platform @@ -373,64 +710,124 @@ module fms l8_kind, l4_kind, i2_kind, ptr_kind !> random_numbers - use random_numbers_mod, only: randomNumberStream, initializeRandomNumberStream, & - getRandomNumbers, constructSeed + use random_numbers_mod, only: fms_random_numbers_randomNumberStream => randomNumberStream, & + fms_random_numbers_initializeRandomNumbersStream => initializeRandomNumberStream, & + fms_random_numbers_getRandomNumbers => getRandomNumbers, & + fms_random_numbers_constructSeed => constructSeed !> sat_vapor_pres - use sat_vapor_pres_mod, only: lookup_es, lookup_des, sat_vapor_pres_init, & - lookup_es2, lookup_des2, lookup_es2_des2, & - lookup_es3, lookup_des3, lookup_es3_des3, & - lookup_es_des, compute_qs, compute_mrs, & - escomp, descomp + use sat_vapor_pres_mod, only: fms_sat_vapor_pres_lookup_es => lookup_es, & + fms_sat_vapor_pres_lookup_des => lookup_des, & + fms_sat_vapor_pres_init => sat_vapor_pres_init, & + fms_sat_vapor_pres_lookup_es2 => lookup_es2, & + fms_sat_vapor_pres_lookup_des2 => lookup_des2, & + fms_sat_vapor_pres_lookup_es2_des2 => lookup_es2_des2, & + fms_sat_vapor_pres_lookup_es3 => lookup_es3, & + fms_sat_vapor_pres_lookup_des3 => lookup_des3, & + fms_sat_vapor_pres_lookup_es3_des3 => lookup_es3_des3, & + fms_sat_vapor_pres_lookup_es_des => lookup_es_des, & + fms_sat_vapor_pres_compute_qs => compute_qs, & + fms_sat_vapor_pres_compute_mrs => compute_mrs, & + fms_sat_vapor_pres_escomp => escomp, & + fms_sat_vapor_pres_descomp => descomp !> string_utils - use fms_string_utils_mod, only: string, fms_array_to_pointer, fms_pointer_to_array, fms_sort_this, & - fms_find_my_string, fms_find_unique, fms_c2f_string, fms_cstring2cpointer, & - string_copy + use fms_string_utils_mod, only: fms_string_utils_string => string, & + fms_string_utils_array_to_pointer => fms_array_to_pointer, & + fms_string_utils_fms_pointer_to_array => fms_pointer_to_array, & + fms_string_utils_sort_this => fms_sort_this, & + fms_string_utils_find_my_string => fms_find_my_string, & + fms_string_utils_find_unique => fms_find_unique, & + fms_string_utils_c2f_string => fms_c2f_string, & + fms_string_utils_cstring2cpointer => fms_cstring2cpointer, & + fms_string_utils_copy => string_copy !> time_interp - use time_interp_mod, only: time_interp_init, time_interp, fraction_of_year, & + use time_interp_mod, only: fms_time_interp_init => time_interp_init, & + fms_time_interp => time_interp, fms_fraction_of_year=> fraction_of_year, & NONE, YEAR, MONTH, DAY - use time_interp_external2_mod, only: init_external_field, time_interp_external, & - time_interp_external_init, time_interp_external_exit, & - get_external_field_size, get_time_axis, & - get_external_field_missing, set_override_region, & - reset_src_data_region, get_external_fileobj, & + use time_interp_external2_mod, only: fms_time_interp_external_init_external_field => init_external_field, & + fms_time_interp_external => time_interp_external, & + fms_time_interp_external_init => time_interp_external_init, & + fms_time_interp_external_exit => time_interp_external_exit, & + fms_time_interp_external_get_external_field_size => get_external_field_size, & + fms_time_interp_external_get_time_axis => get_time_axis, & + fms_time_interp_external_get_external_field_missing => get_external_field_missing, & + fms_time_interp_external_set_override_region => set_override_region, & + fms_time_interp_external_reset_src_data_region => reset_src_data_region, & + fms_time_interp_external_get_external_fileobj => get_external_fileobj, & NO_REGION, INSIDE_REGION, OUTSIDE_REGION, & SUCCESS, ERR_FIELD_NOT_FOUND !> time_manager - use time_manager_mod, only: time_type, operator(+), operator(-), operator(*), & + use time_manager_mod, only: FmsTime_type => time_type, & + operator(+), operator(-), operator(*), assignment(=),& operator(/), operator(>), operator(>=), operator(==), & operator(/=), operator(<), operator(<=), operator(//), & - assignment(=), set_time, increment_time, decrement_time, & - get_time, interval_alarm, repeat_alarm, time_type_to_real, & - real_to_time_type, time_list_error, THIRTY_DAY_MONTHS, & - JULIAN, GREGORIAN, NOLEAP, NO_CALENDAR, INVALID_CALENDAR, & - set_calendar_type, get_calendar_type, set_ticks_per_second, & - get_ticks_per_second, set_date, get_date, increment_date, & - decrement_date, days_in_month, leap_year, length_of_year, & - days_in_year, day_of_year, month_name, valid_calendar_types, & - time_manager_init, print_time, print_date, set_date_julian, & - get_date_julian, get_date_no_leap, date_to_string - use get_cal_time_mod, only: get_cal_time + fms_time_manager_set_time => set_time, & + fms_time_manager_increment_time => increment_time, & + fms_time_manager_decrement_time => decrement_time, & + fms_time_manager_get_time => get_time, & + fms_time_manager_interval_alarm => interval_alarm, & + fms_time_manager_repeat_alarm => repeat_alarm, & + fms_time_manager_time_type_to_real => time_type_to_real, & + fms_time_manager_real_to_time_type => real_to_time_type, & + fms_time_manager_time_list_error => time_list_error, & + THIRTY_DAY_MONTHS, JULIAN, GREGORIAN, NOLEAP, NO_CALENDAR, INVALID_CALENDAR, & + fms_time_manager_set_calendar_type => set_calendar_type, & + fms_time_manager_get_calendar_type => get_calendar_type, & + fms_time_manager_set_ticks_per_second => set_ticks_per_second, & + fms_time_manager_get_ticks_per_second => get_ticks_per_second, & + fms_time_manager_set_date => set_date, & + fms_time_manager_get_date => get_date, & + fms_time_manager_increment_date => increment_date, & + fms_time_manager_decrement_date => decrement_date, & + fms_time_manager_days_in_month => days_in_month, & + fms_time_manager_leap_year => leap_year, & + fms_time_manager_length_of_year => length_of_year, & + fms_time_manager_days_in_year => days_in_year, & + fms_time_manager_day_of_year => day_of_year, & + fms_time_manager_month_name => month_name, & + fms_time_manager_valid_calendar_types => valid_calendar_types, & + fms_time_manager_init => time_manager_init, & + fms_time_manager_print_time => print_time, & + fms_time_manager_print_date => print_date, & + fms_time_manager_set_date_julian => set_date_julian, & + fms_time_manager_get_date_julian => get_date_julian, & + fms_time_manager_get_date_no_leap => get_date_no_leap, & + fms_time_manager_date_to_string => date_to_string + use get_cal_time_mod, only: fms_get_cal_time => get_cal_time !> topography - use gaussian_topog_mod, only: gaussian_topog_init, get_gaussian_topog - use topography_mod, only: topography_init, get_topog_mean, get_topog_stdev, & - get_ocean_frac, get_ocean_mask, get_water_frac, & - get_water_mask + use gaussian_topog_mod, only: fms_gaussian_topog_init => gaussian_topog_init, & + fms_get_gaussian_topog => get_gaussian_topog + use topography_mod, only: fms_topography_init => topography_init, & + fms_topography_get_topog_mean => get_topog_mean, & + fms_topography_get_topog_stdev => get_topog_stdev, & + fms_topography_get_ocean_frac => get_ocean_frac, & + fms_topography_get_ocean_mask => get_ocean_mask, & + fms_topography_get_water_frac => get_water_frac, & + fms_topography_get_water_mask => get_water_mask !> tracer_manager - use tracer_manager_mod, only: tracer_manager_init, tracer_manager_end, & - check_if_prognostic, get_tracer_indices, & - get_tracer_index, get_tracer_names, & - get_tracer_name, query_method, & - set_tracer_atts, set_tracer_profile, & - register_tracers, get_number_tracers, & - adjust_mass, adjust_positive_def, NO_TRACER, MAX_TRACER_FIELDS + use tracer_manager_mod, only: fms_tracer_manager_init => tracer_manager_init, & + fms_tracer_manager_end => tracer_manager_end, & + fms_tracer_manager_check_if_prognostic => check_if_prognostic, & + fms_tracer_manager_get_tracer_indices => get_tracer_indices, & + fms_tracer_manager_get_tracer_index => get_tracer_index, & + fms_tracer_manager_get_tracer_names => get_tracer_names, & + fms_tracer_manager_get_tracer_name => get_tracer_name, & + fms_tracer_manager_query_method => query_method, & + fms_tracer_manager_set_tracer_atts => set_tracer_atts, & + fms_tracer_manager_set_tracer_profile => set_tracer_profile, & + fms_tracer_manager_register_tracers => register_tracers, & + fms_tracer_manager_get_number_tracers => get_number_tracers, & + fms_tracer_manager_adjust_mass => adjust_mass, & + fms_tracer_manager_adjust_positive_def => adjust_positive_def, & + NO_TRACER, MAX_TRACER_FIELDS !> tridiagonal - use tridiagonal_mod, only: tri_invert, close_tridiagonal + use tridiagonal_mod, only: fms_tridiagonal_tri_invert => tri_invert, & + fms_tridiagonal_close_tridiagonal => close_tridiagonal implicit none diff --git a/test_fms/mpp/test_domains_utility_mod.F90 b/test_fms/mpp/test_domains_utility_mod.F90 index 43271e053f..f88054b9f5 100644 --- a/test_fms/mpp/test_domains_utility_mod.F90 +++ b/test_fms/mpp/test_domains_utility_mod.F90 @@ -22,9 +22,9 @@ module test_domains_utility_mod use mpp_mod, only : FATAL, WARNING, MPP_DEBUG, NOTE use mpp_mod, only : mpp_error - use mpp_domains_mod, only : ZERO, NINETY, MINUS_NINETY + use mpp_domains_mod, only : ZERO, NINETY, MINUS_NINETY, & + domain2d, mpp_define_mosaic use platform_mod, only: r4_kind, r8_kind - use fms interface fill_coarse_data module procedure fill_coarse_data_r8 diff --git a/test_fms/mpp/test_mpp_chksum.F90 b/test_fms/mpp/test_mpp_chksum.F90 index a63ee7d22e..5810e42cab 100644 --- a/test_fms/mpp/test_mpp_chksum.F90 +++ b/test_fms/mpp/test_mpp_chksum.F90 @@ -23,7 +23,10 @@ !> single pe and distributed checksums program test_mpp_chksum - use fms + use mpp_mod + use mpp_domains_mod + use fms_mod + use platform_mod implicit none diff --git a/test_fms/mpp/test_mpp_domains.F90 b/test_fms/mpp/test_mpp_domains.F90 index 1ae1d904da..3ca557788f 100644 --- a/test_fms/mpp/test_mpp_domains.F90 +++ b/test_fms/mpp/test_mpp_domains.F90 @@ -54,7 +54,7 @@ program test_mpp_domains NONSYMEDGEUPDATE use mpp_domains_mod, only : domainUG, mpp_define_unstruct_domain, mpp_get_UG_domain_tile_id use mpp_domains_mod, only : mpp_get_UG_compute_domain, mpp_pass_SG_to_UG, mpp_pass_UG_to_SG - use mpp_domains_mod, only : mpp_global_field_ug + use mpp_domains_mod, only : mpp_global_field_ug, mpp_get_ug_global_domain use compare_data_checksums use test_domains_utility_mod diff --git a/test_fms/mpp/test_mpp_nesting.F90 b/test_fms/mpp/test_mpp_nesting.F90 index 201fd217f0..833c580bf5 100644 --- a/test_fms/mpp/test_mpp_nesting.F90 +++ b/test_fms/mpp/test_mpp_nesting.F90 @@ -19,7 +19,9 @@ !> Tests nested domain operations and routines in mpp_domains program test_mpp_nesting - use fms + use fms_mod + use mpp_domains_mod + use mpp_mod use compare_data_checksums use test_domains_utility_mod use platform_mod From 20a3b9a47ef941f48fb84feab72255d337c7cc5d Mon Sep 17 00:00:00 2001 From: mlee03 Date: Wed, 19 Jul 2023 11:25:58 -0400 Subject: [PATCH 42/51] merge main updates to mixedmode_base --- .github/workflows/build_cmake_gnu.yml | 3 +- .github/workflows/build_ubuntu_gnu.yml | 3 +- .github/workflows/intel_pr.yml | 6 +- .github/workflows/update_docs.yml | 28 +- CMakeLists.txt | 5 + axis_utils/axis_utils.F90 | 3 +- axis_utils/include/axis_utils2.inc | 2 +- configure.ac | 17 +- coupler/coupler_types.F90 | 14 +- coupler/ensemble_manager.F90 | 4 + coupler/include/coupler_types.inc | 14 +- coupler/include/ensemble_manager.inc | 4 + diag_manager/Makefile.am | 67 +- fms/Makefile.am | 73 +- fms/fms.F90 | 36 +- fms/fms_io.F90 | 3 +- fms/fms_stacksize.c | 33 + libFMS.F90 | 947 +++++++++++++----- monin_obukhov/include/monin_obukhov.inc | 53 +- monin_obukhov/monin_obukhov.F90 | 53 +- mosaic/grid.F90 | 3 +- mosaic/mosaic.F90 | 3 +- mpp/include/mpp_do_global_field_ad.fh | 4 +- mpp/include/mpp_do_updateV_ad.fh | 2 +- mpp/include/mpp_do_update_ad.fh | 173 +++- mpp/include/mpp_get_boundary_ad.fh | 2 +- mpp/include/mpp_global_field_ad.fh | 4 +- mpp/include/mpp_sum_mpi_ad.fh | 2 +- mpp/include/mpp_sum_nocomm_ad.fh | 2 +- mpp/include/mpp_update_domains2D_ad.fh | 16 +- mpp/mpp_io.F90 | 3 +- test_fms/data_override/test_data_override.F90 | 78 +- test_fms/diag_manager/test_diag_manager.F90 | 16 +- test_fms/fms2_io/test_fms2_io.sh | 10 - test_fms/interpolator/test_interpolator.F90 | 17 +- test_fms/mpp/test_domains_utility_mod.F90 | 4 +- test_fms/mpp/test_global_arrays.F90 | 493 +++++---- test_fms/mpp/test_global_arrays.sh | 22 +- test_fms/mpp/test_mpp.F90 | 2 - test_fms/mpp/test_mpp_chksum.F90 | 5 +- test_fms/mpp/test_mpp_chksum.sh | 5 - test_fms/mpp/test_mpp_domains.F90 | 119 +-- test_fms/mpp/test_mpp_gatscat.F90 | 2 - test_fms/mpp/test_mpp_global_sum_ad.F90 | 2 - test_fms/mpp/test_mpp_nesting.F90 | 20 +- test_fms/mpp/test_mpp_sendrecv.F90 | 2 - test_fms/mpp/test_mpp_update_domains_ad.F90 | 2 - test_fms/mpp/test_mpp_update_domains_int.F90 | 1 - test_fms/mpp/test_mpp_update_domains_main.F90 | 2 - .../mpp/test_update_domains_performance.F90 | 2 - test_fms/mpp_io/Makefile.am | 4 + test_fms/mpp_io/test_io_R4_R8.F90 | 3 +- test_fms/mpp_io/test_io_mosaic_R4_R8.F90 | 3 +- test_fms/mpp_io/test_mpp_io.F90 | 4 +- test_fms/parser/parser_demo.F90 | 1 - test_fms/test-lib.sh.in | 5 - time_interp/include/time_interp_external.inc | 3 +- time_interp/include/time_interp_external2.inc | 18 +- time_interp/time_interp_external.F90 | 3 +- time_interp/time_interp_external2.F90 | 18 +- 60 files changed, 1462 insertions(+), 986 deletions(-) create mode 100644 fms/fms_stacksize.c diff --git a/.github/workflows/build_cmake_gnu.yml b/.github/workflows/build_cmake_gnu.yml index f649345d8a..d4f7e2a248 100644 --- a/.github/workflows/build_cmake_gnu.yml +++ b/.github/workflows/build_cmake_gnu.yml @@ -9,10 +9,11 @@ jobs: matrix: omp-flags: [ -DOPENMP=on, -DOPENMP=off ] libyaml-flag: [ "", -DWITH_YAML=on ] + io-flag: [ "", -DUSE_DEPRECATED_IO=on ] container: image: noaagfdl/hpc-me.ubuntu-minimal:cmake env: - CMAKE_FLAGS: "${{ matrix.omp-flags }} ${{ matrix.libyaml-flag }} -D64BIT=on" + CMAKE_FLAGS: "${{ matrix.omp-flags }} ${{ matrix.io-flag }} ${{ matrix.libyaml-flag }} -D64BIT=on" steps: - name: Checkout code uses: actions/checkout@v2 diff --git a/.github/workflows/build_ubuntu_gnu.yml b/.github/workflows/build_ubuntu_gnu.yml index f4dc48225f..7c53895b15 100644 --- a/.github/workflows/build_ubuntu_gnu.yml +++ b/.github/workflows/build_ubuntu_gnu.yml @@ -12,11 +12,12 @@ jobs: matrix: conf-flags: [--disable-openmp, --enable-mixed-mode, --disable-setting-flags, --with-mpi=no] input-flag: [--with-yaml, --enable-test-input=/home/unit_tests_input] + io-flag: [ --enable-deprecated-io, --disable-deprecated-io] container: image: noaagfdl/hpc-me.ubuntu-minimal:gnu-input env: TEST_VERBOSE: 1 - DISTCHECK_CONFIGURE_FLAGS: "${{ matrix.conf-flags }} ${{ matrix.input-flag }}" + DISTCHECK_CONFIGURE_FLAGS: "${{ matrix.conf-flags }} ${{ matrix.input-flag }} ${{ matrix.io-flag }}" steps: - name: Checkout code uses: actions/checkout@v2 diff --git a/.github/workflows/intel_pr.yml b/.github/workflows/intel_pr.yml index d95519fbf2..62a15361ea 100644 --- a/.github/workflows/intel_pr.yml +++ b/.github/workflows/intel_pr.yml @@ -3,7 +3,7 @@ jobs: intel-autotools: runs-on: ubuntu-latest container: - image: intel/oneapi-hpckit:2022.2-devel-ubuntu20.04 + image: intel/oneapi-hpckit:2023.1.0-devel-ubuntu20.04 env: CC: mpiicc FC: mpiifort @@ -22,7 +22,7 @@ jobs: path: /libs key: ${{ runner.os }}-intel-libs - name: Install packages for building - run: apt update && apt install -y autoconf libtool automake zlibc zlib1g-dev + run: apt-get update && apt-get install -y autoconf libtool automake zlibc zlib1g-dev - if: steps.cache.outputs.cache-hit != 'true' name: Build netcdf run: | @@ -50,4 +50,4 @@ jobs: - name: Compile run: make -j || make - name: Run test suite - run: make check LD_LIBRARY_PATH="/libs/lib:$LD_LIBRARY_PATH" SKIP_TESTS="$SKIP_TESTS" VERBOSE=1 + run: make check LD_LIBRARY_PATH="/libs/lib:$LD_LIBRARY_PATH" TEST_VERBOSE=1 diff --git a/.github/workflows/update_docs.yml b/.github/workflows/update_docs.yml index 6a4b4bf917..bbf2335811 100644 --- a/.github/workflows/update_docs.yml +++ b/.github/workflows/update_docs.yml @@ -6,7 +6,7 @@ on: types: [published] workflow_dispatch: jobs: - update_docs: + build: runs-on: ubuntu-latest steps: - name: Checkout code @@ -23,8 +23,26 @@ jobs: run: | sudo apt -y install doxygen graphviz doxygen gen_docs/Doxyfile - - name: Deploy - uses: peaceiris/actions-gh-pages@v3 + - name: Upload Pages Artifact + uses: actions/upload-pages-artifact@v1 with: - github_token: ${{ secrets.GITHUB_TOKEN }} - publish_dir: ./gen_docs/html + path: 'gen_docs/html' + deploy: + needs: build + + # Grant GITHUB_TOKEN the permissions required to make a Pages deployment + permissions: + pages: write # to deploy to Pages + id-token: write # to verify the deployment originates from an appropriate source + + # Deploy to the github-pages environment + environment: + name: github-pages + url: ${{ steps.deployment.outputs.page_url }} + + # Specify runner + deployment step + runs-on: ubuntu-latest + steps: + - name: Deploy to GitHub Pages + id: deployment + uses: actions/deploy-pages@v1 diff --git a/CMakeLists.txt b/CMakeLists.txt index 89cc584813..204cb32bb1 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -66,6 +66,7 @@ option(ENABLE_QUAD_PRECISION "Enable compiler definition -DENABLE_QUAD_PRECISION option(GFS_PHYS "Enable compiler definition -DGFS_PHYS" OFF) option(LARGEFILE "Enable compiler definition -Duse_LARGEFILE" OFF) option(WITH_YAML "Enable compiler definition -Duse_yaml" OFF) +option(USE_DEPRECATED_IO "Enable compiler definition -Duse_deprecated_io (compile with fms_io/mpp_io)" OFF) if(32BIT) list(APPEND kinds "r4") @@ -244,6 +245,10 @@ if(WITH_YAML) list(APPEND fms_defs use_yaml) endif() +if(USE_DEPRECATED_IO) + list(APPEND fms_defs use_deprecated_io) +endif() + if(INTERNAL_FILE_NML) list(APPEND fms_defs INTERNAL_FILE_NML) endif() diff --git a/axis_utils/axis_utils.F90 b/axis_utils/axis_utils.F90 index 3947e370e3..4d746be7f3 100644 --- a/axis_utils/axis_utils.F90 +++ b/axis_utils/axis_utils.F90 @@ -27,6 +27,7 @@ !> @addtogroup axis_utils_mod !> @{ module axis_utils_mod +#ifdef use_deprecated_io use netcdf use mpp_io_mod, only: axistype, atttype, default_axis, default_att, & mpp_get_atts, mpp_get_axis_data, mpp_modify_meta, & @@ -787,7 +788,7 @@ subroutine find_index(grid1, xs, xe, ks, ke) if(ke == 0 ) call mpp_error(FATAL,' xe locate outside of grid1') end subroutine find_index - +#endif end module axis_utils_mod !> @} ! close documentation grouping diff --git a/axis_utils/include/axis_utils2.inc b/axis_utils/include/axis_utils2.inc index da544d68c3..3535e70df7 100644 --- a/axis_utils/include/axis_utils2.inc +++ b/axis_utils/include/axis_utils2.inc @@ -212,7 +212,7 @@ endif lon_strt = lon(1) - do i=2,len+1 + do i=2,len lon(i) = lon_in_range(lon(i),lon_strt) lon_strt = lon(i) enddo diff --git a/configure.ac b/configure.ac index c1393a8b8b..a2a9729a01 100644 --- a/configure.ac +++ b/configure.ac @@ -110,6 +110,13 @@ AS_IF([test ${enable_8byte_int:-no} = yes], [enable_8byte_int=yes], [enable_8byte_int=no]) +AC_ARG_ENABLE([deprecated-io], + [AS_HELP_STRING([--enable-deprecated-io], + [Enables compilation of deprecated mpp_io and fms_io modules in addition to the updated fms2_io modules (default no)])]) +AS_IF([test ${enable_deprecated_io:-no} = yes], + [enable_deprecated_io=yes], + [enable_deprecated_io=no]) + # user enabled testing with input files AC_MSG_CHECKING([whether to enable tests with input files]) AC_ARG_ENABLE([test-input], @@ -203,7 +210,6 @@ AC_MSG_CHECKING([if netCDF was built with HDF5]) AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [[ #include #if !(NC_HAS_NC4) - choke me #endif]])], [nc_has_nc4=yes], [nc_has_nc4=no]) AC_MSG_RESULT([$nc_has_nc4]) if test $nc_has_nc4 = no; then @@ -281,6 +287,15 @@ if test $with_mpi = yes; then AC_DEFINE([use_libMPI], [1], [This is required for the library to build]) fi +# check if compiling old io +if test $enable_deprecated_io = yes; then + #If the test pass, define use_deprecated_io macro and skip it's unit tests + AC_DEFINE([use_deprecated_io], [1], [This is required to use mpp_io and fms_io modules]) + AM_CONDITIONAL([SKIP_DEPRECATED_IO_TESTS], true) +else + AM_CONDITIONAL([SKIP_DEPRECATED_IO_TESTS], false) +fi + # Set any required compile flags. This will not be done if the user wants to # define all their own flags. if test $enable_setting_flags = yes; then diff --git a/coupler/coupler_types.F90 b/coupler/coupler_types.F90 index 82d0c97082..d059fe8a27 100644 --- a/coupler/coupler_types.F90 +++ b/coupler/coupler_types.F90 @@ -31,8 +31,10 @@ module coupler_types_mod use fms2_io_mod, only: get_variable_attribute, get_dimension_size, get_dimension_names use fms2_io_mod, only: register_variable_attribute, get_variable_dimension_names use fms2_io_mod, only: get_variable_num_dimensions +#ifdef use_deprecated_io use fms_io_mod, only: restart_file_type, fms_io_register_restart_field=>register_restart_field use fms_io_mod, only: query_initialized, restore_state +#endif use time_manager_mod, only: time_type use diag_manager_mod, only: register_diag_field, send_data use data_override_mod, only: data_override @@ -95,8 +97,10 @@ module coupler_types_mod integer :: atm_tr_index = 0 !< atm_tr_index character(len=128) :: ice_restart_file = ' ' !< ice_restart_file character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file +#ifdef use_deprecated_io type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type !! that is used for this field. +#endif type(FmsNetcdfDomainFile_t), pointer :: fms2_io_rest_type => NULL() !< A pointer to the restart_file_type !! That is used for this field logical :: use_atm_pressure !< use_atm_pressure @@ -149,8 +153,10 @@ module coupler_types_mod integer :: atm_tr_index = 0 !< atm_tr_index character(len=128) :: ice_restart_file = ' ' !< ice_restart_file character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file +#ifdef use_deprecated_io type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type !! that is used for this field. +#endif type(FmsNetcdfDomainFile_t), pointer :: fms2_io_rest_type => NULL() !< A pointer to the restart_file_type !! That is used for this field logical :: use_atm_pressure !< use_atm_pressure @@ -319,9 +325,10 @@ module coupler_types_mod !! in restart files. !> @ingroup coupler_types_mod interface coupler_type_register_restarts +#ifdef use_deprecated_io module procedure mpp_io_CT_register_restarts_2d, mpp_io_CT_register_restarts_3d module procedure mpp_io_CT_register_restarts_to_file_2d, mpp_io_CT_register_restarts_to_file_3d - +#endif module procedure CT_register_restarts_2d, CT_register_restarts_3d end interface coupler_type_register_restarts @@ -329,7 +336,9 @@ module coupler_types_mod !! been saved in restart files. !> @ingroup coupler_types_mod interface coupler_type_restore_state +#ifdef use_deprecated_io module procedure mpp_io_CT_restore_state_2d, mpp_io_CT_restore_state_3d +#endif module procedure CT_restore_state_2d, CT_restore_state_3d end interface coupler_type_restore_state @@ -3743,6 +3752,7 @@ end subroutine CT_destructor_3d !! !! This subroutine registers the fields in a coupler_2d_bc_type to be saved in restart files !! specified in the field table. +#ifdef use_deprecated_io subroutine mpp_io_CT_register_restarts_2d(var, bc_rest_files, num_rest_files, mpp_domain, ocean_restart) type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts type(restart_file_type), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files @@ -4056,7 +4066,7 @@ subroutine mpp_io_CT_restore_state_3d(var, directory, all_or_nothing, all_requir endif endif end subroutine mpp_io_CT_restore_state_3d - +#endif end module coupler_types_mod !> @} ! close documentation grouping diff --git a/coupler/ensemble_manager.F90 b/coupler/ensemble_manager.F90 index 944e859455..257dfed54e 100644 --- a/coupler/ensemble_manager.F90 +++ b/coupler/ensemble_manager.F90 @@ -30,7 +30,9 @@ module ensemble_manager_mod use mpp_mod, only : mpp_pe, mpp_declare_pelist use mpp_mod, only : input_nml_file use fms2_io_mod, only : fms2_io_set_filename_appendix=>set_filename_appendix +#ifdef use_deprecated_io use fms_io_mod, only : fms_io_set_filename_appendix=>set_filename_appendix +#endif IMPLICIT NONE @@ -408,7 +410,9 @@ subroutine ensemble_pelist_setup(concurrent, atmos_npes, ocean_npes, land_npes, !< Both calls are needed for cases where both fms2io/fmsio are used call fms2_io_set_filename_appendix(trim(text)) +#ifdef use_deprecated_io call fms_io_set_filename_appendix(trim(text)) +#endif endif end subroutine ensemble_pelist_setup diff --git a/coupler/include/coupler_types.inc b/coupler/include/coupler_types.inc index 82d0c97082..d059fe8a27 100644 --- a/coupler/include/coupler_types.inc +++ b/coupler/include/coupler_types.inc @@ -31,8 +31,10 @@ module coupler_types_mod use fms2_io_mod, only: get_variable_attribute, get_dimension_size, get_dimension_names use fms2_io_mod, only: register_variable_attribute, get_variable_dimension_names use fms2_io_mod, only: get_variable_num_dimensions +#ifdef use_deprecated_io use fms_io_mod, only: restart_file_type, fms_io_register_restart_field=>register_restart_field use fms_io_mod, only: query_initialized, restore_state +#endif use time_manager_mod, only: time_type use diag_manager_mod, only: register_diag_field, send_data use data_override_mod, only: data_override @@ -95,8 +97,10 @@ module coupler_types_mod integer :: atm_tr_index = 0 !< atm_tr_index character(len=128) :: ice_restart_file = ' ' !< ice_restart_file character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file +#ifdef use_deprecated_io type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type !! that is used for this field. +#endif type(FmsNetcdfDomainFile_t), pointer :: fms2_io_rest_type => NULL() !< A pointer to the restart_file_type !! That is used for this field logical :: use_atm_pressure !< use_atm_pressure @@ -149,8 +153,10 @@ module coupler_types_mod integer :: atm_tr_index = 0 !< atm_tr_index character(len=128) :: ice_restart_file = ' ' !< ice_restart_file character(len=128) :: ocean_restart_file = ' ' !< ocean_restart_file +#ifdef use_deprecated_io type(restart_file_type), pointer :: rest_type => NULL() !< A pointer to the restart_file_type !! that is used for this field. +#endif type(FmsNetcdfDomainFile_t), pointer :: fms2_io_rest_type => NULL() !< A pointer to the restart_file_type !! That is used for this field logical :: use_atm_pressure !< use_atm_pressure @@ -319,9 +325,10 @@ module coupler_types_mod !! in restart files. !> @ingroup coupler_types_mod interface coupler_type_register_restarts +#ifdef use_deprecated_io module procedure mpp_io_CT_register_restarts_2d, mpp_io_CT_register_restarts_3d module procedure mpp_io_CT_register_restarts_to_file_2d, mpp_io_CT_register_restarts_to_file_3d - +#endif module procedure CT_register_restarts_2d, CT_register_restarts_3d end interface coupler_type_register_restarts @@ -329,7 +336,9 @@ module coupler_types_mod !! been saved in restart files. !> @ingroup coupler_types_mod interface coupler_type_restore_state +#ifdef use_deprecated_io module procedure mpp_io_CT_restore_state_2d, mpp_io_CT_restore_state_3d +#endif module procedure CT_restore_state_2d, CT_restore_state_3d end interface coupler_type_restore_state @@ -3743,6 +3752,7 @@ contains !! !! This subroutine registers the fields in a coupler_2d_bc_type to be saved in restart files !! specified in the field table. +#ifdef use_deprecated_io subroutine mpp_io_CT_register_restarts_2d(var, bc_rest_files, num_rest_files, mpp_domain, ocean_restart) type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to be registered for restarts type(restart_file_type), dimension(:), pointer :: bc_rest_files !< Structures describing the restart files @@ -4056,7 +4066,7 @@ contains endif endif end subroutine mpp_io_CT_restore_state_3d - +#endif end module coupler_types_mod !> @} ! close documentation grouping diff --git a/coupler/include/ensemble_manager.inc b/coupler/include/ensemble_manager.inc index 944e859455..257dfed54e 100644 --- a/coupler/include/ensemble_manager.inc +++ b/coupler/include/ensemble_manager.inc @@ -30,7 +30,9 @@ module ensemble_manager_mod use mpp_mod, only : mpp_pe, mpp_declare_pelist use mpp_mod, only : input_nml_file use fms2_io_mod, only : fms2_io_set_filename_appendix=>set_filename_appendix +#ifdef use_deprecated_io use fms_io_mod, only : fms_io_set_filename_appendix=>set_filename_appendix +#endif IMPLICIT NONE @@ -408,7 +410,9 @@ contains !< Both calls are needed for cases where both fms2io/fmsio are used call fms2_io_set_filename_appendix(trim(text)) +#ifdef use_deprecated_io call fms_io_set_filename_appendix(trim(text)) +#endif endif end subroutine ensemble_pelist_setup diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 37759e838f..7de8a5e753 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -31,56 +31,57 @@ noinst_LTLIBRARIES = libdiag_manager.la # Each convenience library depends on its source. libdiag_manager_la_SOURCES = \ - diag_axis.F90 \ - diag_data.F90 \ - diag_grid.F90 \ - diag_manager.F90 \ - diag_output.F90 \ - diag_table.F90 \ - diag_util.F90 \ - fms_diag_time_reduction.F90 \ - fms_diag_outfield.F90 \ - fms_diag_elem_weight_procs.F90 \ - fms_diag_fieldbuff_update.F90 \ + diag_axis.F90 \ + diag_data.F90 \ + diag_grid.F90 \ + diag_manager.F90 \ + diag_output.F90 \ + diag_table.F90 \ + diag_util.F90 \ + fms_diag_time_reduction.F90 \ + fms_diag_outfield.F90 \ + fms_diag_elem_weight_procs.F90 \ + fms_diag_fieldbuff_update.F90 \ fms_diag_bbox.F90 \ - include/fms_diag_fieldbuff_update.inc \ - include/fms_diag_fieldbuff_update.fh + include/fms_diag_fieldbuff_update.inc \ + include/fms_diag_fieldbuff_update.fh # Some mods are dependant on other mods in this dir. diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) \ - diag_grid_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) + diag_grid_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) -fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ - fms_diag_elem_weight_procs_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) +fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ + fms_diag_outfield_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ + fms_diag_bbox_mod.$(FC_MODEXT) diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ - diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ - fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ - fms_diag_fieldbuff_update_mod.$(FC_MODEXT) + diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ + fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_fieldbuff_update_mod.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ - diag_data_mod.$(FC_MODEXT) \ - diag_axis_mod.$(FC_MODEXT) \ - diag_grid_mod.$(FC_MODEXT) \ - diag_output_mod.$(FC_MODEXT) \ - diag_util_mod.$(FC_MODEXT) \ - diag_table_mod.$(FC_MODEXT) \ - fms_diag_time_reduction_mod.$(FC_MODEXT) \ - fms_diag_outfield_mod.$(FC_MODEXT) \ - fms_diag_bbox_mod.$(FC_MODEXT) \ - fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ - fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \ - diag_manager_mod.$(FC_MODEXT) \ - include/fms_diag_fieldbuff_update.inc \ - include/fms_diag_fieldbuff_update.fh + diag_data_mod.$(FC_MODEXT) \ + diag_axis_mod.$(FC_MODEXT) \ + diag_grid_mod.$(FC_MODEXT) \ + diag_output_mod.$(FC_MODEXT) \ + diag_util_mod.$(FC_MODEXT) \ + diag_table_mod.$(FC_MODEXT) \ + fms_diag_time_reduction_mod.$(FC_MODEXT) \ + fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_bbox_mod.$(FC_MODEXT) \ + fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ + fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \ + diag_manager_mod.$(FC_MODEXT) \ + include/fms_diag_fieldbuff_update.inc \ + include/fms_diag_fieldbuff_update.fh nodist_include_HEADERS = $(MODFILES) BUILT_SOURCES = $(MODFILES) diff --git a/fms/Makefile.am b/fms/Makefile.am index 8f8c58525b..84e2287b24 100644 --- a/fms/Makefile.am +++ b/fms/Makefile.am @@ -31,49 +31,50 @@ noinst_LTLIBRARIES = libfms.la # Each convenience library depends on its source. libfms_la_SOURCES = \ - fms.F90 \ - include/fms.inc \ - include/fms_r4.fh \ - include/fms_r8.fh \ - fms_io.F90 \ - fms_io_unstructured_field_exist.inc \ - fms_io_unstructured_get_file_name.inc \ - fms_io_unstructured_register_restart_axis.inc \ - fms_io_unstructured_setup_one_field.inc read_data_4d.inc \ - fms_io_unstructured_file_unit.inc \ - fms_io_unstructured_get_file_unit.inc \ - fms_io_unstructured_register_restart_field.inc \ - read_data_2d.inc \ - write_data.inc \ - fms_io_unstructured_get_field_size.inc \ - fms_io_unstructured_read.inc \ - fms_io_unstructured_save_restart.inc \ - read_data_3d.inc + fms.F90 \ + fms_stacksize.c \ + include/fms.inc \ + include/fms_r4.fh \ + include/fms_r8.fh \ + fms_io.F90 \ + fms_io_unstructured_field_exist.inc \ + fms_io_unstructured_get_file_name.inc \ + fms_io_unstructured_register_restart_axis.inc \ + fms_io_unstructured_setup_one_field.inc read_data_4d.inc \ + fms_io_unstructured_file_unit.inc \ + fms_io_unstructured_get_file_unit.inc \ + fms_io_unstructured_register_restart_field.inc \ + read_data_2d.inc \ + write_data.inc \ + fms_io_unstructured_get_field_size.inc \ + fms_io_unstructured_read.inc \ + fms_io_unstructured_save_restart.inc \ + read_data_3d.inc fms_mod.$(FC_MODEXT): fms_io_mod.$(FC_MODEXT) \ - fms.F90 \ - include/fms.inc \ - include/fms_r4.fh \ - include/fms_r8.fh + fms.F90 \ + include/fms.inc \ + include/fms_r4.fh \ + include/fms_r8.fh fms_io_mod.$(FC_MODEXT): fms_io_unstructured_field_exist.inc \ - fms_io_unstructured_get_file_name.inc \ - fms_io_unstructured_register_restart_axis.inc \ - fms_io_unstructured_setup_one_field.inc read_data_4d.inc \ - fms_io_unstructured_file_unit.inc \ - fms_io_unstructured_get_file_unit.inc \ - fms_io_unstructured_register_restart_field.inc \ - read_data_2d.inc \ - write_data.inc \ - fms_io_unstructured_get_field_size.inc \ - fms_io_unstructured_read.inc \ - fms_io_unstructured_save_restart.inc \ - read_data_3d.inc + fms_io_unstructured_get_file_name.inc \ + fms_io_unstructured_register_restart_axis.inc \ + fms_io_unstructured_setup_one_field.inc read_data_4d.inc \ + fms_io_unstructured_file_unit.inc \ + fms_io_unstructured_get_file_unit.inc \ + fms_io_unstructured_register_restart_field.inc \ + read_data_2d.inc \ + write_data.inc \ + fms_io_unstructured_get_field_size.inc \ + fms_io_unstructured_read.inc \ + fms_io_unstructured_save_restart.inc \ + read_data_3d.inc # Mod files are built and then installed as headers. MODFILES = \ - fms_io_mod.$(FC_MODEXT) \ - fms_mod.$(FC_MODEXT) + fms_io_mod.$(FC_MODEXT) \ + fms_mod.$(FC_MODEXT) BUILT_SOURCES = $(MODFILES) nodist_include_HEADERS = $(MODFILES) $(FMS_INC_FILES) diff --git a/fms/fms.F90 b/fms/fms.F90 index 7067b86aee..2ac9393b48 100644 --- a/fms/fms.F90 +++ b/fms/fms.F90 @@ -143,7 +143,8 @@ module fms_mod mpp_get_compute_domain, mpp_get_global_domain, & mpp_get_data_domain -use mpp_io_mod, only: mpp_io_init, mpp_open, mpp_close, & +#ifdef use_deprecated_io +use mpp_io_mod, only: mpp_io_init, mpp_open, mpp_close, & MPP_ASCII, MPP_NATIVE, MPP_IEEE32, MPP_NETCDF, & MPP_RDONLY, MPP_WRONLY, MPP_APPEND, MPP_OVERWR, & MPP_SEQUENTIAL, MPP_DIRECT, & @@ -158,6 +159,7 @@ module fms_mod open_file, open_direct_file, get_mosaic_tile_grid, & get_mosaic_tile_file, get_global_att_value, file_exist, field_exist, & set_domain, nullify_domain +#endif use fms2_io_mod, only: fms2_io_init use memutils_mod, only: print_memuse_stats, memutils_init use grid2_mod, only: grid_init, grid_end @@ -173,6 +175,7 @@ module fms_mod public :: fms_init, fms_end ! routines for opening/closing specific types of file +#ifdef use_deprecated_io public :: open_namelist_file, open_restart_file, & open_ieee32_file, close_file, & open_file, open_direct_file @@ -186,15 +189,19 @@ module fms_mod public :: get_mosaic_tile_grid, get_mosaic_tile_file ! miscellaneous i/o routines -public :: file_exist, check_nml_error, field_exist, & - error_mesg, fms_error_handler +public :: file_exist, field_exist +#endif +public ::check_nml_error, error_mesg, fms_error_handler + ! version logging routine (originally from fms_io) public :: write_version_number ! miscellaneous utilities (non i/o) public :: lowercase, uppercase, & - string_array_index, monotonic_array, & - set_domain, nullify_domain + string_array_index, monotonic_array +#ifdef use_deprecated_io +public :: set_domain, nullify_domain +#endif ! public mpp interfaces public :: mpp_error, NOTE, WARNING, FATAL, & @@ -213,7 +220,9 @@ module fms_mod public :: string ! public mpp-io interfaces +#ifdef use_deprecated_io public :: do_cf_compliance +#endif interface monotonic_array module procedure :: monotonic_array_r4, monotonic_array_r8 @@ -323,7 +332,14 @@ subroutine fms_init (localcomm, alt_input_nml_path) !--- needed to output the version number of constants_mod to the logfile --- use constants_mod, only: constants_version=>version !pjp: PI not computed +#ifdef use_deprecated_io use fms_io_mod, only: fms_io_version +#endif + + interface + subroutine maximize_system_stacksize_limit() bind(C) + end subroutine + end interface integer, intent(in), optional :: localcomm character(len=*), intent(in), optional :: alt_input_nml_path @@ -333,6 +349,10 @@ subroutine fms_init (localcomm, alt_input_nml_path) if (module_is_initialized) return ! return silently if already called module_is_initialized = .true. + +!---- Raise the system stack size limit to its maximum permissible value ---- + call maximize_system_stacksize_limit + !---- initialize mpp routines ---- if(present(localcomm)) then if(present(alt_input_nml_path)) then @@ -348,10 +368,14 @@ subroutine fms_init (localcomm, alt_input_nml_path) endif endif call mpp_domains_init() +#ifdef use_deprecated_io call fms_io_init() +#endif !! write_version_number is inaccesible from fms_io_mod so write it from here if not written if(.not.fms_io_initialized) then +#ifdef use_deprecated_io call write_version_number("FMS_IO_MOD", fms_io_version) +#endif fms_io_initialized = .true. endif call fms2_io_init() @@ -446,7 +470,9 @@ subroutine fms_end ( ) if (.not.module_is_initialized) return ! return silently ! call fms_io_exit ! now called from coupler_end call grid_end +#ifdef use_deprecated_io call mpp_io_exit +#endif call mpp_domains_exit call mpp_exit module_is_initialized =.FALSE. diff --git a/fms/fms_io.F90 b/fms/fms_io.F90 index ce1069948e..06ca5a0627 100644 --- a/fms/fms_io.F90 +++ b/fms/fms_io.F90 @@ -86,6 +86,7 @@ !> @addtogroup fms_io_mod !> @{ module fms_io_mod +#ifdef use_deprecated_io #include @@ -8706,7 +8707,7 @@ end function get_great_circle_algorithm #include #include !---------- - +#endif end module fms_io_mod !> @} ! close documentation grouping diff --git a/fms/fms_stacksize.c b/fms/fms_stacksize.c new file mode 100644 index 0000000000..7631656475 --- /dev/null +++ b/fms/fms_stacksize.c @@ -0,0 +1,33 @@ +/*********************************************************************** + * GNU Lesser General Public License + * + * This file is part of the GFDL Flexible Modeling System (FMS). + * + * FMS is free software: you can redistribute it and/or modify it under + * the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or (at + * your option) any later version. + * + * FMS is distributed in the hope that it will be useful, but WITHOUT + * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + * FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License + * for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with FMS. If not, see . + **********************************************************************/ + +#include + +/* + * Set the stack size limit to its maximum permissible value + */ + +void maximize_system_stacksize_limit() +{ + struct rlimit stacksize; + + getrlimit(RLIMIT_STACK, &stacksize); + stacksize.rlim_cur = stacksize.rlim_max; + setrlimit(RLIMIT_STACK, &stacksize); +} diff --git a/libFMS.F90 b/libFMS.F90 index 7e5a35bc50..02b54df82a 100644 --- a/libFMS.F90 +++ b/libFMS.F90 @@ -28,11 +28,18 @@ !! and routines. Overloaded type operators/assignments cannot be imported individually !! (ie. `use fms, only: OPERATOR(*)` includes any defined '*' operators within FMS). !! -!! Remappings due to conflicts: +!! Renaming scheme: +!! Routines and variables: fms__routine_name +!! Types: FmsModuleNameTypeName !! -!! get_mosaic_tile_grid from mosaic2(fms2_io) => mosaic2_get_mosaic_tile_grid +!! Exceptions (mainly for rep: +!! - Parameter values are kept their original names +!! - If module name is already included (like in init routines) only fms prefix will be added. +!! - Similarly if theres a redundant module name included already included it will not be repeated +!! (ie. mpp_update_domains => fms_mpp_domains_update_domains) +!! - Override interfaces for operators and assignment are provided !! -!! read_data from interpolator_mod(fms2_io) => interpolator_read_data +!! Remappings due to name conflicts: !! !! ZERO from interpolator_mod(mpp_parameter) => INTERPOLATOR_ZERO !! @@ -41,7 +48,7 @@ !! Not in this module: !! !! axis_utils_mod, fms_io_mod, time_interp_external_mod -!! get_grid_version_mpp_mod, mpp_io_mod, mosaic_mod, +!! get_grid_version_mpp_mod, mpp_io_mod, mosaic_mod, & !! fms_mod(partial, old io excluded), drifters modules !! constants_mod (FMSconstants should be used externally) !! grid_mod, mosaic_mod @@ -65,215 +72,458 @@ module fms fms_affinity_set !> amip_interp - use amip_interp_mod, only: amip_interp_init, get_amip_sst, get_amip_ice, & - amip_interp_new,amip_interp_del, amip_interp_type, & - assignment(=), i_sst, j_sst, sst_ncep, sst_anom, & - forecast_mode, use_ncep_sst + use amip_interp_mod, only: fms_amip_interp_init => amip_interp_init, & + fms_amip_interp_get_amip_sst => get_amip_sst, & + fms_amip_interp_get_amip_ice => get_amip_ice, & + fms_amip_interp_new => amip_interp_new, & + fms_amip_interp_del => amip_interp_del, & + FmsAmipInterp_type => amip_interp_type, & + assignment(=), & + fms_amip_interp_i_sst => i_sst, & + fms_amip_interp_j_sst => j_sst, & + fms_amip_interp_sst_ncep => sst_ncep, & + fms_amip_interp_sst_anom => sst_anom, & + fms_amip_interp_forecast_mode=> forecast_mode, & + fms_amip_interp_use_ncep_sst => use_ncep_sst !> astronomy - use astronomy_mod, only: astronomy_init, get_period, set_period, & - set_orbital_parameters, get_orbital_parameters, & - set_ref_date_of_ae, get_ref_date_of_ae, & - diurnal_solar, daily_mean_solar, annual_mean_solar, & - astronomy_end, universal_time, orbital_time + use astronomy_mod, only: fms_astronomy_init => astronomy_init, & + fms_astronomy_get_period => get_period, & + fms_astronomy_set_period => set_period, & + fms_astronomy_set_orbital_parameters => set_orbital_parameters, & + fms_astronomy_get_orbital_parameters => get_orbital_parameters, & + fms_astronomy_set_ref_date_of_ae => set_ref_date_of_ae, & + fms_astronomy_get_ref_date_of_ae => get_ref_date_of_ae, & + fms_astronomy_diurnal_solar => diurnal_solar, & + fms_astronomy_daily_mean_solar => daily_mean_solar, & + fms_astronomy_annual_mean_solar => annual_mean_solar, & + fms_astronomy_end => astronomy_end, & + fms_astronomy_universal_time => universal_time, & + fms_astronomy_orbital_time => orbital_time !> axis_utils - use axis_utils2_mod, only: get_axis_cart, get_axis_modulo, lon_in_range, & - tranlon, frac_index, nearest_index, interp_1d, & - get_axis_modulo_times, axis_edges + use axis_utils2_mod, only: fms_axis_utils2_get_axis_cart => get_axis_cart, & + fms_axis_utils2_get_axis_modulo => get_axis_modulo, & + fms_axis_utils2_lon_in_range => lon_in_range, & + fms_axis_utils2_tranlon => tranlon, & + fms_axis_utils2_frac_index => frac_index, & + fms_axis_utils2_nearest_index => nearest_index, & + fms_axis_utils2_interp_1d => interp_1d, & + fms_axis_utils2_get_axis_modulo_times => get_axis_modulo_times, & + fms_axis_utils2_axis_edges => axis_edges !>block_control - use block_control_mod, only: block_control_type, define_blocks, & - define_blocks_packed + use block_control_mod, only: FmsBlockControl_type => block_control_type, & + fms_block_control_define_blocks => define_blocks, & + fms_block_control_define_blocks_packed => define_blocks_packed !> column_diagnostics - use column_diagnostics_mod, only: column_diagnostics_init, & - initialize_diagnostic_columns, & - column_diagnostics_header, & - close_column_diagnostics_units + use column_diagnostics_mod, only: fms_column_diagnostics_init => column_diagnostics_init, & + fms_column_diagnostics_initialize_diagnostic_columns => & + initialize_diagnostic_columns, & + fms_column_diagnostics_header => column_diagnostics_header, & + fms_column_diagnostics_close_units => close_column_diagnostics_units !> coupler - use coupler_types_mod, only: coupler_types_init, coupler_type_copy, & - coupler_type_spawn, coupler_type_set_diags, & - coupler_type_write_chksums, coupler_type_send_data, & - coupler_type_data_override, coupler_type_register_restarts, & - coupler_type_restore_state, coupler_type_increment_data, & - coupler_type_rescale_data, coupler_type_copy_data, & - coupler_type_redistribute_data, coupler_type_destructor, & - coupler_type_initialized, coupler_type_extract_data, & - coupler_type_set_data,coupler_type_copy_1d_2d, & - coupler_type_copy_1d_3d, coupler_3d_values_type, & - coupler_3d_field_type, coupler_3d_bc_type, & - coupler_2d_values_type, coupler_2d_field_type, & - coupler_2d_bc_type, coupler_1d_values_type, & - coupler_1d_field_type, coupler_1d_bc_type, & - ind_pcair, ind_u10, ind_psurf, ind_alpha, ind_csurf, & - ind_sc_no, ind_flux, ind_deltap, ind_kw, ind_flux0, & - ind_deposition, ind_runoff - use ensemble_manager_mod, only: ensemble_manager_init, get_ensemble_id, get_ensemble_size, & - get_ensemble_pelist, ensemble_pelist_setup, & - get_ensemble_filter_pelist - use atmos_ocean_fluxes_mod, only: atmos_ocean_fluxes_init, atmos_ocean_type_fluxes_init, & - aof_set_coupler_flux + use coupler_types_mod, only: fms_coupler_types_init => coupler_types_init, & + fms_coupler_type_copy => coupler_type_copy, & + fms_coupler_type_spawn => coupler_type_spawn, & + fms_coupler_type_set_diags => coupler_type_set_diags, & + fms_coupler_type_write_chksums => coupler_type_write_chksums, & + fms_coupler_type_send_data => coupler_type_send_data, & + fms_coupler_type_data_override => coupler_type_data_override, & + fms_coupler_type_register_restarts => coupler_type_register_restarts, & + fms_coupler_type_restore_state => coupler_type_restore_state, & + fms_coupler_type_increment_data => coupler_type_increment_data, & + fms_coupler_type_rescale_data => coupler_type_rescale_data, & + fms_coupler_type_copy_data => coupler_type_copy_data, & + fms_coupler_type_redistribute_data => coupler_type_redistribute_data, & + fms_coupler_type_destructor => coupler_type_destructor, & + fms_coupler_type_initialized => coupler_type_initialized, & + fms_coupler_type_extract_data => coupler_type_extract_data, & + fms_coupler_type_set_data => coupler_type_set_data, & + fms_coupler_type_copy_1d_2d => coupler_type_copy_1d_2d, & + fms_coupler_type_copy_1d_3d => coupler_type_copy_1d_3d, & + FmsCoupler3dValues_type => coupler_3d_values_type, & + FmsCoupler3dField_type => coupler_3d_field_type, & + FmsCoupler3dBC_type => coupler_3d_bc_type, & + FmsCoupler2dValues_type => coupler_2d_values_type, & + FmsCoupler2dField_type => coupler_2d_field_type, & + FmsCoupler2dBC_type => coupler_2d_bc_type, & + FmsCoupler1dValues_type => coupler_1d_values_type, & + FmsCoupler1dField_type => coupler_1d_field_type, & + FmsCoupler1dBC_type => coupler_1d_bc_type, & + fms_coupler_ind_pcair => ind_pcair, & + fms_coupler_ind_u10 => ind_u10, & + fms_coupler_ind_psurf => ind_psurf, & + fms_coupler_ind_alpha => ind_alpha, & + fms_coupler_ind_csurf => ind_csurf, & + fms_coupler_ind_sc_no => ind_sc_no, & + fms_coupler_ind_flux => ind_flux, & + fms_coupler_ind_deltap => ind_deltap, & + fms_coupler_ind_kw => ind_kw, & + fms_coupler_ind_flux0 => ind_flux0, & + fms_coupler_ind_deposition => ind_deposition,& + fms_coupler_ind_runoff => ind_runoff + use ensemble_manager_mod, only: fms_ensemble_manager_init => ensemble_manager_init, & + fms_ensemble_manager_get_ensemble_id => get_ensemble_id, & + fms_ensemble_manager_get_ensemble_size => get_ensemble_size, & + fms_ensemble_manager_get_ensemble_pelist => get_ensemble_pelist, & + fms_ensemble_manager_ensemble_pelist_setup => ensemble_pelist_setup, & + fms_ensemble_manager_get_ensemble_filter_pelist => get_ensemble_filter_pelist + use atmos_ocean_fluxes_mod, only: fms_atmos_ocean_fluxes_init => atmos_ocean_fluxes_init, & + fms_atmos_ocean_type_fluxes_init => atmos_ocean_type_fluxes_init, & + fms_atmos_ocean_fluxes_set_coupler_flux => aof_set_coupler_flux !> data_override - use data_override_mod, only: data_override_init, data_override, & - data_override_unset_domains, data_override_UG + use data_override_mod, only: fms_data_override_init => data_override_init, & + fms_data_override => data_override, & + fms_data_override_unset_domains => data_override_unset_domains, & + fms_data_override_UG => data_override_UG !> diag_integral - use diag_integral_mod, only: diag_integral_init, diag_integral_field_init, & - sum_diag_integral_field, diag_integral_output, & - diag_integral_end + use diag_integral_mod, only: fms_diag_integral_init => diag_integral_init, & + fms_diag_integral_field_init => diag_integral_field_init, & + fms_sum_diag_integral_field => sum_diag_integral_field, & + fms_diag_integral_output => diag_integral_output, & + fms_diag_integral_end => diag_integral_end !> diag_manager !! includes imports from submodules made public - use diag_manager_mod, only: diag_manager_init, send_data, send_tile_averaged_data, & - diag_manager_end, register_diag_field, register_static_field, & - diag_axis_init, get_base_time, get_base_date, need_data, & - DIAG_ALL, DIAG_OCEAN, DIAG_OTHER, get_date_dif, DIAG_SECONDS,& - DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, & - get_diag_global_att, set_diag_global_att, diag_field_add_attribute, & - diag_field_add_cell_measures, get_diag_field_id, & - diag_axis_add_attribute, diag_grid_init, diag_grid_end, & - diag_manager_set_time_end, diag_send_complete, & - diag_send_complete_instant, DIAG_FIELD_NOT_FOUND, & - CMOR_MISSING_VALUE, null_axis_id + use diag_manager_mod, only: fms_diag_init => diag_manager_init, & + fms_diag_send_data => send_data, & + fms_diag_send_tile_averaged_data => send_tile_averaged_data, & + fms_diag_end => diag_manager_end, & + fms_diag_register_diag_field => register_diag_field, & + fms_diag_register_static_field => register_static_field, & + fms_diag_axis_init => diag_axis_init, & + fms_diag_get_base_time => get_base_time, & + fms_diag_get_base_date => get_base_date, & + fms_diag_need_data => need_data, & + DIAG_ALL, & + DIAG_OCEAN, & + DIAG_OTHER, & + fms_get_date_dif => get_date_dif, & + DIAG_SECONDS,& + DIAG_MINUTES, & + DIAG_HOURS, & + DIAG_DAYS, & + DIAG_MONTHS, & + DIAG_YEARS, & + fms_diag_get_global_att => get_diag_global_att, & + fms_diag_set_global_att => set_diag_global_att, & + fms_diag_field_add_attribute => diag_field_add_attribute, & + fms_diag_field_add_cell_measures => diag_field_add_cell_measures, & + fms_diag_get_field_id => get_diag_field_id, & + fms_diag_axis_add_attribute => diag_axis_add_attribute, & + fms_diag_grid_init => diag_grid_init, & + fms_diag_grid_end => diag_grid_end, & + fms_diag_set_time_end => diag_manager_set_time_end, & + fms_diag_send_complete => diag_send_complete, & + fms_diag_send_complete_instant => diag_send_complete_instant, & + DIAG_FIELD_NOT_FOUND, & + CMOR_MISSING_VALUE, & + null_axis_id !> exchange - use xgrid_mod, only: xmap_type, setup_xmap, set_frac_area, put_to_xgrid, & - get_from_xgrid, xgrid_count, some, conservation_check, & - xgrid_init, AREA_ATM_SPHERE, AREA_OCN_SPHERE, AREA_ATM_MODEL, & - AREA_OCN_MODEL, get_ocean_model_area_elements, grid_box_type, & - get_xmap_grid_area, put_to_xgrid_ug, get_from_xgrid_ug, & - set_frac_area_ug, FIRST_ORDER, SECOND_ORDER, stock_move_ug, & - stock_move, stock_type, stock_print, get_index_range, & - stock_integrate_2d + use xgrid_mod, only: FmsXgridXmap_type => xmap_type, & + fms_xgrid_setup_xmap => setup_xmap, & + fms_xgrid_set_frac_area => set_frac_area, & + fms_xgrid_put_to_xgrid => put_to_xgrid, & + fms_xgrid_get_from_xgrid => get_from_xgrid, & + fms_xgrid_count => xgrid_count, & + fms_xgrid_some => some, & + fms_xgrid_conservation_check => conservation_check, & + fms_xgrid_init => xgrid_init, & + AREA_ATM_SPHERE, AREA_OCN_SPHERE, AREA_ATM_MODEL, AREA_OCN_MODEL, & + fms_xgrid_get_ocean_model_area_elements => get_ocean_model_area_elements, & + FmsXgridGridBox_type => grid_box_type, & + fms_xgrid_get_xmap_grid_area => get_xmap_grid_area, & + fms_xgrid_put_to_xgrid_ug => put_to_xgrid_ug, & + fms_xgrid_get_from_xgrid_ug => get_from_xgrid_ug, & + fms_xgrid_set_frac_area_ug => set_frac_area_ug, & + FIRST_ORDER, SECOND_ORDER, & + fms_xgrid_stock_move_ug => stock_move_ug, & + fms_xgrid_stock_move => stock_move, & + FmsXgridStock_type => stock_type, & + fms_xgrid_stock_print => stock_print, & + fms_xgrid_get_index_range => get_index_range, & + fms_xgrid_stock_integrate_2d => stock_integrate_2d use stock_constants_mod, only: NELEMS, ISTOCK_WATER, ISTOCK_HEAT, ISTOCK_SALT, & - ISTOCK_TOP, ISTOCK_BOTTOM, ISTOCK_SIDE, stocks_file, & - stocks_report, stocks_report_init, stocks_set_init_time, & - atm_stock, ocn_stock, lnd_stock, ice_stock + ISTOCK_TOP, ISTOCK_BOTTOM, ISTOCK_SIDE, & + fms_stock_constants_stocks_file => stocks_file, & + fms_stock_constants_stocks_report => stocks_report, & + fms_stocks_report_init => stocks_report_init, & + fms_stocks_set_init_time => stocks_set_init_time, & + fms_stock_constants_atm_stock => atm_stock, & + fms_stock_constants_ocn_stock => ocn_stock, & + fms_stock_constants_lnd_stock => lnd_stock, & + fms_stock_constants_ice_stock => ice_stock !> field manager - use field_manager_mod, only: field_manager_init, field_manager_end, find_field_index, & - get_field_info, & - get_field_method, get_field_methods, parse, fm_change_list, & - fm_change_root, fm_dump_list, fm_exists, fm_get_index, & - fm_get_current_list, fm_get_length, fm_get_type, fm_get_value, & - fm_init_loop, & - fm_loop_over_list, fm_new_list, fm_new_value, & - fm_reset_loop, fm_return_root, & - fm_modify_name, fm_query_method, fm_find_methods, fm_copy_list, & - fm_field_name_len, fm_path_name_len, & - fm_string_len, fm_type_name_len, NUM_MODELS, NO_FIELD, & - MODEL_ATMOS, MODEL_OCEAN, MODEL_LAND, MODEL_ICE, MODEL_COUPLER, & - method_type, method_type_short, & - method_type_very_short, fm_list_iter_type, default_method - use fm_util_mod, only: fm_util_start_namelist, fm_util_end_namelist, & - fm_util_check_for_bad_fields, fm_util_set_caller, & - fm_util_reset_caller, fm_util_set_no_overwrite, & - fm_util_reset_no_overwrite, fm_util_set_good_name_list, & - fm_util_reset_good_name_list, fm_util_get_length, & - fm_util_get_integer, fm_util_get_logical, fm_util_get_real, & - fm_util_get_string, fm_util_get_integer_array, & - fm_util_get_logical_array, fm_util_get_real_array, & - fm_util_get_string_array, fm_util_set_value, & - fm_util_set_value_integer_array, fm_util_set_value_logical_array, & - fm_util_set_value_real_array, fm_util_set_value_string_array, & - fm_util_set_value_integer, fm_util_set_value_logical, & - fm_util_set_value_real, fm_util_set_value_string, & - fm_util_get_index_list, fm_util_get_index_string, & - fm_util_default_caller + use field_manager_mod, only: fms_field_manager_init => field_manager_init, & + fms_field_manager_end => field_manager_end, & + fms_field_manager_find_field_index => find_field_index, & + fms_field_manager_get_field_info => get_field_info, & + fms_field_manager_get_field_method => get_field_method, & + fms_field_manager_get_field_methods => get_field_methods, & + fms_field_manager_parse => parse, & + fms_field_manager_fm_change_list => fm_change_list, & + fms_field_manager_fm_change_root => fm_change_root, & + fms_field_manager_fm_dump_list => fm_dump_list, & + fms_field_manager_fm_exists => fm_exists, & + fms_field_manager_fm_get_index => fm_get_index, & + fms_field_manager_fm_get_current_list => fm_get_current_list, & + fms_field_manager_fm_get_length => fm_get_length, & + fms_field_manager_fm_get_type => fm_get_type, & + fms_field_manager_fm_get_value => fm_get_value, & + fms_field_manager_fm_init_loop => fm_init_loop, & + fms_field_manager_fm_loop_over_list => fm_loop_over_list, & + fms_field_manager_fm_new_list => fm_new_list, & + fms_field_manager_fm_new_value => fm_new_value, & + fms_field_manager_fm_reset_loop => fm_reset_loop, & + fms_field_manager_fm_return_root => fm_return_root, & + fms_field_manager_fm_modify_name => fm_modify_name, & + fms_field_manager_fm_query_method => fm_query_method, & + fms_field_manager_fm_find_methods => fm_find_methods, & + fms_field_manager_fm_copy_list => fm_copy_list, & + fms_field_manager_fm_field_name_len => fm_field_name_len, & + fms_field_manager_fm_path_name_len => fm_path_name_len, & + fms_field_manager_fm_string_len => fm_string_len, & + fms_field_manager_fm_type_name_len => fm_type_name_len, & + NUM_MODELS, NO_FIELD, MODEL_ATMOS, MODEL_OCEAN, MODEL_LAND, MODEL_ICE, MODEL_COUPLER, & + FmsFieldManagerMethod_type => method_type, & + FmsFieldManagerMethodShort_type => method_type_short, & + FmsFieldManagerMethodVeryShort_type => method_type_very_short, & + FmsFieldManagerListIterator_type => fm_list_iter_type, & + fms_field_manager_default_method => default_method + use fm_util_mod, only: fms_fm_util_start_namelist => fm_util_start_namelist, & + fms_fm_util_end_namelist => fm_util_end_namelist, & + fms_fm_util_check_for_bad_fields => fm_util_check_for_bad_fields, & + fms_fm_util_set_caller => fm_util_set_caller, & + fms_fm_util_reset_caller => fm_util_reset_caller, & + fms_fm_util_set_no_overwrite => fm_util_set_no_overwrite, & + fms_fm_util_reset_no_overwrite => fm_util_reset_no_overwrite, & + fms_fm_util_set_good_name_list => fm_util_set_good_name_list, & + fms_fm_util_reset_good_name_list => fm_util_reset_good_name_list, & + fms_fm_util_get_length => fm_util_get_length, & + fms_fm_util_get_integer => fm_util_get_integer, & + fms_fm_util_get_logical => fm_util_get_logical, & + fms_fm_util_get_real => fm_util_get_real, & + fms_fm_util_get_string => fm_util_get_string, & + fms_fm_util_get_integer_array => fm_util_get_integer_array, & + fms_fm_util_get_logical_array => fm_util_get_logical_array, & + fms_fm_util_get_real_array => fm_util_get_real_array, & + fms_fm_util_get_string_array => fm_util_get_string_array, & + fms_fm_util_set_value => fm_util_set_value, & + fms_fm_util_set_value_integer_array => fm_util_set_value_integer_array, & + fms_fm_util_set_value_logical_array => fm_util_set_value_logical_array, & + fms_fm_util_set_value_real_array => fm_util_set_value_real_array, & + fms_fm_util_set_value_string_array => fm_util_set_value_string_array, & + fms_fm_util_set_value_integer => fm_util_set_value_integer, & + fms_fm_util_set_value_logical => fm_util_set_value_logical, & + fms_fm_util_set_value_real => fm_util_set_value_real, & + fms_fm_util_set_value_string => fm_util_set_value_string, & + fms_fm_util_get_index_list => fm_util_get_index_list, & + fms_fm_util_get_index_string => fm_util_get_index_string, & + fms_fm_util_default_caller => fm_util_default_caller !> fms2_io + !! TODO need to see opinions on these + !! not sure if we need fms_ prefix for routines + !! types do not follow our typical naming convention(no _type and uses camel case instead of _ spacing) use fms2_io_mod, only: unlimited, FmsNetcdfFile_t, FmsNetcdfDomainFile_t, & - FmsNetcdfUnstructuredDomainFile_t, open_file, open_virtual_file, & - close_file, register_axis, register_field, register_restart_field, & - write_data, read_data, write_restart, write_new_restart, & - read_restart, read_new_restart, global_att_exists, & - variable_att_exists, register_global_attribute, & - register_variable_attribute, get_global_attribute, & - get_variable_attribute, get_num_dimensions, & - get_dimension_names, dimension_exists, is_dimension_unlimited, & - get_dimension_size, get_num_variables, get_variable_names, & - variable_exists, get_variable_num_dimensions, & - get_variable_dimension_names, get_variable_size, & - get_compute_domain_dimension_indices, & - get_global_io_domain_indices, Valid_t, get_valid, is_valid, & - get_unlimited_dimension_name, get_variable_unlimited_dimension_index, & - file_exists, compressed_start_and_count, get_variable_sense, & - get_variable_missing, get_variable_units, get_time_calendar, & - open_check, is_registered_to_restart, check_if_open, & - set_fileobj_time_name, is_dimension_registered, & - fms2_io_init, get_mosaic_tile_grid, & - write_restart_bc, read_restart_bc, get_filename_appendix, & !> 2021.02-a1 - set_filename_appendix, get_instance_filename, & - nullify_filename_appendix, ascii_read, get_mosaic_tile_file, & - parse_mask_table + FmsNetcdfUnstructuredDomainFile_t, & + Valid_t, & + fms2_io_open_file => open_file, & + fms2_io_open_virtual_file => open_virtual_file, & + fms2_io_close_file => close_file, & + fms2_io_register_axis => register_axis, & + fms2_io_register_field => register_field, & + fms2_io_register_restart_field => register_restart_field, & + fms2_io_write_data => write_data, & + fms2_io_read_data => read_data, & + fms2_io_write_restart => write_restart, & + fms2_io_write_new_restart => write_new_restart, & + fms2_io_read_restart => read_restart, & + fms2_io_read_new_restart => read_new_restart, & + fms2_io_global_att_exists => global_att_exists, & + fms2_io_variable_att_exists => variable_att_exists, & + fms2_io_register_global_attribute => register_global_attribute, & + fms2_io_register_variable_attribute => register_variable_attribute, & + fms2_io_get_global_attribute => get_global_attribute, & + fms2_io_get_variable_attribute => get_variable_attribute, & + fms2_io_get_num_dimensions => get_num_dimensions, & + fms2_io_get_dimension_names => get_dimension_names, & + fms2_io_dimension_exists => dimension_exists, & + fms2_io_is_dimension_unlimited => is_dimension_unlimited, & + fms2_io_get_dimension_size => get_dimension_size, & + fms2_io_get_num_variables => get_num_variables, & + fms2_io_get_variable_names => get_variable_names, & + fms2_io_variable_exists => variable_exists, & + fms2_io_get_variable_num_dimensions => get_variable_num_dimensions, & + fms2_io_get_variable_dimension_names => get_variable_dimension_names, & + fms2_io_get_variable_size => get_variable_size, & + fms2_io_get_compute_domain_dimension_indices => get_compute_domain_dimension_indices, & + fms2_io_get_global_io_domain_indices => get_global_io_domain_indices, & + fms2_io_get_valid => get_valid, & + fms2_io_is_valid => is_valid, & + fms2_io_get_unlimited_dimension_name => get_unlimited_dimension_name, & + fms2_io_get_variable_unlimited_dimension_index => get_variable_unlimited_dimension_index, & + fms2_io_file_exists => file_exists, & + fms2_io_compressed_start_and_count => compressed_start_and_count, & + fms2_io_get_variable_sense => get_variable_sense, & + fms2_io_get_variable_missing => get_variable_missing, & + fms2_io_get_variable_units => get_variable_units, & + fms2_io_get_time_calendar => get_time_calendar, & + fms2_io_open_check => open_check, & + fms2_io_is_registered_to_restart => is_registered_to_restart, & + fms2_io_check_if_open => check_if_open, & + fms2_io_set_fileobj_time_name => set_fileobj_time_name, & + fms2_io_is_dimension_registered => is_dimension_registered, & + fms2_io_fms2_io_init => fms2_io_init, & + fms2_io_get_mosaic_tile_grid => get_mosaic_tile_grid, & + fms2_io_write_restart_bc => write_restart_bc, & + fms2_io_read_restart_bc => read_restart_bc, & + fms2_io_get_filename_appendix => get_filename_appendix, & + fms2_io_set_filename_appendix => set_filename_appendix, & + fms2_io_get_instance_filename => get_instance_filename, & + fms2_io_nullify_filename_appendix => nullify_filename_appendix, & + fms2_io_ascii_read => ascii_read, & + fms2_io_get_mosaic_tile_file => get_mosaic_tile_file, & + fms2_io_parse_mask_table => parse_mask_table ! used via fms2_io - ! fms_io_utils_mod, fms_netcdf_domain_io_mod, netcdf_io_mod, + ! fms_io_utils_mod, fms_netcdf_domain_io_mod, netcdf_io_mod, & ! fms_netcdf_unstructured_domain_io_mod, blackboxio !> fms !! routines that don't conflict with fms2_io - use fms_mod, only: fms_init, fms_end, error_mesg, fms_error_handler, check_nml_error, & - monotonic_array, string_array_index, clock_flag_default, & - print_memory_usage, write_version_number + use fms_mod, only: fms_init, fms_end, error_mesg, fms_error_handler, & + check_nml_error, & + fms_monotonic_array => monotonic_array, fms_string_array_index => string_array_index, & + fms_clock_flag_default => clock_flag_default, fms_print_memory_usage => print_memory_usage, & + fms_write_version_number => write_version_number !> horiz_interp - use horiz_interp_mod, only: horiz_interp, horiz_interp_new, horiz_interp_del, & - horiz_interp_init, horiz_interp_end - use horiz_interp_type_mod, only: horiz_interp_type, assignment(=), CONSERVE, & - BILINEAR, SPHERICA, BICUBIC, stats + use horiz_interp_mod, only: fms_horiz_interp => horiz_interp, fms_horiz_interp_new => horiz_interp_new, & + fms_horiz_interp_del => horiz_interp_del, fms_horiz_interp_init => horiz_interp_init, & + fms_horiz_interp_end => horiz_interp_end + use horiz_interp_type_mod, only: FmsHorizInterp_type => horiz_interp_type, & + assignment(=), CONSERVE, BILINEAR, SPHERICA, BICUBIC, & + fms_horiz_interp_type_stats => stats !! used via horiz_interp ! horiz_interp_bicubic_mod, horiz_interp_bilinear_mod ! horiz_interp_conserve_mod, horiz_interp_spherical_mod !> interpolator - use interpolator_mod, only: interpolator_init, interpolator, interpolate_type_eq, & - obtain_interpolator_time_slices, unset_interpolator_time_flag, & - interpolator_end, init_clim_diag, query_interpolator, & - interpolate_type, CONSTANT, & - INTERP_WEIGHTED_P, INTERP_LINEAR_P, INTERP_LOG_P, & - INTERPOLATOR_ZERO=>ZERO, & !! conflicts with mpp_parameter's ZERO - interpolator_read_data=>read_data !! conflicts with fms2_io interface + use interpolator_mod, only: fms_interpolator_init => interpolator_init, & + fms_interpolator => interpolator, & + fms_interpolate_type_eq => interpolate_type_eq, & + fms_interpolator_obtain_interpolator_time_slices => obtain_interpolator_time_slices, & + fms_interpolator_unset_interpolator_time_flag => unset_interpolator_time_flag, & + fms_interpolator_end => interpolator_end, & + fms_interpolator_init_clim_diag => init_clim_diag, & + fms_interpolator_query_interpolator => query_interpolator, & + FmsInterpolate_type => interpolate_type, & + CONSTANT, INTERP_WEIGHTED_P, INTERP_LINEAR_P, INTERP_LOG_P, & + FMS_INTERPOLATOR_ZERO=>ZERO, & !! conflicts with mpp_parameter's ZERO + fms_interpolator_read_data=>read_data !> memutils - use memutils_mod, only: memutils_init, print_memuse_stats + use memutils_mod, only: fms_memutils_init => memutils_init, & + fms_memutils_print_memuse_stats => print_memuse_stats !> monin_obukhov - use monin_obukhov_mod, only: monin_obukhov_init, monin_obukhov_end, & - mo_drag, mo_profile, mo_diff, stable_mix - use monin_obukhov_inter, only: monin_obukhov_diff, monin_obukhov_drag_1d, & - monin_obukhov_solve_zeta, monin_obukhov_derivative_t, & - monin_obukhov_derivative_m, monin_obukhov_profile_1d, & - monin_obukhov_integral_m, monin_obukhov_integral_tq, & - monin_obukhov_stable_mix + use monin_obukhov_mod, only: fms_monin_obukhov_init => monin_obukhov_init, & + fms_monin_obukhov_end => monin_obukhov_end, & + fms_monin_obukhov_mo_drag => mo_drag, & + fms_monin_obukhov_mo_profile => mo_profile, & + fms_monin_obukhov_mo_diff => mo_diff, & + fms_monin_obukhov_stable_mix => stable_mix + use monin_obukhov_inter, only: fms_monin_obukhov_inter_diff => monin_obukhov_diff, & + fms_monin_obukhov_inter_drag_1d => monin_obukhov_drag_1d, & + fms_monin_obukhov_inter_solve_zeta => monin_obukhov_solve_zeta, & + fms_monin_obukhov_inter_derivative_t => monin_obukhov_derivative_t, & + fms_monin_obukhov_inter_derivative_m => monin_obukhov_derivative_m, & + fms_monin_obukhov_inter_profile_1d => monin_obukhov_profile_1d, & + fms_monin_obukhov_inter_integral_m => monin_obukhov_integral_m, & + fms_monin_obukhov_inter_integral_tq => monin_obukhov_integral_tq, & + fms_monin_obukhov_inter_stable_mix => monin_obukhov_stable_mix !> mosaic - use mosaic2_mod, only: get_mosaic_ntiles, get_mosaic_ncontacts, & - get_mosaic_grid_sizes, get_mosaic_contact, & - get_mosaic_xgrid_size, get_mosaic_xgrid, & - calc_mosaic_grid_area, calc_mosaic_grid_great_circle_area, & - is_inside_polygon, & - mosaic2_get_mosaic_tile_grid => get_mosaic_tile_grid !overloaded in fms2_io - use grid2_mod, only: get_grid_ntiles, get_grid_size, get_grid_cell_centers, & - get_grid_cell_vertices, get_grid_cell_Area, get_grid_comp_area, & - define_cube_mosaic, get_great_circle_algorithm, grid_init, grid_end - use gradient_mod, only: gradient_cubic, calc_cubic_grid_info + use mosaic2_mod, only: fms_mosaic2_get_mosaic_ntiles => get_mosaic_ntiles, & + fms_mosaic2_get_mosaic_ncontacts => get_mosaic_ncontacts, & + fms_mosaic2_get_mosaic_grid_sizes => get_mosaic_grid_sizes, & + fms_mosaic2_get_mosaic_contact => get_mosaic_contact, & + fms_mosaic2_get_mosaic_xgrid_size => get_mosaic_xgrid_size, & + fms_mosaic2_get_mosaic_xgrid => get_mosaic_xgrid, & + fms_mosaic2_calc_mosaic_grid_area => calc_mosaic_grid_area, & + fms_mosaic2_calc_mosaic_grid_great_circle_area => calc_mosaic_grid_great_circle_area, & + fms_mosaic2_is_inside_polygon => is_inside_polygon, & + fms_mosaic2_get_mosaic_tile_grid => get_mosaic_tile_grid !overloaded in fms2_io + use grid2_mod, only: fms_grid2_get_grid_ntiles => get_grid_ntiles, & + fms_grid2_get_grid_size => get_grid_size, & + fms_grid2_get_grid_cell_centers => get_grid_cell_centers, & + fms_grid2_get_grid_cell_vertices => get_grid_cell_vertices, & + fms_grid2_get_grid_cell_Area => get_grid_cell_Area, & + fms_grid2_get_grid_comp_area => get_grid_comp_area, & + fms_grid2_define_cube_mosaic => define_cube_mosaic, & + fms_grid2_get_great_circle_algorithm => get_great_circle_algorithm, & + fms_grid2_grid_init => grid_init, & + fms_grid2_end => grid_end + use gradient_mod, only: fms_gradient_cubic => gradient_cubic, & + fms_gradient_calc_cubic_grid_info => calc_cubic_grid_info !> mpp - use mpp_mod, only: stdin, stdout, stderr, & - stdlog, lowercase, uppercase, mpp_error, mpp_error_state, & - mpp_set_warn_level, mpp_sync, mpp_sync_self, mpp_set_stack_size, & - mpp_pe, mpp_npes, mpp_root_pe, mpp_set_root_pe, mpp_declare_pelist, & - mpp_get_current_pelist, mpp_set_current_pelist, & - mpp_get_current_pelist_name, mpp_clock_id, mpp_clock_set_grain, & - mpp_record_timing_data, get_unit, read_ascii_file, read_input_nml, & - mpp_clock_begin, mpp_clock_end, get_ascii_file_num_lines, & - mpp_record_time_start, mpp_record_time_end, mpp_chksum, & - mpp_max, mpp_min, mpp_sum, mpp_transmit, mpp_send, mpp_recv, & - mpp_sum_ad, mpp_broadcast, mpp_init, mpp_exit, mpp_gather, & - mpp_scatter, mpp_alltoall, mpp_type, mpp_byte, mpp_type_create, & - mpp_type_free, input_nml_file + use mpp_mod, only: fms_mpp_stdin => stdin, & + fms_mpp_stdout => stdout, & + fms_mpp_stderr => stderr, & + fms_mpp_stdlog => stdlog, & + fms_mpp_lowercase => lowercase, & + fms_mpp_uppercase => uppercase, & + fms_mpp_error => mpp_error, & + fms_mpp_error_state => mpp_error_state, & + fms_mpp_set_warn_level => mpp_set_warn_level, & + fms_mpp_sync => mpp_sync, & + fms_mpp_sync_self => mpp_sync_self, & + fms_mpp_set_stack_size => mpp_set_stack_size, & + fms_mpp_pe => mpp_pe, & + fms_mpp_npes => mpp_npes, & + fms_mpp_root_pe => mpp_root_pe, & + fms_mpp_set_root_pe => mpp_set_root_pe, & + fms_mpp_declare_pelist => mpp_declare_pelist, & + fms_mpp_get_current_pelist => mpp_get_current_pelist, & + fms_mpp_set_current_pelist => mpp_set_current_pelist, & + fms_mpp_get_current_pelist_name => mpp_get_current_pelist_name, & + fms_mpp_clock_id => mpp_clock_id, & + fms_mpp_clock_set_grain => mpp_clock_set_grain, & + fms_mpp_record_timing_data => mpp_record_timing_data, & + fms_mpp_get_unit => get_unit, & + fms_mpp_read_ascii_file => read_ascii_file, & + fms_mpp_read_input_nml => read_input_nml, & + fms_mpp_clock_begin => mpp_clock_begin, & + fms_mpp_clock_end => mpp_clock_end, & + fms_mpp_get_ascii_file_num_lines => get_ascii_file_num_lines, & + fms_mpp_record_time_start => mpp_record_time_start, & + fms_mpp_record_time_end => mpp_record_time_end, & + fms_mpp_chksum => mpp_chksum, & + fms_mpp_max => mpp_max, & + fms_mpp_min => mpp_min, & + fms_mpp_sum => mpp_sum, & + fms_mpp_transmit => mpp_transmit, & + fms_mpp_send => mpp_send, & + fms_mpp_recv => mpp_recv, & + fms_mpp_sum_ad => mpp_sum_ad, & + fms_mpp_broadcast => mpp_broadcast, & + fms_mpp_init => mpp_init, & + fms_mpp_exit => mpp_exit, & + fms_mpp_gather => mpp_gather, & + fms_mpp_scatter => mpp_scatter, & + fms_mpp_alltoall => mpp_alltoall, & + FmsMpp_type => mpp_type, & + FmsMpp_byte => mpp_byte, & + fms_mpp_type_create => mpp_type_create, & + fms_mpp_type_free => mpp_type_free, & + fms_mpp_input_nml_file => input_nml_file use mpp_parameter_mod,only:MAXPES, MPP_VERBOSE, MPP_DEBUG, ALL_PES, ANY_PE, NULL_PE, & NOTE, WARNING, FATAL, MPP_WAIT, MPP_READY, MAX_CLOCKS, & MAX_EVENT_TYPES, MAX_EVENTS, MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, & @@ -298,74 +548,161 @@ module fms MAX_DOMAIN_FIELDS, MAX_TILES, ZERO, NINETY, MINUS_NINETY, & ONE_HUNDRED_EIGHTY, NONBLOCK_UPDATE_TAG, EDGEUPDATE, EDGEONLY, & NONSYMEDGEUPDATE, NONSYMEDGE - use mpp_data_mod, only: stat, mpp_stack, ptr_stack, status, ptr_status, sync, & - ptr_sync, mpp_from_pe, ptr_from, remote_Data_loc, & - ptr_remote, mpp_domains_stack, ptr_domains_stack, & - mpp_domains_stack_nonblock, ptr_domains_stack_nonblock - use mpp_utilities_mod, only: mpp_array_global_min_max - use mpp_memutils_mod, only: mpp_print_memuse_stats, mpp_mem_dump, & - mpp_memuse_begin, mpp_memuse_end - use mpp_efp_mod, only: mpp_reproducing_sum, mpp_efp_list_sum_across_PEs, & - mpp_efp_plus, mpp_efp_minus, mpp_efp_to_real, & - mpp_real_to_efp, mpp_efp_real_diff, operator(+), & - operator(-), assignment(=), mpp_query_efp_overflow_error, & - mpp_reset_efp_overflow_error, mpp_efp_type - use mpp_domains_mod, only: domain_axis_spec, domain1D, domain2D, DomainCommunicator2D, & - nest_domain_type, mpp_group_update_type, & - mpp_domains_set_stack_size, mpp_get_compute_domain, & - mpp_get_compute_domains, mpp_get_data_domain, & - mpp_get_global_domain, mpp_get_domain_components, & - mpp_get_layout, mpp_get_pelist, operator(.EQ.), operator(.NE.), & - mpp_domain_is_symmetry, mpp_domain_is_initialized, & - mpp_get_neighbor_pe, mpp_nullify_domain_list, & - mpp_set_compute_domain, mpp_set_data_domain, mpp_set_global_domain, & - mpp_get_memory_domain, mpp_get_domain_shift, & - mpp_domain_is_tile_root_pe, mpp_get_tile_id, & - mpp_get_domain_extents, mpp_get_current_ntile, & - mpp_get_ntile_count, mpp_get_tile_list, mpp_get_tile_npes, & - mpp_get_domain_root_pe, mpp_get_tile_pelist, & - mpp_get_tile_compute_domains, mpp_get_num_overlap, & - mpp_get_overlap, mpp_get_io_domain, mpp_get_domain_pe, & - mpp_get_domain_tile_root_pe, mpp_get_domain_name, & - mpp_get_io_domain_layout, mpp_copy_domain, mpp_set_domain_symmetry, & - mpp_get_update_pelist, mpp_get_update_size, & - mpp_get_domain_npes, mpp_get_domain_pelist, & - mpp_clear_group_update, mpp_group_update_initialized, & - mpp_group_update_is_set, mpp_get_global_domains, & - mpp_global_field, mpp_global_max, mpp_global_min, mpp_global_sum, & - mpp_global_sum_tl, mpp_global_sum_ad, mpp_broadcast_domain, & - mpp_domains_init, mpp_domains_exit, mpp_redistribute, & - mpp_update_domains, mpp_check_field, mpp_start_update_domains, & - mpp_complete_update_domains, mpp_create_group_update, & - mpp_do_group_update, mpp_start_group_update, & - mpp_complete_group_update, mpp_reset_group_update_field, & - mpp_update_nest_fine, mpp_update_nest_coarse, mpp_get_boundary, & - mpp_update_domains_ad, mpp_get_boundary_ad, mpp_pass_SG_to_UG, & - mpp_pass_UG_to_SG, mpp_define_layout, mpp_define_domains, & - mpp_modify_domain, mpp_define_mosaic, mpp_define_mosaic_pelist, & - mpp_define_null_domain, mpp_mosaic_defined, & - mpp_define_io_domain, mpp_deallocate_domain, & - mpp_compute_extent, mpp_compute_block_extent, & - mpp_define_unstruct_domain, domainUG, mpp_get_UG_io_domain, & - mpp_get_UG_domain_npes, mpp_get_UG_compute_domain, & - mpp_get_UG_domain_tile_id, mpp_get_UG_domain_pelist, & - mpp_get_ug_domain_grid_index, mpp_get_UG_domain_ntiles, & - mpp_get_UG_global_domain, mpp_global_field_ug, & - mpp_get_ug_domain_tile_list, mpp_get_UG_compute_domains, & - mpp_define_null_UG_domain, NULL_DOMAINUG, mpp_get_UG_domains_index, & - mpp_get_UG_SG_domain, mpp_get_UG_domain_tile_pe_inf, & - mpp_define_nest_domains, mpp_get_C2F_index, mpp_get_F2C_index, & - mpp_get_nest_coarse_domain, mpp_get_nest_fine_domain, & - mpp_is_nest_coarse, mpp_is_nest_fine, & - mpp_get_nest_pelist, mpp_get_nest_npes, & - mpp_get_nest_fine_pelist, mpp_get_nest_fine_npes, & - mpp_domain_UG_is_tile_root_pe, mpp_deallocate_domainUG, & - mpp_get_io_domain_UG_layout, NULL_DOMAIN1D, NULL_DOMAIN2D, & - mpp_create_super_grid_domain, mpp_shift_nest_domains + ! this should really only be used internally + !use mpp_data_mod, only: stat, mpp_stack, ptr_stack, status, ptr_status, sync, & + ! ptr_sync, mpp_from_pe, ptr_from, remote_Data_loc, & + ! ptr_remote, mpp_domains_stack, ptr_domains_stack, & + ! mpp_domains_stack_nonblock, ptr_domains_stack_nonblock + use mpp_utilities_mod, only: fms_mpp_utilities_array_global_min_max => mpp_array_global_min_max + use mpp_memutils_mod, only: fms_mpp_memutils_print_memuse_stats => mpp_print_memuse_stats, & + fms_mpp_memutils_mem_dump => mpp_mem_dump, & + fms_mpp_memutils_memuse_begin => mpp_memuse_begin, & + fms_mpp_memutils_memuse_end => mpp_memuse_end + use mpp_efp_mod, only: fms_mpp_efp_reproducing_sum => mpp_reproducing_sum, & + fms_mpp_efp_list_sum_across_PEs => mpp_efp_list_sum_across_PEs, & + fms_mpp_efp_plus => mpp_efp_plus, & + fms_mpp_efp_minus => mpp_efp_minus, & + fms_mpp_efp_to_real => mpp_efp_to_real, & + fms_mpp_efp_real_to_efp => mpp_real_to_efp, & + fms_mpp_efp_real_diff => mpp_efp_real_diff, & + operator(+), operator(-), assignment(=), & + fms_mpp_efp_query_overflow_error => mpp_query_efp_overflow_error, & + fms_mpp_efp_reset_overflow_error => mpp_reset_efp_overflow_error, & + FmsMppEfp_type => mpp_efp_type + use mpp_domains_mod, only: FmsMppDomains_axis_spec => domain_axis_spec, & + FmsMppDomain1D => domain1D, & + FmsMppDomain2D => domain2D, & + FmsMppDomainCommunicator2D => DomainCommunicator2D, & + FmsMppDomainsNestDomain_type => nest_domain_type, & + FmsMppDomainsGroupUpdate_type => mpp_group_update_type, & + fms_mpp_domains_domains_set_stack_size => mpp_domains_set_stack_size, & + fms_mpp_domains_get_compute_domain => mpp_get_compute_domain, & + fms_mpp_domains_get_compute_domains => mpp_get_compute_domains, & + fms_mpp_domains_get_data_domain => mpp_get_data_domain, & + fms_mpp_domains_get_global_domain => mpp_get_global_domain, & + fms_mpp_domains_get_domain_components => mpp_get_domain_components, & + fms_mpp_domains_get_layout => mpp_get_layout, & + fms_mpp_domains_get_pelist => mpp_get_pelist, & + operator(.EQ.), operator(.NE.), & + fms_mpp_domains_domain_is_symmetry => mpp_domain_is_symmetry, & + fms_mpp_domains_domain_is_initialized => mpp_domain_is_initialized, & + fms_mpp_domains_get_neighbor_pe => mpp_get_neighbor_pe, & + fms_mpp_domains_nullify_domain_list => mpp_nullify_domain_list, & + fms_mpp_domains_set_compute_domain => mpp_set_compute_domain, & + fms_mpp_domains_set_data_domain => mpp_set_data_domain, & + fms_mpp_domains_set_global_domain => mpp_set_global_domain, & + fms_mpp_domains_get_memory_domain => mpp_get_memory_domain, & + fms_mpp_domains_get_domain_shift => mpp_get_domain_shift, & + fms_mpp_domains_domain_is_tile_root_pe => mpp_domain_is_tile_root_pe, & + fms_mpp_domains_get_tile_id => mpp_get_tile_id, & + fms_mpp_domains_get_domain_extents => mpp_get_domain_extents, & + fms_mpp_domains_get_current_ntile => mpp_get_current_ntile, & + fms_mpp_domains_get_ntile_count => mpp_get_ntile_count, & + fms_mpp_domains_get_tile_list => mpp_get_tile_list, & + fms_mpp_domains_get_tile_npes => mpp_get_tile_npes, & + fms_mpp_domains_get_domain_root_pe => mpp_get_domain_root_pe, & + fms_mpp_domains_get_tile_pelist => mpp_get_tile_pelist, & + fms_mpp_domains_get_tile_compute_domains => mpp_get_tile_compute_domains, & + fms_mpp_domains_get_num_overlap => mpp_get_num_overlap, & + fms_mpp_domains_get_overlap => mpp_get_overlap, & + fms_mpp_domains_get_io_domain => mpp_get_io_domain, & + fms_mpp_domains_get_domain_pe => mpp_get_domain_pe, & + fms_mpp_domains_get_domain_tile_root_pe => mpp_get_domain_tile_root_pe, & + fms_mpp_domains_get_domain_name => mpp_get_domain_name, & + fms_mpp_domains_get_io_domain_layout => mpp_get_io_domain_layout, & + fms_mpp_domains_copy_domain => mpp_copy_domain, & + fms_mpp_domains_set_domain_symmetry => mpp_set_domain_symmetry, & + fms_mpp_domains_get_update_pelist => mpp_get_update_pelist, & + fms_mpp_domains_get_update_size => mpp_get_update_size, & + fms_mpp_domains_get_domain_npes => mpp_get_domain_npes, & + fms_mpp_domains_get_domain_pelist => mpp_get_domain_pelist, & + fms_mpp_domains_clear_group_update => mpp_clear_group_update, & + fms_mpp_domains_group_update_initialized => mpp_group_update_initialized, & + fms_mpp_domains_group_update_is_set => mpp_group_update_is_set, & + fms_mpp_domains_get_global_domains => mpp_get_global_domains, & + fms_mpp_domains_global_field => mpp_global_field, & + fms_mpp_domains_global_max => mpp_global_max, & + fms_mpp_domains_global_min => mpp_global_min, & + fms_mpp_domains_global_sum => mpp_global_sum, & + fms_mpp_domains_global_sum_tl => mpp_global_sum_tl, & + fms_mpp_domains_global_sum_ad => mpp_global_sum_ad, & + fms_mpp_domains_broadcast_domain => mpp_broadcast_domain, & + fms_mpp_domains_init => mpp_domains_init, & + fms_mpp_domains_exit => mpp_domains_exit, & + fms_mpp_domains_redistribute => mpp_redistribute, & + fms_mpp_domains_update_domains => mpp_update_domains, & + fms_mpp_domains_check_field => mpp_check_field, & + fms_mpp_domains_start_update_domains => mpp_start_update_domains, & + fms_mpp_domains_complete_update_domains => mpp_complete_update_domains, & + fms_mpp_domains_create_group_update => mpp_create_group_update, & + fms_mpp_domains_do_group_update => mpp_do_group_update, & + fms_mpp_domains_start_group_update => mpp_start_group_update, & + fms_mpp_domains_complete_group_update => mpp_complete_group_update, & + fms_mpp_domains_reset_group_update_field => mpp_reset_group_update_field, & + fms_mpp_domains_update_nest_fine => mpp_update_nest_fine, & + fms_mpp_domains_update_nest_coarse => mpp_update_nest_coarse, & + fms_mpp_domains_get_boundary => mpp_get_boundary, & + fms_mpp_domains_update_domains_ad => mpp_update_domains_ad, & + fms_mpp_domains_get_boundary_ad => mpp_get_boundary_ad, & + fms_mpp_domains_pass_SG_to_UG => mpp_pass_SG_to_UG, & + fms_mpp_domains_pass_UG_to_SG => mpp_pass_UG_to_SG, & + fms_mpp_domains_define_layout => mpp_define_layout, & + fms_mpp_domains_define_domains => mpp_define_domains, & + fms_mpp_domains_modify_domain => mpp_modify_domain, & + fms_mpp_domains_define_mosaic => mpp_define_mosaic, & + fms_mpp_domains_define_mosaic_pelist => mpp_define_mosaic_pelist, & + fms_mpp_domains_define_null_domain => mpp_define_null_domain, & + fms_mpp_domains_mosaic_defined => mpp_mosaic_defined, & + fms_mpp_domains_define_io_domain => mpp_define_io_domain, & + fms_mpp_domains_deallocate_domain => mpp_deallocate_domain, & + fms_mpp_domains_compute_extent => mpp_compute_extent, & + fms_mpp_domains_compute_block_extent => mpp_compute_block_extent, & + fms_mpp_domains_define_unstruct_domain => mpp_define_unstruct_domain, & + fmsMppDomainUG => domainUG, & + fms_mpp_domains_get_UG_io_domain => mpp_get_UG_io_domain, & + fms_mpp_domains_get_UG_domain_npes => mpp_get_UG_domain_npes, & + fms_mpp_domains_get_UG_compute_domain => mpp_get_UG_compute_domain, & + fms_mpp_domains_get_UG_domain_tile_id => mpp_get_UG_domain_tile_id, & + fms_mpp_domains_get_UG_domain_pelist => mpp_get_UG_domain_pelist, & + fms_mpp_domains_get_ug_domain_grid_index => mpp_get_ug_domain_grid_index, & + fms_mpp_domains_get_UG_domain_ntiles => mpp_get_UG_domain_ntiles, & + fms_mpp_domains_get_UG_global_domain => mpp_get_UG_global_domain, & + fms_mpp_domains_global_field_ug => mpp_global_field_ug, & + fms_mpp_domains_get_ug_domain_tile_list => mpp_get_ug_domain_tile_list, & + fms_mpp_domains_get_UG_compute_domains => mpp_get_UG_compute_domains, & + fms_mpp_domains_define_null_UG_domain => mpp_define_null_UG_domain, & + fms_mpp_domains_NULL_DOMAINUG => NULL_DOMAINUG, & + fms_mpp_domains_get_UG_domains_index => mpp_get_UG_domains_index, & + fms_mpp_domains_get_UG_SG_domain => mpp_get_UG_SG_domain, & + fms_mpp_domains_get_UG_domain_tile_pe_inf => mpp_get_UG_domain_tile_pe_inf, & + fms_mpp_domains_define_nest_domains => mpp_define_nest_domains, & + fms_mpp_domains_get_C2F_index => mpp_get_C2F_index, & + fms_mpp_domains_get_F2C_index => mpp_get_F2C_index, & + fms_mpp_domains_get_nest_coarse_domain => mpp_get_nest_coarse_domain, & + fms_mpp_domains_get_nest_fine_domain => mpp_get_nest_fine_domain, & + fms_mpp_domains_is_nest_coarse => mpp_is_nest_coarse, & + fms_mpp_domains_is_nest_fine => mpp_is_nest_fine, & + fms_mpp_domains_get_nest_pelist => mpp_get_nest_pelist, & + fms_mpp_domains_get_nest_npes => mpp_get_nest_npes, & + fms_mpp_domains_get_nest_fine_pelist => mpp_get_nest_fine_pelist, & + fms_mpp_domains_get_nest_fine_npes => mpp_get_nest_fine_npes, & + fms_mpp_domains_domain_UG_is_tile_root_pe => mpp_domain_UG_is_tile_root_pe, & + fms_mpp_domains_deallocate_domainUG => mpp_deallocate_domainUG, & + fms_mpp_domains_get_io_domain_UG_layout => mpp_get_io_domain_UG_layout, & + NULL_DOMAIN1D, & + NULL_DOMAIN2D, & + fms_mpp_domains_create_super_grid_domain => mpp_create_super_grid_domain, & + fms_mpp_domains_shift_nest_domains => mpp_shift_nest_domains !> parser #ifdef use_yaml - use yaml_parser_mod, only: open_and_parse_file, get_num_blocks, get_block_ids, get_value_from_key, & - get_nkeys, get_key_ids, get_key_name, get_key_value + use yaml_parser_mod, only: fms_yaml_parser_open_and_parse_file => open_and_parse_file, & + fms_yaml_parser_get_num_blocks => get_num_blocks, & + fms_yaml_parser_get_block_ids => get_block_ids, & + fms_yaml_parser_get_value_from_key => get_value_from_key, & + fms_yaml_parser_get_nkeys => get_nkeys, & + fms_yaml_parser_get_key_ids => get_key_ids, & + fms_yaml_parser_get_key_name => get_key_name, & + fms_yaml_parser_get_key_value => get_key_value #endif !> platform @@ -373,64 +710,124 @@ module fms l8_kind, l4_kind, i2_kind, ptr_kind !> random_numbers - use random_numbers_mod, only: randomNumberStream, initializeRandomNumberStream, & - getRandomNumbers, constructSeed + use random_numbers_mod, only: fms_random_numbers_randomNumberStream => randomNumberStream, & + fms_random_numbers_initializeRandomNumbersStream => initializeRandomNumberStream, & + fms_random_numbers_getRandomNumbers => getRandomNumbers, & + fms_random_numbers_constructSeed => constructSeed !> sat_vapor_pres - use sat_vapor_pres_mod, only: lookup_es, lookup_des, sat_vapor_pres_init, & - lookup_es2, lookup_des2, lookup_es2_des2, & - lookup_es3, lookup_des3, lookup_es3_des3, & - lookup_es_des, compute_qs, compute_mrs, & - escomp, descomp, check_1d, check_2d, temp_check, show_all_bad + use sat_vapor_pres_mod, only: fms_sat_vapor_pres_lookup_es => lookup_es, & + fms_sat_vapor_pres_lookup_des => lookup_des, & + fms_sat_vapor_pres_init => sat_vapor_pres_init, & + fms_sat_vapor_pres_lookup_es2 => lookup_es2, & + fms_sat_vapor_pres_lookup_des2 => lookup_des2, & + fms_sat_vapor_pres_lookup_es2_des2 => lookup_es2_des2, & + fms_sat_vapor_pres_lookup_es3 => lookup_es3, & + fms_sat_vapor_pres_lookup_des3 => lookup_des3, & + fms_sat_vapor_pres_lookup_es3_des3 => lookup_es3_des3, & + fms_sat_vapor_pres_lookup_es_des => lookup_es_des, & + fms_sat_vapor_pres_compute_qs => compute_qs, & + fms_sat_vapor_pres_compute_mrs => compute_mrs, & + fms_sat_vapor_pres_escomp => escomp, & + fms_sat_vapor_pres_descomp => descomp !> string_utils - use fms_string_utils_mod, only: string, fms_array_to_pointer, fms_pointer_to_array, fms_sort_this, & - fms_find_my_string, fms_find_unique, fms_c2f_string, fms_cstring2cpointer, & - string_copy + use fms_string_utils_mod, only: fms_string_utils_string => string, & + fms_string_utils_array_to_pointer => fms_array_to_pointer, & + fms_string_utils_fms_pointer_to_array => fms_pointer_to_array, & + fms_string_utils_sort_this => fms_sort_this, & + fms_string_utils_find_my_string => fms_find_my_string, & + fms_string_utils_find_unique => fms_find_unique, & + fms_string_utils_c2f_string => fms_c2f_string, & + fms_string_utils_cstring2cpointer => fms_cstring2cpointer, & + fms_string_utils_copy => string_copy !> time_interp - use time_interp_mod, only: time_interp_init, time_interp, fraction_of_year, & + use time_interp_mod, only: fms_time_interp_init => time_interp_init, & + fms_time_interp => time_interp, fms_fraction_of_year=> fraction_of_year, & NONE, YEAR, MONTH, DAY - use time_interp_external2_mod, only: init_external_field, time_interp_external, & - time_interp_external_init, time_interp_external_exit, & - get_external_field_size, get_time_axis, & - get_external_field_missing, set_override_region, & - reset_src_data_region, get_external_fileobj, & + use time_interp_external2_mod, only: fms_time_interp_external_init_external_field => init_external_field, & + fms_time_interp_external => time_interp_external, & + fms_time_interp_external_init => time_interp_external_init, & + fms_time_interp_external_exit => time_interp_external_exit, & + fms_time_interp_external_get_external_field_size => get_external_field_size, & + fms_time_interp_external_get_time_axis => get_time_axis, & + fms_time_interp_external_get_external_field_missing => get_external_field_missing, & + fms_time_interp_external_set_override_region => set_override_region, & + fms_time_interp_external_reset_src_data_region => reset_src_data_region, & + fms_time_interp_external_get_external_fileobj => get_external_fileobj, & NO_REGION, INSIDE_REGION, OUTSIDE_REGION, & SUCCESS, ERR_FIELD_NOT_FOUND !> time_manager - use time_manager_mod, only: time_type, operator(+), operator(-), operator(*), & + use time_manager_mod, only: FmsTime_type => time_type, & + operator(+), operator(-), operator(*), assignment(=),& operator(/), operator(>), operator(>=), operator(==), & operator(/=), operator(<), operator(<=), operator(//), & - assignment(=), set_time, increment_time, decrement_time, & - get_time, interval_alarm, repeat_alarm, time_type_to_real, & - real_to_time_type, time_list_error, THIRTY_DAY_MONTHS, & - JULIAN, GREGORIAN, NOLEAP, NO_CALENDAR, INVALID_CALENDAR, & - set_calendar_type, get_calendar_type, set_ticks_per_second, & - get_ticks_per_second, set_date, get_date, increment_date, & - decrement_date, days_in_month, leap_year, length_of_year, & - days_in_year, day_of_year, month_name, valid_calendar_types, & - time_manager_init, print_time, print_date, set_date_julian, & - get_date_julian, get_date_no_leap, date_to_string - use get_cal_time_mod, only: get_cal_time + fms_time_manager_set_time => set_time, & + fms_time_manager_increment_time => increment_time, & + fms_time_manager_decrement_time => decrement_time, & + fms_time_manager_get_time => get_time, & + fms_time_manager_interval_alarm => interval_alarm, & + fms_time_manager_repeat_alarm => repeat_alarm, & + fms_time_manager_time_type_to_real => time_type_to_real, & + fms_time_manager_real_to_time_type => real_to_time_type, & + fms_time_manager_time_list_error => time_list_error, & + THIRTY_DAY_MONTHS, JULIAN, GREGORIAN, NOLEAP, NO_CALENDAR, INVALID_CALENDAR, & + fms_time_manager_set_calendar_type => set_calendar_type, & + fms_time_manager_get_calendar_type => get_calendar_type, & + fms_time_manager_set_ticks_per_second => set_ticks_per_second, & + fms_time_manager_get_ticks_per_second => get_ticks_per_second, & + fms_time_manager_set_date => set_date, & + fms_time_manager_get_date => get_date, & + fms_time_manager_increment_date => increment_date, & + fms_time_manager_decrement_date => decrement_date, & + fms_time_manager_days_in_month => days_in_month, & + fms_time_manager_leap_year => leap_year, & + fms_time_manager_length_of_year => length_of_year, & + fms_time_manager_days_in_year => days_in_year, & + fms_time_manager_day_of_year => day_of_year, & + fms_time_manager_month_name => month_name, & + fms_time_manager_valid_calendar_types => valid_calendar_types, & + fms_time_manager_init => time_manager_init, & + fms_time_manager_print_time => print_time, & + fms_time_manager_print_date => print_date, & + fms_time_manager_set_date_julian => set_date_julian, & + fms_time_manager_get_date_julian => get_date_julian, & + fms_time_manager_get_date_no_leap => get_date_no_leap, & + fms_time_manager_date_to_string => date_to_string + use get_cal_time_mod, only: fms_get_cal_time => get_cal_time !> topography - use gaussian_topog_mod, only: gaussian_topog_init, get_gaussian_topog - use topography_mod, only: topography_init, get_topog_mean, get_topog_stdev, & - get_ocean_frac, get_ocean_mask, get_water_frac, & - get_water_mask + use gaussian_topog_mod, only: fms_gaussian_topog_init => gaussian_topog_init, & + fms_get_gaussian_topog => get_gaussian_topog + use topography_mod, only: fms_topography_init => topography_init, & + fms_topography_get_topog_mean => get_topog_mean, & + fms_topography_get_topog_stdev => get_topog_stdev, & + fms_topography_get_ocean_frac => get_ocean_frac, & + fms_topography_get_ocean_mask => get_ocean_mask, & + fms_topography_get_water_frac => get_water_frac, & + fms_topography_get_water_mask => get_water_mask !> tracer_manager - use tracer_manager_mod, only: tracer_manager_init, tracer_manager_end, & - check_if_prognostic, get_tracer_indices, & - get_tracer_index, get_tracer_names, & - get_tracer_name, query_method, & - set_tracer_atts, set_tracer_profile, & - register_tracers, get_number_tracers, & - adjust_mass, adjust_positive_def, NO_TRACER, MAX_TRACER_FIELDS + use tracer_manager_mod, only: fms_tracer_manager_init => tracer_manager_init, & + fms_tracer_manager_end => tracer_manager_end, & + fms_tracer_manager_check_if_prognostic => check_if_prognostic, & + fms_tracer_manager_get_tracer_indices => get_tracer_indices, & + fms_tracer_manager_get_tracer_index => get_tracer_index, & + fms_tracer_manager_get_tracer_names => get_tracer_names, & + fms_tracer_manager_get_tracer_name => get_tracer_name, & + fms_tracer_manager_query_method => query_method, & + fms_tracer_manager_set_tracer_atts => set_tracer_atts, & + fms_tracer_manager_set_tracer_profile => set_tracer_profile, & + fms_tracer_manager_register_tracers => register_tracers, & + fms_tracer_manager_get_number_tracers => get_number_tracers, & + fms_tracer_manager_adjust_mass => adjust_mass, & + fms_tracer_manager_adjust_positive_def => adjust_positive_def, & + NO_TRACER, MAX_TRACER_FIELDS !> tridiagonal - use tridiagonal_mod, only: tri_invert, close_tridiagonal + use tridiagonal_mod, only: fms_tridiagonal_tri_invert => tri_invert, & + fms_tridiagonal_close_tridiagonal => close_tridiagonal implicit none diff --git a/monin_obukhov/include/monin_obukhov.inc b/monin_obukhov/include/monin_obukhov.inc index 883e4cbe34..ac8a89075f 100644 --- a/monin_obukhov/include/monin_obukhov.inc +++ b/monin_obukhov/include/monin_obukhov.inc @@ -274,16 +274,18 @@ subroutine stable_mix_3d(rich, mix) real, intent(in) , dimension(:,:,:) :: rich real, intent(out), dimension(:,:,:) :: mix +integer :: n2 !< Size of dimension 2 of mix and rich +integer :: n3 !< Size of dimension 3 of mix and rich +integer :: i, j !< Loop indices -integer :: n, ier - -if(.not.module_is_initialized) call error_mesg('stable_mix_3d in monin_obukhov_mod', & - 'monin_obukhov_init has not been called', FATAL) - -n = size(rich,1)*size(rich,2)*size(rich,3) -call monin_obukhov_stable_mix(stable_option, rich_crit, zeta_trans, & - & n, rich, mix, ier) +n2 = size(mix, 2) +n3 = size(mix, 3) +do j=1, n3 + do i=1, n2 + call stable_mix(rich(:, i, j), mix(:, i, j)) + enddo +enddo end subroutine stable_mix_3d @@ -943,16 +945,15 @@ subroutine stable_mix_2d(rich, mix) real, intent(in) , dimension(:,:) :: rich real, intent(out), dimension(:,:) :: mix +integer :: n2 !< Size of dimension 2 of mix and rich +integer :: i !< Loop index -real, dimension(size(rich,1),size(rich,2),1) :: rich_3d, mix_3d - -rich_3d(:,:,1) = rich +n2 = size(mix, 2) -call stable_mix_3d(rich_3d, mix_3d) - -mix = mix_3d(:,:,1) +do i=1, n2 + call stable_mix(rich(:, i), mix(:, i)) +enddo -return end subroutine stable_mix_2d @@ -962,16 +963,17 @@ subroutine stable_mix_1d(rich, mix) real, intent(in) , dimension(:) :: rich real, intent(out), dimension(:) :: mix +integer :: n !< Size of mix and rich +integer :: ierr !< Error code set by monin_obukhov_stable_mix -real, dimension(size(rich),1,1) :: rich_3d, mix_3d - -rich_3d(:,1,1) = rich +if (.not.module_is_initialized) call error_mesg('stable_mix in monin_obukhov_mod', & + 'monin_obukhov_init has not been called', FATAL) -call stable_mix_3d(rich_3d, mix_3d) +n = size(mix) -mix = mix_3d(:,1,1) +call monin_obukhov_stable_mix(stable_option, rich_crit, zeta_trans, & + & n, rich, mix, ierr) -return end subroutine stable_mix_1d !======================================================================= @@ -981,15 +983,12 @@ subroutine stable_mix_0d(rich, mix) real, intent(in) :: rich real, intent(out) :: mix -real, dimension(1,1,1) :: rich_3d, mix_3d - -rich_3d(1,1,1) = rich +real, dimension(1) :: mix_1d !< Representation of mix as a dimension(1) array -call stable_mix_3d(rich_3d, mix_3d) +call stable_mix([rich], mix_1d) -mix = mix_3d(1,1,1) +mix = mix_1d(1) -return end subroutine stable_mix_0d !======================================================================= diff --git a/monin_obukhov/monin_obukhov.F90 b/monin_obukhov/monin_obukhov.F90 index 883e4cbe34..ac8a89075f 100644 --- a/monin_obukhov/monin_obukhov.F90 +++ b/monin_obukhov/monin_obukhov.F90 @@ -274,16 +274,18 @@ subroutine stable_mix_3d(rich, mix) real, intent(in) , dimension(:,:,:) :: rich real, intent(out), dimension(:,:,:) :: mix +integer :: n2 !< Size of dimension 2 of mix and rich +integer :: n3 !< Size of dimension 3 of mix and rich +integer :: i, j !< Loop indices -integer :: n, ier - -if(.not.module_is_initialized) call error_mesg('stable_mix_3d in monin_obukhov_mod', & - 'monin_obukhov_init has not been called', FATAL) - -n = size(rich,1)*size(rich,2)*size(rich,3) -call monin_obukhov_stable_mix(stable_option, rich_crit, zeta_trans, & - & n, rich, mix, ier) +n2 = size(mix, 2) +n3 = size(mix, 3) +do j=1, n3 + do i=1, n2 + call stable_mix(rich(:, i, j), mix(:, i, j)) + enddo +enddo end subroutine stable_mix_3d @@ -943,16 +945,15 @@ subroutine stable_mix_2d(rich, mix) real, intent(in) , dimension(:,:) :: rich real, intent(out), dimension(:,:) :: mix +integer :: n2 !< Size of dimension 2 of mix and rich +integer :: i !< Loop index -real, dimension(size(rich,1),size(rich,2),1) :: rich_3d, mix_3d - -rich_3d(:,:,1) = rich +n2 = size(mix, 2) -call stable_mix_3d(rich_3d, mix_3d) - -mix = mix_3d(:,:,1) +do i=1, n2 + call stable_mix(rich(:, i), mix(:, i)) +enddo -return end subroutine stable_mix_2d @@ -962,16 +963,17 @@ subroutine stable_mix_1d(rich, mix) real, intent(in) , dimension(:) :: rich real, intent(out), dimension(:) :: mix +integer :: n !< Size of mix and rich +integer :: ierr !< Error code set by monin_obukhov_stable_mix -real, dimension(size(rich),1,1) :: rich_3d, mix_3d - -rich_3d(:,1,1) = rich +if (.not.module_is_initialized) call error_mesg('stable_mix in monin_obukhov_mod', & + 'monin_obukhov_init has not been called', FATAL) -call stable_mix_3d(rich_3d, mix_3d) +n = size(mix) -mix = mix_3d(:,1,1) +call monin_obukhov_stable_mix(stable_option, rich_crit, zeta_trans, & + & n, rich, mix, ierr) -return end subroutine stable_mix_1d !======================================================================= @@ -981,15 +983,12 @@ subroutine stable_mix_0d(rich, mix) real, intent(in) :: rich real, intent(out) :: mix -real, dimension(1,1,1) :: rich_3d, mix_3d - -rich_3d(1,1,1) = rich +real, dimension(1) :: mix_1d !< Representation of mix as a dimension(1) array -call stable_mix_3d(rich_3d, mix_3d) +call stable_mix([rich], mix_1d) -mix = mix_3d(1,1,1) +mix = mix_1d(1) -return end subroutine stable_mix_0d !======================================================================= diff --git a/mosaic/grid.F90 b/mosaic/grid.F90 index 6c94e1b733..84fd0d8cb0 100644 --- a/mosaic/grid.F90 +++ b/mosaic/grid.F90 @@ -21,6 +21,7 @@ !> @brief Routines for grid calculations module grid_mod +#ifdef use_deprecated_io use mpp_mod, only : mpp_root_pe, uppercase, lowercase, FATAL, NOTE, mpp_error use constants_mod, only : PI, radius @@ -1030,7 +1031,7 @@ subroutine define_cube_mosaic ( component, domain, layout, halo, maskmap ) deallocate(is2,ie2,js2,je2) end subroutine define_cube_mosaic - +#endif end module grid_mod !> @} ! close documentation grouping diff --git a/mosaic/mosaic.F90 b/mosaic/mosaic.F90 index e8558fc8fa..eb8a698de4 100644 --- a/mosaic/mosaic.F90 +++ b/mosaic/mosaic.F90 @@ -28,6 +28,7 @@ !> @addtogroup mosaic_mod !> @{ module mosaic_mod +#ifdef use_deprecated_io use mpp_mod, only : mpp_error, FATAL, mpp_pe, mpp_root_pe use mpp_io_mod, only : MPP_MULTI @@ -488,7 +489,7 @@ function parse_string(string, set, value) return end function parse_string - +#endif end module mosaic_mod diff --git a/mpp/include/mpp_do_global_field_ad.fh b/mpp/include/mpp_do_global_field_ad.fh index 5c72b5adbf..d32e6aa4b8 100644 --- a/mpp/include/mpp_do_global_field_ad.fh +++ b/mpp/include/mpp_do_global_field_ad.fh @@ -22,8 +22,8 @@ !> @addtogroup mpp_domains_mod !> @{ - !> Gets a global field from a local field - !! local field may be on compute OR data domain + !> Gets a local ad field from a global field + !! global field may be on compute OR data domain subroutine MPP_DO_GLOBAL_FIELD_3D_AD_( domain, local, global, tile, ishift, jshift, flags, default_data) type(domain2D), intent(in) :: domain MPP_TYPE_, intent(inout) :: local(:,:,:) diff --git a/mpp/include/mpp_do_updateV_ad.fh b/mpp/include/mpp_do_updateV_ad.fh index d6cce14abf..8d230f501c 100644 --- a/mpp/include/mpp_do_updateV_ad.fh +++ b/mpp/include/mpp_do_updateV_ad.fh @@ -21,7 +21,7 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - !> Updates data domain of 3D field whose computational domains have been computed + !> Updates data domain of 3D ad field whose computational domains have been computed subroutine MPP_DO_UPDATE_AD_3D_V_(f_addrsx,f_addrsy, domain, update_x, update_y, & d_type, ke, gridtype, flags) integer(i8_kind), intent(in) :: f_addrsx(:,:), f_addrsy(:,:) diff --git a/mpp/include/mpp_do_update_ad.fh b/mpp/include/mpp_do_update_ad.fh index 7afbe8317d..7e7382dcb8 100644 --- a/mpp/include/mpp_do_update_ad.fh +++ b/mpp/include/mpp_do_update_ad.fh @@ -1,6 +1,4 @@ ! -*-f90-*- - - !*********************************************************************** !* GNU Lesser General Public License !* @@ -21,8 +19,12 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - - !> Updates data domain of 3D field whose computational domains have been computed + !> Updates data domain of 3D ad field whose computational domains have been computed + !! @brief Applies linear adjoint operation to 3D field based on duality of MPP_DO_UPDATE_3D_ + !! @note Adjoint duality exists between MPI SEND and MPI_RECV. + !! However, checkpoint is needed for forward buffer information. + !! ref: BN. Cheng, A Duality between Forward and Adjoint MPI Communication Routines + !! COMPUTATIONAL METHODS IN SCIENCE AND TECHNOLOGY Special Issue 2006, 23-24 subroutine MPP_DO_UPDATE_AD_3D_( f_addrs, domain, update, d_type, ke, flags) integer(i8_kind), intent(in) :: f_addrs(:,:) type(domain2D), intent(in) :: domain @@ -35,6 +37,7 @@ pointer(ptr_field, field) integer :: update_flags type(overlap_type), pointer :: overPtr => NULL() + character(len=8) :: text !equate to mpp_domains_stack MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) @@ -43,13 +46,16 @@ !receive domains saved here for unpacking !for non-blocking version, could be recomputed - integer, allocatable :: msg1(:), msg2(:) + integer, allocatable :: msg1(:), msg2(:), msg3(:) logical :: send(8), recv(8), update_edge_only - integer :: to_pe, from_pe, pos, msgsize, msgsize_send + integer :: to_pe, from_pe, pos, msgsize integer :: n, l_size, l, m, i, j, k integer :: is, ie, js, je, tMe, dir integer :: buffer_recv_size, nlist, outunit - + integer :: send_start_pos !>Send buffer start location + !!This serves as ad recv buffer start location + integer :: send_msgsize(MAXLIST) !>Send buffer msg size storage + !!This should be checkpointed for reverse ad communication outunit = stdout() ptr = LOC(mpp_domains_stack) @@ -80,9 +86,10 @@ if(debug_message_passing) then nlist = size(domain%list(:)) - allocate(msg1(0:nlist-1), msg2(0:nlist-1) ) + allocate(msg1(0:nlist-1), msg2(0:nlist-1), msg3(0:nlist-1) ) msg1 = 0 msg2 = 0 + msg3 = 0 do m = 1, update%nrecv overPtr => update%recv(m) msgsize = 0 @@ -96,7 +103,6 @@ end do from_pe = update%recv(m)%pe l = from_pe-mpp_root_pe() - call mpp_recv( msg1(l), glen=1, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_1 ) msg2(l) = msgsize enddo @@ -111,9 +117,13 @@ msgsize = msgsize + (ie-is+1)*(je-js+1) end if end do - call mpp_send( msgsize, plen=1, to_pe=overPtr%pe, tag=COMM_TAG_1 ) + l = overPtr%pe - mpp_root_pe() + msg3(l) = msgsize enddo - call mpp_sync_self(check=EVENT_RECV) + ! mpp_sync_self is desirable but keep mpp_alltoall + ! to exactly follow the duality of mpp_do_update.fh + ! all-to-all may have scaling issues on very large systems + call mpp_alltoall(msg3, 1, msg1, 1) do m = 0, nlist-1 if(msg1(m) .NE. msg2(m)) then @@ -122,14 +132,16 @@ call mpp_error(FATAL, "mpp_do_update: mismatch on send and recv size") endif enddo - call mpp_sync_self() write(outunit,*)"NOTE from mpp_do_update: message sizes are matched between send and recv for domain " & //trim(domain%name) - deallocate(msg1, msg2) + deallocate(msg1, msg2, msg3) endif - !recv + ! Duality of ad code requires checkpoint info: buffer recv size and send pos and msgsize + ! from the forward recv portion of mpp_do_update.fh + ! ref above in line 26 buffer_pos = 0 + do m = 1, update%nrecv overPtr => update%recv(m) if( overPtr%count == 0 )cycle @@ -137,38 +149,24 @@ do n = 1, overPtr%count dir = overPtr%dir(n) if(recv(dir)) then - tMe = overPtr%tileMe(n) is = overPtr%is(n); ie = overPtr%ie(n) js = overPtr%js(n); je = overPtr%je(n) msgsize = msgsize + (ie-is+1)*(je-js+1) - msgsize_send = (ie-is+1)*(je-js+1)*ke*l_size - pos = buffer_pos + msgsize_send - do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) - do k = ke,1,-1 - do j = je, js, -1 - do i = ie, is, -1 - buffer(pos) = field(i,j,k) - field(i,j,k) = 0. - pos = pos - 1 - end do - end do - end do - end do end if end do msgsize = msgsize*ke*l_size if( msgsize.GT.0 )then - to_pe = overPtr%pe - call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=to_pe, tag=COMM_TAG_2 ) buffer_pos = buffer_pos + msgsize end if - end do ! end do m = 1, update%nrecv + end do buffer_recv_size = buffer_pos + send_start_pos = buffer_pos - ! send + ! checkpoint send_msgsize + buffer_pos = buffer_recv_size do m = 1, update%nsend + send_msgsize(m) = 0 overPtr => update%send(m) if( overPtr%count == 0 )cycle pos = buffer_pos @@ -179,19 +177,99 @@ enddo if( msgsize.GT.0 )then msgsize = msgsize*ke*l_size - msgsize_send = msgsize + end if + + do n = 1, overPtr%count + dir = overPtr%dir(n) + if( send(dir) ) then + tMe = overPtr%tileMe(n) + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + pos = pos + (ie-is+1)*(je-js+1)*ke*l_size + endif + end do + + send_msgsize(m) = pos-buffer_pos + buffer_pos = pos + end do + + ! bufferize for backward communication + ! using pack procedures of recv in mpp_do_update.fh + buffer_pos = buffer_recv_size + do m = update%nrecv, 1, -1 + overPtr => update%recv(m) + if( overPtr%count == 0 )cycle + pos = buffer_pos + do n = overPtr%count, 1, -1 + dir = overPtr%dir(n) + if( recv(dir) ) then + tMe = overPtr%tileMe(n) + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + msgsize = (ie-is+1)*(je-js+1)*ke*l_size + pos = buffer_pos - msgsize + buffer_pos = pos + do l=1,l_size ! loop over number of fields + ptr_field = f_addrs(l, tMe) + do k = 1,ke + do j = js, je + do i = is, ie + pos = pos + 1 + buffer(pos) = field(i,j,k) + end do + end do + end do + end do + endif + end do + end do + + ! for duality, mpp_send of mpp_do_update.sh becomes mpp_recv in adjoint + buffer_pos = send_start_pos + do m = 1, update%nsend + msgsize = send_msgsize(m) + if(msgsize == 0) cycle + to_pe = update%send(m)%pe + call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=to_pe, block=.FALSE., tag=COMM_TAG_2 ) + buffer_pos = buffer_pos + msgsize + end do + + ! for duality, mpp_recv of mpp_do_update.sh becomes mpp_send in adjoint + buffer_pos = 0 + do m = 1, update%nrecv + overPtr => update%recv(m) + if( overPtr%count == 0 )cycle + msgsize = 0 + do n = 1, overPtr%count + dir = overPtr%dir(n) + if(recv(dir)) then + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + msgsize = msgsize + (ie-is+1)*(je-js+1) + end if + end do + + msgsize = msgsize*ke*l_size + if( msgsize.GT.0 )then from_pe = overPtr%pe - call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_2 ) + mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize) ) + if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then + write( text,'(i8)' )mpp_domains_stack_hwm + call mpp_error( FATAL, 'MPP_DO_UPDATE: mpp_domains_stack overflow, '// & + 'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.' ) + end if + call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=from_pe, tag=COMM_TAG_2 ) buffer_pos = buffer_pos + msgsize end if - end do ! end do ist = 0,nlist-1 + end do call mpp_sync_self(check=EVENT_RECV) + ! unpack and linear adjoint operation + ! in reverse order of pack process of mpp_do_update.fh buffer_pos = buffer_recv_size - - ! send do m = 1, update%nsend + send_msgsize(m) = 0 overPtr => update%send(m) if( overPtr%count == 0 )cycle pos = buffer_pos @@ -201,7 +279,13 @@ if( send(dir) ) msgsize = msgsize + overPtr%msgsize(n) enddo if( msgsize.GT.0 )then - buffer_pos = pos + msgsize = msgsize*ke*l_size + mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, pos+msgsize ) + if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then + write( text,'(i8)' )mpp_domains_stack_hwm + call mpp_error( FATAL, 'MPP_START_UPDATE_DOMAINS: mpp_domains_stack overflow, ' // & + 'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.') + end if end if do n = 1, overPtr%count @@ -259,15 +343,12 @@ end do end do end do - end select + end select endif end do ! do n = 1, overPtr%count - - msgsize = pos - buffer_pos - if( msgsize.GT.0 )then - buffer_pos = pos - end if - end do ! end do ist = 0,nlist-1 + send_msgsize(m) = pos-buffer_pos + buffer_pos = pos + end do call mpp_sync_self() diff --git a/mpp/include/mpp_get_boundary_ad.fh b/mpp/include/mpp_get_boundary_ad.fh index 56a18120e6..6701d375dd 100644 --- a/mpp/include/mpp_get_boundary_ad.fh +++ b/mpp/include/mpp_get_boundary_ad.fh @@ -21,7 +21,7 @@ !> @addtogroup mpp_domains_mod !> @{ -!> This routine is used to retrieve scalar boundary data for symmetric domain. +!> This routine is used to retrieve scalar ad boundary data for symmetric domain. subroutine MPP_GET_BOUNDARY_AD_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffer, flags, & position, complete, tile_count) type(domain2D), intent(in) :: domain diff --git a/mpp/include/mpp_global_field_ad.fh b/mpp/include/mpp_global_field_ad.fh index 7d948f9366..712d12e48e 100644 --- a/mpp/include/mpp_global_field_ad.fh +++ b/mpp/include/mpp_global_field_ad.fh @@ -21,8 +21,8 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - !> Get a global field from a local field - !! local field may be on compute OR data domain + !> Get a local ad field from a global ad field + !! global field may be on compute OR data domain subroutine MPP_GLOBAL_FIELD_2D_AD_( domain, local, global, flags, position,tile_count, default_data) type(domain2D), intent(in) :: domain MPP_TYPE_, intent(out) :: local(:,:) diff --git a/mpp/include/mpp_sum_mpi_ad.fh b/mpp/include/mpp_sum_mpi_ad.fh index 9b61b9457b..ee28d6c4bf 100644 --- a/mpp/include/mpp_sum_mpi_ad.fh +++ b/mpp/include/mpp_sum_mpi_ad.fh @@ -20,7 +20,7 @@ !* License along with FMS. If not, see . !*********************************************************************** !> Sums array a over the PEs in pelist (all PEs if this argument is omitted) - !! result is also automatically broadcast: all PEs have the sum in a at the end + !! forward array is already summed and broadcasted: all PEs already have the ad sum !! we are using f77-style call: array passed by address and not descriptor; further, !! the f90 conformance check is avoided. !> @ingroup mpp_mod diff --git a/mpp/include/mpp_sum_nocomm_ad.fh b/mpp/include/mpp_sum_nocomm_ad.fh index 9a427aa9d0..263bfde8d6 100644 --- a/mpp/include/mpp_sum_nocomm_ad.fh +++ b/mpp/include/mpp_sum_nocomm_ad.fh @@ -21,7 +21,7 @@ !*********************************************************************** !> Sums array a over the PEs in pelist (all PEs if this argument is omitted) - !! result is also automatically broadcast: all PEs have the sum in a at the end + !! forward array is already summed and broadcasted: all PEs already have the ad sum !! we are using f77-style call: array passed by address and not descriptor; further, !! the f90 conformance check is avoided. subroutine MPP_SUM_AD_( a, length, pelist ) diff --git a/mpp/include/mpp_update_domains2D_ad.fh b/mpp/include/mpp_update_domains2D_ad.fh index e5fc6e7af3..8a876fdba5 100644 --- a/mpp/include/mpp_update_domains2D_ad.fh +++ b/mpp/include/mpp_update_domains2D_ad.fh @@ -19,7 +19,7 @@ !*********************************************************************** !> @addtogroup mpp_domains_mod !> @{ - !> Updates data domain of 2D field whose computational domains have been computed + !> Updates data domain of 2D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_2D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count) MPP_TYPE_, intent(inout) :: field(:,:) @@ -39,7 +39,7 @@ return end subroutine MPP_UPDATE_DOMAINS_AD_2D_ - !> Updates data domain of 3D field whose computational domains have been computed + !> Updates data domain of 3D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_3D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count) MPP_TYPE_, intent(inout) :: field(:,:,:) @@ -176,7 +176,7 @@ end subroutine MPP_UPDATE_DOMAINS_AD_3D_ - !> Updates data domain of 4D field whose computational domains have been computed + !> Updates data domain of 4D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_4D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) MPP_TYPE_, intent(inout) :: field(:,:,:,:) @@ -196,7 +196,7 @@ return end subroutine MPP_UPDATE_DOMAINS_AD_4D_ - !> Updates data domain of 5D field whose computational domains have been computed + !> Updates data domain of 5D ad field whose computational domains have been computed subroutine MPP_UPDATE_DOMAINS_AD_5D_( field, domain, flags, complete, position, & whalo, ehalo, shalo, nhalo, name, tile_count ) MPP_TYPE_, intent(inout) :: field(:,:,:,:,:) @@ -224,7 +224,7 @@ !vector fields subroutine MPP_UPDATE_DOMAINS_AD_2D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) -!updates data domain of 2D field whose computational domains have been computed +!updates data domain of 2D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:), fieldy(:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype @@ -247,7 +247,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_3D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count) -!updates data domain of 3D field whose computational domains have been computed +!updates data domain of 3D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:,:), fieldy(:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype @@ -422,7 +422,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_4D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count ) -!updates data domain of 4D field whose computational domains have been computed +!updates data domain of 4D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:), fieldy(:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype @@ -445,7 +445,7 @@ subroutine MPP_UPDATE_DOMAINS_AD_5D_V_( fieldx, fieldy, domain, flags, gridtype, complete, & whalo, ehalo, shalo, nhalo, name, tile_count ) -!updates data domain of 5D field whose computational domains have been computed +!updates data domain of 5D ad field whose computational domains have been computed MPP_TYPE_, intent(inout) :: fieldx(:,:,:,:,:), fieldy(:,:,:,:,:) type(domain2D), intent(inout) :: domain integer, intent(in), optional :: flags, gridtype diff --git a/mpp/mpp_io.F90 b/mpp/mpp_io.F90 index 4a8fc1bb0b..297f2df41e 100644 --- a/mpp/mpp_io.F90 +++ b/mpp/mpp_io.F90 @@ -309,6 +309,7 @@ !> @{ module mpp_io_mod +#ifdef use_deprecated_io #define _MAX_FILE_UNITS 1024 @@ -1203,7 +1204,7 @@ module mpp_io_mod #include #include !---------- - +#endif end module mpp_io_mod !> @} ! close documentation grouping diff --git a/test_fms/data_override/test_data_override.F90 b/test_fms/data_override/test_data_override.F90 index eee88eddca..36f22b3143 100644 --- a/test_fms/data_override/test_data_override.F90 +++ b/test_fms/data_override/test_data_override.F90 @@ -46,12 +46,15 @@ program test use mpp_mod, only: input_nml_file, stdout, mpp_chksum use mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_define_io_domain, mpp_get_compute_domain, & & mpp_define_layout - use fms_mod, only: fms_init, fms_end, mpp_npes, file_exist, check_nml_error - use fms_mod, only: error_mesg, FATAL, file_exist, field_exist, field_size + use fms_mod, only: fms_init, fms_end, mpp_npes, check_nml_error, error_mesg, FATAL +#ifdef use_deprecated_io + use fms_mod, only: field_exist, field_size, file_exist +#endif use fms_affinity_mod, only: fms_affinity_set - use fms_io_mod, only: read_data, fms_io_exit + use fms2_io_mod, only: read_data, variable_exists, get_variable_size, FmsNetcdfFile_t, open_file use constants_mod, only: constants_init, pi - use time_manager_mod, only: time_type, set_calendar_type, set_date, NOLEAP, JULIAN, operator(+), set_time, print_time + use time_manager_mod, only: time_type, set_calendar_type, set_date, NOLEAP, JULIAN, operator(+), & + set_time, print_time use diag_manager_mod, only: diag_manager_init, diag_manager_end, register_static_field, register_diag_field use diag_manager_mod, only: send_data, diag_axis_init use data_override_mod, only: data_override_init, data_override, data_override_UG @@ -98,7 +101,7 @@ program test integer, allocatable :: is_win(:), js_win(:) integer :: nx_dom, ny_dom, nx_win, ny_win type(domain2d) :: Domain - integer :: nlon, nlat, siz(4) + integer :: nlon, nlat, siz(2) real, allocatable, dimension(:) :: x, y real, allocatable, dimension(:,:) :: lon, lat real, allocatable, dimension(:,:) :: sst, ice @@ -117,6 +120,9 @@ program test integer :: nwindows integer :: nx_cubic=90, ny_cubic=90, nx_latlon=90, ny_latlon=90 integer :: test_num=1 !* 1 for unstruct cubic grid, 2 for unstruct latlon-grid + + type(FmsNetcdfFile_t) :: fileobj_grid, fileobj_solo_mosaic, fileobj_tile + namelist / test_data_override_nml / layout, window, nthreads, nx_cubic, ny_cubic, nx_latlon, ny_latlon, test_num call fms_init @@ -131,23 +137,27 @@ program test read (input_nml_file, test_data_override_nml, iostat=io) ierr = check_nml_error(io, 'test_data_override_nml') - if(field_exist(grid_file, "x_T" ) ) then - call field_size(grid_file, 'x_T', siz) + if (.not. open_file(fileobj_grid, grid_file, "read")) call error_mesg('test_data_override', & + 'The grid_file does not exist', FATAL) + if(variable_exists(fileobj_grid, "x_T" ) ) then + call get_variable_size(fileobj_grid, 'x_T', siz) nlon = siz(1) nlat = siz(2) - else if(field_exist(grid_file, "geolon_t" ) ) then - call field_size(grid_file, 'geolon_t', siz) + else if(variable_exists(fileobj_grid, "geolon_t" ) ) then + call get_variable_size(fileobj_grid, 'geolon_t', siz) nlon = siz(1) nlat = siz(2) - else if (field_exist(grid_file, "ocn_mosaic_file" )) then - call read_data(grid_file, 'ocn_mosaic_file', solo_mosaic_file) + else if (variable_exists(fileobj_grid, "ocn_mosaic_file" )) then + call read_data(fileobj_grid, 'ocn_mosaic_file', solo_mosaic_file) solo_mosaic_file = 'INPUT/'//trim(solo_mosaic_file) - call field_size(solo_mosaic_file, 'gridfiles', siz) - if( siz(2) .NE. 1) & - call error_mesg('test_data_override', 'only support single tile mosaic, contact developer', FATAL) - call read_data(solo_mosaic_file, 'gridfiles', tile_file) + if (.not. open_file(fileobj_solo_mosaic, solo_mosaic_file, "read")) call error_mesg('test_data_override', & + 'The solo_mosaic fike does not exist', FATAL) + call get_variable_size(fileobj_solo_mosaic, 'gridfiles', siz) + call read_data(fileobj_solo_mosaic, 'gridfiles', tile_file) tile_file = 'INPUT/'//trim(tile_file) - call field_size(tile_file, 'area', siz) + if(.not. open_file(fileobj_tile, tile_file, "read")) call error_mesg('test_data_override', & + 'The tile_file does not exist', FATAL) + call get_variable_size(fileobj_tile, 'area', siz) if(mod(siz(1),2) .NE. 0 .OR. mod(siz(2),2) .NE. 0 ) call error_mesg('test_data_override', & "test_data_override: supergrid size can not be divided by 2", FATAL) nlon = siz(1)/2 @@ -306,41 +316,43 @@ program test !------------------------------------------------------------------------------------------------------- call diag_manager_end(Time) - call fms_io_exit call fms_end contains -!====================================================================================================================== +!==================================================================================================================== subroutine get_grid real, allocatable, dimension(:,:,:) :: lon_vert_glo, lat_vert_glo real, allocatable, dimension(:,:) :: lon_global, lat_global - integer, dimension(4) :: siz + integer, dimension(2) :: siz character(len=128) :: message + type(FmsNetcdfFile_t) :: fileobj_grid, fileobj_solo_mosaic, fileobj_tile - if(field_exist(grid_file, 'x_T')) then - call field_size(grid_file, 'x_T', siz) + if (.not. open_file(fileobj_grid, grid_file, "read")) call error_mesg('test_data_override', & + 'The grid_file does not exist', FATAL) + if(variable_exists(fileobj_grid, 'x_T')) then + call get_variable_size(fileobj_grid, 'x_T', siz) if(siz(1) /= nlon .or. siz(2) /= nlat) then write(message,'(a,2i4)') 'x_T is wrong shape. shape(x_T)=',siz(1:2) call error_mesg('test_data_override', trim(message), FATAL) endif allocate(lon_vert_glo(nlon,nlat,4), lat_vert_glo(nlon,nlat,4) ) allocate(lon_global (nlon,nlat ), lat_global (nlon,nlat ) ) - call read_data(trim(grid_file), 'x_vert_T', lon_vert_glo, no_domain=.true.) - call read_data(trim(grid_file), 'y_vert_T', lat_vert_glo, no_domain=.true.) + call read_data(fileobj_grid, 'x_vert_T', lon_vert_glo) + call read_data(fileobj_grid, 'y_vert_T', lat_vert_glo) lon_global(:,:) = (lon_vert_glo(:,:,1) + lon_vert_glo(:,:,2) + lon_vert_glo(:,:,3) + lon_vert_glo(:,:,4))*0.25 lat_global(:,:) = (lat_vert_glo(:,:,1) + lat_vert_glo(:,:,2) + lat_vert_glo(:,:,3) + lat_vert_glo(:,:,4))*0.25 - else if(field_exist(grid_file, "geolon_t" ) ) then - call field_size(grid_file, 'geolon_vert_t', siz) + else if(variable_exists(fileobj_grid, "geolon_t" ) ) then + call get_variable_size(fileobj_grid, 'geolon_vert_t', siz) if(siz(1) /= nlon+1 .or. siz(2) /= nlat+1) then write(message,'(a,2i4)') 'geolon_vert_t is wrong shape. shape(geolon_vert_t)=',siz(1:2) call error_mesg('test_data_override', trim(message), FATAL) endif allocate(lon_vert_glo(nlon+1,nlat+1,1), lat_vert_glo(nlon+1,nlat+1,1)) allocate(lon_global (nlon, nlat ), lat_global (nlon, nlat )) - call read_data(trim(grid_file), 'geolon_vert_t', lon_vert_glo, no_domain=.true.) - call read_data(trim(grid_file), 'geolat_vert_t', lat_vert_glo, no_domain=.true.) + call read_data(fileobj_grid, 'geolon_vert_t', lon_vert_glo) + call read_data(fileobj_grid, 'geolat_vert_t', lat_vert_glo) do i = 1, nlon do j = 1, nlat @@ -350,16 +362,18 @@ subroutine get_grid lat_vert_glo(i+1,j+1,1) + lat_vert_glo(i,j+1,1))*0.25 enddo enddo - else if( field_exist(grid_file, "ocn_mosaic_file") ) then ! reading from mosaic file - call field_size(tile_file, 'area', siz) + else if( variable_exists(fileobj_grid, "ocn_mosaic_file") ) then ! reading from mosaic file + if(.not. open_file(fileobj_tile, tile_file, "read")) call error_mesg('test_data_override', & + 'The tile_file does not exist', FATAL) + call get_variable_size(fileobj_tile, 'area', siz) if(siz(1) /= nlon*2 .or. siz(2) /= nlat*2) then write(message,'(a,2i4)') 'area is wrong shape. shape(area)=',siz(1:2) call error_mesg('test_data_override', trim(message), FATAL) endif allocate(lon_vert_glo(siz(1)+1,siz(2)+1,1), lat_vert_glo(siz(1)+1,siz(2)+1,1)) allocate(lon_global (nlon, nlat ), lat_global (nlon, nlat )) - call read_data( tile_file, 'x', lon_vert_glo, no_domain=.true.) - call read_data( tile_file, 'y', lat_vert_glo, no_domain=.true.) + call read_data(fileobj_tile, 'x', lon_vert_glo) + call read_data(fileobj_tile, 'y', lat_vert_glo) do j = 1, nlat do i = 1, nlon lon_global(i,j) = lon_vert_glo(i*2,j*2,1) @@ -824,5 +838,5 @@ subroutine define_cubic_mosaic(type, domain, ni, nj, global_indices, layout, pe_ end subroutine define_cubic_mosaic -!====================================================================================================================== +!==================================================================================================================== end program test diff --git a/test_fms/diag_manager/test_diag_manager.F90 b/test_fms/diag_manager/test_diag_manager.F90 index b943cb38af..dd263d2e3f 100644 --- a/test_fms/diag_manager/test_diag_manager.F90 +++ b/test_fms/diag_manager/test_diag_manager.F90 @@ -223,15 +223,17 @@ PROGRAM test ! Because of this, the calls to all of those routines differ depending on the test. USE mpp_mod, ONLY: mpp_pe, mpp_root_pe, mpp_debug, mpp_set_stack_size - USE mpp_io_mod, ONLY: mpp_io_init USE mpp_domains_mod, ONLY: domain2d, mpp_define_domains, mpp_get_compute_domain USE mpp_domains_mod, ONLY: mpp_define_io_domain, mpp_define_layout USE mpp_domains_mod, ONLY: mpp_domains_init, mpp_domains_set_stack_size - USE fms_mod, ONLY: fms_init, fms_end, mpp_npes, file_exist, check_nml_error, open_file + USE fms_mod, ONLY: fms_init, fms_end, mpp_npes, check_nml_error USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdlog, stdout USE mpp_mod, ONLY: input_nml_file - USE fms_io_mod, ONLY: fms_io_init +#ifdef use_deprecated_io + USE fms_io_mod, ONLY: fms_io_init, file_exist, open_file USE fms_io_mod, ONLY: fms_io_exit, set_filename_appendix + use mpp_io_mod, only: mpp_io_init +#endif USE constants_mod, ONLY: constants_init, PI, RAD_TO_DEG USE time_manager_mod, ONLY: time_type, set_calendar_type, set_date, decrement_date, OPERATOR(+), set_time @@ -374,14 +376,13 @@ PROGRAM test endif !Initialize the mpp_io module. +#ifdef use_deprecated_io if (debug) then call mpp_io_init(MPP_DEBUG) else call mpp_io_init() endif - - !Initialize the fms_io module. - call fms_io_init() +#endif !Set the mpp and mpp_domains stack sizes. call mpp_set_stack_size(stackmax) @@ -546,7 +547,9 @@ PROGRAM test IF ( test_number == 16 ) THEN ! Test 16 tests the filename appendix +#ifdef use_deprecated_io CALL set_filename_appendix('g01') +#endif END IF id_dat1 = register_diag_field('test_diag_manager_mod', 'dat1', (/id_lon1,id_lat1,id_pfull/), Time, 'sample data','K') IF ( test_number == 18 ) THEN @@ -1002,7 +1005,6 @@ PROGRAM test CALL diag_manager_end(Time) END SELECT ! End of case handling opened for test 12. - CALL fms_io_exit CALL fms_end CONTAINS diff --git a/test_fms/fms2_io/test_fms2_io.sh b/test_fms/fms2_io/test_fms2_io.sh index 8a604e6655..5e0bd31c0e 100755 --- a/test_fms/fms2_io/test_fms2_io.sh +++ b/test_fms/fms2_io/test_fms2_io.sh @@ -31,16 +31,6 @@ # Create and enter output directory output_dir -# use smaller arrays if system stack size is limited -if [ $STACK_LIMITED ]; then - cat <<_EOF > input.nml -&test_fms2_io_nml - nx = 32 - ny = 32 - nz = 10 -/ -_EOF -fi touch input.nml # run the tests diff --git a/test_fms/interpolator/test_interpolator.F90 b/test_fms/interpolator/test_interpolator.F90 index 367ceefa4a..4636cde918 100644 --- a/test_fms/interpolator/test_interpolator.F90 +++ b/test_fms/interpolator/test_interpolator.F90 @@ -37,12 +37,17 @@ program test_interpolator use mpp_mod use mpp_domains_mod +#ifdef use_deprecated_io +use fms_mod, old_open_file => open_file +#else use fms_mod +#endif use time_manager_mod use diag_manager_mod use interpolator_mod use constants_mod use time_interp_mod, only : time_interp_init +use fms2_io_mod, only : open_file, FmsNetcdfFile_t implicit none integer, parameter :: nsteps_per_day = 8, ndays = 16 @@ -255,8 +260,12 @@ subroutine sulfate_init(aerosol,lonb, latb, names, data_out_of_bounds, vert_inte integer, intent(in) :: data_out_of_bounds(:) integer, intent(in), optional :: vert_interp(:) character(len=*), intent(out),optional :: units(:) +character(len=128) :: filename_aerosol -if (.not. file_exist("INPUT/aerosol.climatology.nc") ) return +type(FmsNetcdfFile_t) :: fileobj_aerosol + +filename_aerosol = "INPUT/aerosol.climatology.nc" +if (.not. open_file(fileobj_aerosol, filename_aerosol, "read") ) return call interpolator_init( aerosol, "aerosol.climatology.nc", lonb, latb, & data_names=names, data_out_of_bounds=data_out_of_bounds, & vert_interp=vert_interp, clim_units=units ) @@ -287,8 +296,12 @@ subroutine ozone_init( o3, lonb, latb, axes, model_time, data_out_of_bounds, ver type(interpolate_type),intent(inout) :: o3 integer, intent(in) :: data_out_of_bounds(:) integer, intent(in), optional :: vert_interp(:) +character(len=128) :: filename_o3 + +type(FmsNetcdfFile_t) :: fileobj_o3 -if (.not. file_exist("INPUT/o3.climatology.nc") ) return +filename_o3 = "INPUT/o3.climatology.nc" +if (.not. open_file(fileobj_o3, filename_o3, "read") ) return call interpolator_init( o3, "o3.climatology.nc", lonb, latb, & data_out_of_bounds=data_out_of_bounds, vert_interp=vert_interp ) diff --git a/test_fms/mpp/test_domains_utility_mod.F90 b/test_fms/mpp/test_domains_utility_mod.F90 index 43271e053f..f88054b9f5 100644 --- a/test_fms/mpp/test_domains_utility_mod.F90 +++ b/test_fms/mpp/test_domains_utility_mod.F90 @@ -22,9 +22,9 @@ module test_domains_utility_mod use mpp_mod, only : FATAL, WARNING, MPP_DEBUG, NOTE use mpp_mod, only : mpp_error - use mpp_domains_mod, only : ZERO, NINETY, MINUS_NINETY + use mpp_domains_mod, only : ZERO, NINETY, MINUS_NINETY, & + domain2d, mpp_define_mosaic use platform_mod, only: r4_kind, r8_kind - use fms interface fill_coarse_data module procedure fill_coarse_data_r8 diff --git a/test_fms/mpp/test_global_arrays.F90 b/test_fms/mpp/test_global_arrays.F90 index edb3605df6..4f27b0c666 100644 --- a/test_fms/mpp/test_global_arrays.F90 +++ b/test_fms/mpp/test_global_arrays.F90 @@ -28,28 +28,30 @@ program test_global_arrays use mpp_mod, only: mpp_set_stack_size, mpp_sync, mpp_sync_self use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_send, mpp_recv, WARNING use mpp_mod, only: mpp_init_test_init_true_only, mpp_set_root_pe - use mpp_io_mod, only: mpp_io_init use mpp_domains_mod, only: mpp_domains_init, mpp_define_domains, domain2d use mpp_domains_mod, only: mpp_define_layout, mpp_domains_set_stack_size use mpp_domains_mod, only: mpp_get_global_domain, mpp_global_max use mpp_domains_mod, only: mpp_global_min, mpp_get_data_domain,mpp_get_compute_domain use mpp_domains_mod, only: mpp_domains_exit, mpp_update_domains use mpp_domains_mod, only: mpp_get_domain_shift, mpp_global_sum + use mpp_domains_mod, only: CYCLIC_GLOBAL_DOMAIN, NORTH, EAST, CENTER, CORNER, BITWISE_EXACT_SUM + use mpp_mod, only: MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, mpp_clock_id, mpp_clock_begin, mpp_clock_end + use fms_mod, only: check_nml_error, input_nml_file implicit none integer, parameter :: length=64 - integer :: id, pe, npes, root, i, j, icount, jcount - integer(i4_kind) :: maxI4, minI4, ierr, sumI4, sumI4_5d - integer(i8_kind) :: maxI8, minI8, sumI8, sumI8_5d - integer(i4_kind), allocatable :: dataI4(:,:), dataI4_5d(:,:,:,:,:), dataI4_shuf(:,:) - integer(i8_kind), allocatable :: dataI8(:,:), dataI8_5d(:,:,:,:,:), dataI8_shuf(:,:) - real(r4_kind), allocatable :: dataR4(:,:), dataR4_5d(:,:,:,:,:), dataR4_shuf(:,:) - real(r8_kind), allocatable :: dataR8(:,:), dataR8_5d(:,:,:,:,:), dataR8_shuf(:,:) + integer :: id, pe, npes, root, i, j, icount, jcount, io + integer(i4_kind) :: maxI4, minI4, ierr, sumI4, sumI4_5d, sumI4_shuf + integer(i8_kind) :: maxI8, minI8, sumI8, sumI8_5d, sumI8_shuf + integer(i4_kind), allocatable :: dataI4(:,:), dataI4_shuf(:,:), recv_data_i4(:,:) + integer(i8_kind), allocatable :: dataI8(:,:), dataI8_shuf(:,:), recv_data_i8(:,:) + real(r4_kind), allocatable :: dataR4(:,:), dataR4_shuf(:,:), recv_data_r4(:,:) + real(r8_kind), allocatable :: dataR8(:,:), dataR8_shuf(:,:), recv_data_r8(:,:) real, allocatable :: rands(:) type(domain2D) :: domain - real(r8_kind) :: rcoef, maxR8, minR8, sumR8, sumR8_5d - real(r4_kind) :: maxR4, minR4, sumR4, sumR4_5d + real(r8_kind) :: rcoef, maxR8, minR8, sumR8, sumR8_shuf + real(r4_kind) :: maxR4, minR4, sumR4, sumR4_shuf integer :: isc, iec, jsc, jec integer :: isd, ied, jsd, jed character(len=32) :: strTmp1, strTmp2 @@ -57,23 +59,60 @@ program test_global_arrays integer(i8_kind), parameter :: randmaxI8 = 4096 real(r8_kind), parameter :: tol4 = 1e-4, tol8 = 1e-6!> tolerance for real comparisons - call mpp_init(mpp_init_test_init_true_only) - call mpp_io_init() + ! namelist variables - just logicals to enable individual tests + ! simple just does normal max/min + sums across a domain + ! full does max/min+sums with halos and symmetry + logical :: test_simple= .false. , test_full = .false. + namelist / test_global_arrays_nml / test_simple, test_full + + call mpp_init() + call mpp_domains_init() - call mpp_set_stack_size(3145746) - call mpp_domains_set_stack_size(3145746) + !call mpp_set_stack_size(3145746) + call mpp_domains_set_stack_size(4000000) + + read(input_nml_file, nml=test_global_arrays_nml, iostat=io) + ierr = check_nml_error(io, 'test_global_arrays_nml') pe = mpp_pe() npes = mpp_npes() call mpp_set_root_pe(0) root = mpp_root_pe() + if( test_simple) then + call test_mpp_global_simple() + deallocate(dataI4, dataI8, dataR4, dataR8, rands) + deallocate(dataR4_shuf, dataR8_shuf,dataI4_shuf, dataI8_shuf) + else if(test_full) then + call test_global_reduce( 'Simple') + call test_global_reduce( 'Simple symmetry center') + call test_global_reduce( 'Simple symmetry corner') + call test_global_reduce( 'Simple symmetry east') + call test_global_reduce( 'Simple symmetry north') + call test_global_reduce( 'Cyclic symmetry center') + call test_global_reduce( 'Cyclic symmetry corner') + call test_global_reduce( 'Cyclic symmetry east') + call test_global_reduce( 'Cyclic symmetry north') + else + call mpp_error(FATAL, "test_global_arrays: either test_sum or test_max_min must be true in input.nml") + endif + call mpp_sync() + + call mpp_domains_exit() + call MPI_FINALIZE(ierr) + + contains + +subroutine test_mpp_global_simple() + !> define domains and allocate - call mpp_define_domains( (/1,length,1,length/), (/4,2/), domain, xhalo=0) + call mpp_define_domains( (/1,length,1,length/), (/1,8/), domain, xhalo=0) call mpp_get_compute_domain(domain, jsc, jec, isc, iec) call mpp_get_data_domain(domain, jsd, jed, isd, ied) allocate(dataI4(jsd:jed, isd:ied),dataI8(jsd:jed, isd:ied), rands(length*length)) allocate(dataR4(jsd:jed, isd:ied), dataR8(jsd:jed, isd:ied)) allocate(dataR4_shuf(jsd:jed, isd:ied), dataR8_shuf(jsd:jed, isd:ied)) allocate(dataI4_shuf(jsd:jed, isd:ied), dataI8_shuf(jsd:jed, isd:ied)) + allocate(recv_data_r4(jsd:jed, isd:ied), recv_data_r8(jsd:jed, isd:ied)) + allocate(recv_data_i4(jsd:jed, isd:ied), recv_data_i8(jsd:jed, isd:ied)) dataI4 = 0; dataI8 = 0; dataR4 = 0.0; dataR8 = 0.0 dataR8_shuf=0.0; dataR4_shuf=0.0;dataI8_shuf=0; dataI4_shuf=0 @@ -168,97 +207,92 @@ program test_global_arrays NEW_LINE('a')//"Sum: "// strTmp1 ) endif - !> shuffle real data ordering and copy into array with 5 ranks - dataR4_shuf = dataR4 - dataR8_shuf = dataR8 - call shuffleDataR4(dataR4_shuf) - call shuffleDataR8(dataR8_shuf) - allocate(dataR4_5d(jsd:jed, isd:ied, 1, 1, 1), dataR8_5d(jsd:jed,isd:ied, 1, 1, 1)) - - dataR4_5d = 0.0 - dataR8_5d = 0.0 - - do i=isc,iec - do j=jsc,jec - dataR4_5d(j, i, 1, 1, 1) = dataR4_shuf(j, i) - dataR8_5d(j, i, 1, 1, 1) = dataR8_shuf(j, i) - end do - end do + !> moves the data into different pe's and checks the sum still matches + dataR4_shuf = dataR4 ; dataR8_shuf = dataR8 + dataI4_shuf = dataI4 ; dataI8_shuf = dataI8 + !! swap data with neighboring pe + if(modulo(pe, 2) .eq. 0) then + print *, pe, pe+1, SUM(dataR8_shuf) + call mpp_send(dataR4_shuf, SIZE(dataR4_shuf), pe+1) + call mpp_recv(recv_data_r4, SIZE(dataR4_shuf), pe+1) + call mpp_sync() + call mpp_send(dataR8_shuf, SIZE(dataR8_shuf), pe+1) + call mpp_recv(recv_data_r8, SIZE(dataR8_shuf), pe+1) + call mpp_sync() + call mpp_send(dataI4_shuf, SIZE(dataI4_shuf), pe+1) + call mpp_recv(recv_data_I4, SIZE(dataI4_shuf), pe+1) + call mpp_sync() + call mpp_send(dataI8_shuf, SIZE(dataI8_shuf), pe+1) + call mpp_recv(recv_data_I8, SIZE(dataI8_shuf), pe+1) + else + print *, pe, pe-1, SUM(dataR8_shuf) + call mpp_recv(recv_data_r4, SIZE(dataR4_shuf), pe-1) + call mpp_send(dataR4_shuf, SIZE(dataR4_shuf), pe-1) + call mpp_sync() + call mpp_recv(recv_data_r8, SIZE(dataR8_shuf), pe-1) + call mpp_send(dataR8_shuf, SIZE(dataR8_shuf), pe-1) + call mpp_sync() + call mpp_send(dataI4_shuf, SIZE(dataI4_shuf), pe-1) + call mpp_recv(recv_data_I4, SIZE(dataI4_shuf), pe-1) + call mpp_sync() + call mpp_send(dataI8_shuf, SIZE(dataI8_shuf), pe-1) + call mpp_recv(recv_data_I8, SIZE(dataI8_shuf), pe-1) + endif call mpp_sync() + dataR4_shuf = recv_data_r4 + dataR8_shuf = recv_data_r8 - call mpp_error(NOTE, "----------Testing 32-bit real mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataR4_5d, domain) - sumR4_5d = mpp_global_sum(domain, dataR4_5d) + call mpp_error(NOTE, "----------Testing 32-bit real mpp_global_sum with reordering----------") + call mpp_update_domains(dataR4_shuf, domain) + sumR4_shuf = mpp_global_sum(domain, dataR4_shuf) ! check that shuffled array results are approximately the same as the original array - if(abs(sumR4-sumR4_5d) .gt. 1E-4 ) then + if(abs(sumR4-sumR4_shuf) .gt. 1E-4 ) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumR4_5d + write(strTmp1,*) sumR4_shuf write(strTmp2,*) sumR4 call mpp_error(FATAL,"test_global_arrays: invalid 32-bit real answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - call mpp_error(NOTE, "----------Testing 64-bit real mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataR8_5d, domain) - sumR8_5d = mpp_global_sum(domain, dataR8_5d) + call mpp_sync() + call mpp_error(NOTE, "----------Testing 64-bit real mpp_global_sum with reordering----------") + call mpp_update_domains(dataR8_shuf, domain) + sumR8_shuf = mpp_global_sum(domain, dataR8_shuf) ! check that shuffled array results are approximately the same as the original array - if(abs(sumR8-sumR8_5d) .gt. 1E-7) then + if(abs(sumR8-sumR8_shuf) .gt. 1E-7) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumR8_5d + write(strTmp1,*) sumR8_shuf write(strTmp2,*) sumR8 call mpp_error(FATAL,"test_global_arrays: invalid 64-bit real answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - !> shuffle integer data ordering and copy into array with 5 ranks - dataI4_shuf = dataI4 - dataI8_shuf = dataI8 - call shuffleDataI4(dataI4_shuf) - call shuffleDataI8(dataI8_shuf) - allocate(dataI4_5d(jsd:jed, isd:ied, 1, 1, 1), dataI8_5d(jsd:jed,isd:ied, 1, 1, 1)) - - dataI4_5d = 0 - dataI8_5d = 0 - do i=isc,iec - do j=jsc,jec - dataI4_5d(j, i, 1, 1, 1) = dataI4_shuf(j, i) - dataI8_5d(j, i, 1, 1, 1) = dataI8_shuf(j, i) - end do - end do - call mpp_sync() - - call mpp_error(NOTE, "----------Testing 32-bit integer mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataI4_5d, domain) - sumI4_5d = mpp_global_sum(domain, dataI4_5d) + call mpp_error(NOTE, "----------Testing 32-bit integer mpp_global_sum with reordering----------") + call mpp_update_domains(dataI4_shuf, domain) + sumI4_shuf = mpp_global_sum(domain, dataI4_shuf) ! check that shuffled array results are approximately the same as the original array - if(sumI4 .ne. sumI4_5d) then + if(sumI4 .ne. sumI4_shuf) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumI4_5d + write(strTmp1,*) sumI4_shuf write(strTmp2,*) sumI4 call mpp_error(FATAL,"test_global_arrays: invalid 32-bit integer answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - call mpp_error(NOTE, "----------Testing 64-bit integer mpp_global_sum with 5 ranks and reordering----------") - call mpp_update_domains(dataI8_5d, domain) - sumI8_5d = mpp_global_sum(domain, dataI8_5d) + call mpp_error(NOTE, "----------Testing 64-bit integer mpp_global_sum with reordering----------") + call mpp_update_domains(dataI8_shuf, domain) + sumI8_shuf = mpp_global_sum(domain, dataI8_shuf) ! check that shuffled array results are approximately the same as the original array - if(sumI8 .ne. sumI8_5d) then + if(sumI8 .ne. sumI8_shuf) then strTmp1 = ""; strTmp2="" - write(strTmp1,*) sumI8_5d + write(strTmp1,*) sumI8_shuf write(strTmp2,*) sumI8 call mpp_error(FATAL,"test_global_arrays: invalid 64-bit integer answer after reordering"// & NEW_LINE('a')//"Sum: "// strTmp1// " ne "//strTmp2) endif - - deallocate(dataI4, dataI8, dataR4, dataR8, rands, dataI4_5d, dataI8_5d, dataR4_5d, dataR8_5d) - deallocate(dataR4_shuf, dataR8_shuf,dataI4_shuf, dataI8_shuf) - call mpp_domains_exit() - call MPI_FINALIZE(ierr) - - contains +end subroutine test_mpp_global_simple !> true if all pes return the same result and have a lower/higher local max/min function checkResultInt4(res) @@ -370,7 +404,6 @@ function checkSumReal4(gsum) real(r4_kind),intent(in) :: gsum real(r4_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 real(r4_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -404,7 +437,6 @@ function checkSumReal8(gsum) real(r8_kind),intent(in) :: gsum real(r8_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 real(r8_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -438,7 +470,6 @@ function checkSumInt4(gsum) integer(i4_kind),intent(in) :: gsum integer(i4_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 integer(i4_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -472,7 +503,6 @@ function checkSumInt8(gsum) integer(i8_kind),intent(in) :: gsum integer(i8_kind),allocatable :: recv(:) !> pe's local sum at 1, global sum at 2 integer(i8_kind) :: nsum - integer :: i allocate(recv(2)) ! root receives and sums local sums from each pe @@ -499,192 +529,123 @@ function checkSumInt8(gsum) deallocate(recv) end function checkSumInt8 -!> aggregates data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataI4(dataI4) - integer(i4_kind), intent(INOUT) :: dataI4(:,:) - integer(i4_kind), allocatable :: trans(:,:), shuffled(:),tmp - integer :: rind - - allocate(trans(SIZE(dataI4,1), SIZE(dataI4,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataI4)) = RESHAPE(dataI4, (/SIZE(dataI4)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataI4) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataI4 = trans - endif - end do - else - call mpp_send(dataI4, SIZE(dataI4), root) - call mpp_recv(trans, SIZE(dataI4), root) - dataI4 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataI4 - -!> aggregates data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataI8(dataI8) - integer(i8_kind), intent(INOUT) :: dataI8(:,:) - integer(i8_kind), allocatable :: trans(:,:), shuffled(:), tmp - integer :: rind - - allocate(trans(SIZE(dataI8,1), SIZE(dataI8,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataI8)) = RESHAPE(dataI8, (/SIZE(dataI8)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataI8) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataI8 = trans - endif - end do - else - call mpp_send(dataI8, SIZE(dataI8), root) - call mpp_recv(trans, SIZE(dataI8), root) - dataI8 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataI8 - -!> aggregates 32-bit real data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataR4(dataR4) - real(r4_kind), intent(INOUT) :: dataR4(:,:) - real(r4_kind), allocatable :: trans(:,:), shuffled(:), tmp - integer :: rind - - allocate(trans(SIZE(dataR4,1), SIZE(dataR4,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataR4)) = RESHAPE(dataR4, (/SIZE(dataR4)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataR4) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataR4 = trans - endif - end do - else - call mpp_send(dataR4, SIZE(dataR4), root) - call mpp_recv(trans, SIZE(dataR4), root) - dataR4 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataR4 - -!> aggregates 64-bit real data on root and randomizes ordering, then sends partitions back to pes -subroutine shuffleDataR8(dataR8) - real(r8_kind), intent(INOUT) :: dataR8(:,:) - real(r8_kind), allocatable :: trans(:,:), shuffled(:), tmp - integer :: rind - - allocate(trans(SIZE(dataR8,1), SIZE(dataR8,2))) - allocate(shuffled(1:length*length)) - - if( pe.eq.root) then - !> get array partitions and aggregate into 1d - shuffled(1:SIZE(dataR8)) = RESHAPE(dataR8, (/SIZE(dataR8)/)) - do i=1, npes-1 - call mpp_recv(trans, SIZE(dataR8) , i) - shuffled( SIZE(trans)*i+1 : SIZE(trans)*(i+1)) = RESHAPE(trans, (/SIZE(trans)/)) - end do - - !> shuffle order - do i=1, length*length - rind = (rands(i) * length * length) - if( rind .eq. 0) then - rind = 1 - endif - tmp = shuffled(i) - shuffled(i) = shuffled(rind) - shuffled(rind) = tmp - end do - trans = 0 - - !> send back to pes - do i=0, npes-1 - trans = RESHAPE(shuffled(SIZE(trans)*i + 1:SIZE(trans)*(i+1)), & - (/SIZE(trans,1), SIZE(trans,2) /) ) - if(i.ne.root) then - call mpp_send(trans, SIZE(trans), i) - else - dataR8 = trans - endif - end do - else - call mpp_send(dataR8, SIZE(dataR8), root) - call mpp_recv(trans, SIZE(dataR8), root) - dataR8 = trans - endif - deallocate(trans, shuffled) -end subroutine shuffleDataR8 + !--- test mpp_global_sum, mpp_global_min and mpp_global_max + subroutine test_global_reduce (type) + character(len=*), intent(in) :: type + real :: lsum, gsum, lmax, gmax, lmin, gmin + integer :: ni, nj, ishift, jshift, position, k + integer :: is, ie, js, je !, isd, ied, jsd, jed + integer :: nx=128, ny=128, nz=40, stackmax=4000000 + integer :: layout(2) + integer :: whalo = 2, ehalo = 2, shalo = 2, nhalo = 2 + real, allocatable, dimension(:,:,:) :: global1, x + real, allocatable, dimension(:,:) :: global2D + !--- set up domain + call mpp_define_layout( (/1,nx,1,ny/), npes, layout ) + select case(type) + case( 'Simple' ) + call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & + shalo=shalo, nhalo=nhalo, name=type ) + case( 'Simple symmetry center', 'Simple symmetry corner', 'Simple symmetry east', 'Simple symmetry north' ) + call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & + shalo=shalo, nhalo=nhalo, name=type, symmetry = .true. ) + case( 'Cyclic symmetry center', 'Cyclic symmetry corner', 'Cyclic symmetry east', 'Cyclic symmetry north' ) + call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo,& + name=type, symmetry = .true., xflags=CYCLIC_GLOBAL_DOMAIN, & + & yflags=CYCLIC_GLOBAL_DOMAIN ) + case default + call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type//' in test_global_field' ) + end select + call mpp_get_compute_domain( domain, is, ie, js, je ) + call mpp_get_data_domain ( domain, isd, ied, jsd, jed ) + + !--- determine if an extra point is needed + ishift = 0; jshift = 0; position = CENTER + select case(type) + case ('Simple symmetry corner', 'Cyclic symmetry corner') + ishift = 1; jshift = 1; position = CORNER + case ('Simple symmetry east', 'Cyclic symmetry east' ) + ishift = 1; jshift = 0; position = EAST + case ('Simple symmetry north', 'Cyclic symmetry north') + ishift = 0; jshift = 1; position = NORTH + end select + + ie = ie+ishift; je = je+jshift + ied = ied+ishift; jed = jed+jshift + ni = nx+ishift; nj = ny+jshift + allocate(global1(1-whalo:ni+ehalo, 1-shalo:nj+nhalo, nz)) + global1 = 0.0 + do k = 1,nz + do j = 1,nj + do i = 1,ni + global1(i,j,k) = k + i*1e-3 + j*1e-6 + end do + end do + enddo + + !--- NOTE: even though the domain is cyclic, no need to apply cyclic condition on the global data + + allocate( x (isd:ied,jsd:jed,nz) ) + allocate( global2D(ni,nj)) + + x(:,:,:) = global1(isd:ied,jsd:jed,:) + do j = 1, nj + do i = 1, ni + global2D(i,j) = sum(global1(i,j,:)) + enddo + enddo + !test mpp_global_sum + + if(type(1:6) == 'Simple') then + gsum = sum( global2D(1:ni,1:nj) ) + else + gsum = sum( global2D(1:nx, 1:ny) ) + endif + id = mpp_clock_id( type//' sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lsum = mpp_global_sum( domain, x, position = position ) + call mpp_clock_end (id) + if( pe.EQ.mpp_root_pe() )print '(a,2es15.8,a,es12.4)', type//' Fast sum=', lsum, gsum + + !test exact mpp_global_sum + id = mpp_clock_id( type//' exact sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lsum = mpp_global_sum( domain, x, BITWISE_EXACT_SUM, position = position ) + call mpp_clock_end (id) + !--- The following check will fail on altix in normal mode, but it is ok + !--- in debugging mode. It is ok on irix. + call compare_data_scalar(lsum, gsum, FATAL, type//' mpp_global_exact_sum') + + !test mpp_global_min + gmin = minval(global1(1:ni, 1:nj, :)) + id = mpp_clock_id( type//' min', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lmin = mpp_global_min( domain, x, position = position ) + call mpp_clock_end (id) + call compare_data_scalar(lmin, gmin, FATAL, type//' mpp_global_min') + + !test mpp_global_max + gmax = maxval(global1(1:ni, 1:nj, :)) + id = mpp_clock_id( type//' max', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) + call mpp_clock_begin(id) + lmax = mpp_global_max( domain, x, position = position ) + call mpp_clock_end (id) + call compare_data_scalar(lmax, gmax, FATAL, type//' mpp_global_max' ) + + deallocate(global1, x) + + end subroutine test_global_reduce + + subroutine compare_data_scalar( a, b, action, string ) + real, intent(in) :: a, b + integer, intent(in) :: action + character(len=*), intent(in) :: string + if( a .EQ. b)then + if( pe.EQ.mpp_root_pe() )call mpp_error( NOTE, trim(string)//': data comparison are OK.' ) + else + call mpp_error( action, trim(string)//': data comparison are not OK.' ) + end if + + end subroutine compare_data_scalar end program test_global_arrays diff --git a/test_fms/mpp/test_global_arrays.sh b/test_fms/mpp/test_global_arrays.sh index 596d1ecb0a..18390415e5 100755 --- a/test_fms/mpp/test_global_arrays.sh +++ b/test_fms/mpp/test_global_arrays.sh @@ -27,10 +27,26 @@ # Set common test settings. . ../test-lib.sh -# ensure input.nml file present -touch input.nml +cat <<_EOF > input.nml +&test_global_arrays_nml + test_simple = .true. + test_full = .false. +/ +_EOF -test_expect_success "global array functions with mixed precision" ' +test_expect_success "mpp_global_sum/max/min with simple domain" ' mpirun -n 8 ./test_global_arrays ' + +cat <<_EOF > input.nml +&test_global_arrays_nml + test_simple = .false. + test_full = .true. +/ +_EOF + +test_expect_success "mpp_global_sum/max/min with symmetry and halos" ' + mpirun -n 6 ./test_global_arrays +' + test_done diff --git a/test_fms/mpp/test_mpp.F90 b/test_fms/mpp/test_mpp.F90 index 6e0e609f92..034ff3a850 100644 --- a/test_fms/mpp/test_mpp.F90 +++ b/test_fms/mpp/test_mpp.F90 @@ -27,7 +27,6 @@ program test !test various aspects of mpp_mod use mpp_mod, only : mpp_declare_pelist, mpp_set_current_pelist, mpp_set_stack_size use mpp_mod, only : mpp_broadcast, mpp_transmit, mpp_sum, mpp_max, mpp_chksum, ALL_PES use mpp_mod, only : mpp_gather, mpp_error, FATAL, mpp_sync_self - use mpp_io_mod, only: mpp_io_init, mpp_flush use platform_mod implicit none @@ -42,7 +41,6 @@ program test !test various aspects of mpp_mod real :: dt call mpp_init() - call mpp_io_init() call mpp_set_stack_size(3145746) pe = mpp_pe() npes = mpp_npes() diff --git a/test_fms/mpp/test_mpp_chksum.F90 b/test_fms/mpp/test_mpp_chksum.F90 index a63ee7d22e..5810e42cab 100644 --- a/test_fms/mpp/test_mpp_chksum.F90 +++ b/test_fms/mpp/test_mpp_chksum.F90 @@ -23,7 +23,10 @@ !> single pe and distributed checksums program test_mpp_chksum - use fms + use mpp_mod + use mpp_domains_mod + use fms_mod + use platform_mod implicit none diff --git a/test_fms/mpp/test_mpp_chksum.sh b/test_fms/mpp/test_mpp_chksum.sh index 03d252794b..bea691aa5f 100755 --- a/test_fms/mpp/test_mpp_chksum.sh +++ b/test_fms/mpp/test_mpp_chksum.sh @@ -29,11 +29,6 @@ echo "&test_mpp_chksum_nml" > input.nml echo "test_num = 1" >> input.nml -# replaces defaults with smaller sizes if stack size is limited -if [ $STACK_LIMITED ]; then - echo "nx = 64" >> input.nml - echo "ny = 64" >> input.nml -fi echo "/" >> input.nml test_expect_success "mpp_chksum simple functionality" ' diff --git a/test_fms/mpp/test_mpp_domains.F90 b/test_fms/mpp/test_mpp_domains.F90 index ab9ba1a447..3ca557788f 100644 --- a/test_fms/mpp/test_mpp_domains.F90 +++ b/test_fms/mpp/test_mpp_domains.F90 @@ -54,7 +54,7 @@ program test_mpp_domains NONSYMEDGEUPDATE use mpp_domains_mod, only : domainUG, mpp_define_unstruct_domain, mpp_get_UG_domain_tile_id use mpp_domains_mod, only : mpp_get_UG_compute_domain, mpp_pass_SG_to_UG, mpp_pass_UG_to_SG - use mpp_domains_mod, only : mpp_global_field_ug + use mpp_domains_mod, only : mpp_global_field_ug, mpp_get_ug_global_domain use compare_data_checksums use test_domains_utility_mod @@ -250,17 +250,6 @@ program test_mpp_domains call test_uniform_mosaic('Cubic-Grid') ! 6 tiles. call test_nonuniform_mosaic('Five-Tile') - if(.not. wide_halo) then - call test_global_reduce( 'Simple') - call test_global_reduce( 'Simple symmetry center') - call test_global_reduce( 'Simple symmetry corner') - call test_global_reduce( 'Simple symmetry east') - call test_global_reduce( 'Simple symmetry north') - call test_global_reduce( 'Cyclic symmetry center') - call test_global_reduce( 'Cyclic symmetry corner') - call test_global_reduce( 'Cyclic symmetry east') - call test_global_reduce( 'Cyclic symmetry north') - endif call test_redistribute( 'Complete pelist' ) call test_redistribute( 'Overlap pelist' ) @@ -6057,112 +6046,6 @@ subroutine test_cyclic_offset( type ) end subroutine test_cyclic_offset - !--- test mpp_global_sum, mpp_global_min and mpp_global_max - subroutine test_global_reduce (type) - character(len=*), intent(in) :: type - real :: lsum, gsum, lmax, gmax, lmin, gmin - integer :: ni, nj, ishift, jshift, position - integer :: is, ie, js, je, isd, ied, jsd, jed - - type(domain2D) :: domain - real, allocatable, dimension(:,:,:) :: global1, x - real, allocatable, dimension(:,:) :: global2D - !--- set up domain - call mpp_define_layout( (/1,nx,1,ny/), npes, layout ) - select case(type) - case( 'Simple' ) - call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & - shalo=shalo, nhalo=nhalo, name=type ) - case( 'Simple symmetry center', 'Simple symmetry corner', 'Simple symmetry east', 'Simple symmetry north' ) - call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, & - shalo=shalo, nhalo=nhalo, name=type, symmetry = .true. ) - case( 'Cyclic symmetry center', 'Cyclic symmetry corner', 'Cyclic symmetry east', 'Cyclic symmetry north' ) - call mpp_define_domains( (/1,nx,1,ny/), layout, domain, whalo=whalo, ehalo=ehalo, shalo=shalo, nhalo=nhalo,& - name=type, symmetry = .true., xflags=CYCLIC_GLOBAL_DOMAIN, & - & yflags=CYCLIC_GLOBAL_DOMAIN ) - case default - call mpp_error( FATAL, 'TEST_MPP_DOMAINS: no such test: '//type//' in test_global_field' ) - end select - call mpp_get_compute_domain( domain, is, ie, js, je ) - call mpp_get_data_domain ( domain, isd, ied, jsd, jed ) - - !--- determine if an extra point is needed - ishift = 0; jshift = 0; position = CENTER - select case(type) - case ('Simple symmetry corner', 'Cyclic symmetry corner') - ishift = 1; jshift = 1; position = CORNER - case ('Simple symmetry east', 'Cyclic symmetry east' ) - ishift = 1; jshift = 0; position = EAST - case ('Simple symmetry north', 'Cyclic symmetry north') - ishift = 0; jshift = 1; position = NORTH - end select - - ie = ie+ishift; je = je+jshift - ied = ied+ishift; jed = jed+jshift - ni = nx+ishift; nj = ny+jshift - allocate(global1(1-whalo:ni+ehalo, 1-shalo:nj+nhalo, nz)) - global1 = 0.0 - do k = 1,nz - do j = 1,nj - do i = 1,ni - global1(i,j,k) = k + i*1e-3 + j*1e-6 - end do - end do - enddo - - !--- NOTE: even though the domain is cyclic, no need to apply cyclic condition on the global data - - allocate( x (isd:ied,jsd:jed,nz) ) - allocate( global2D(ni,nj)) - - x(:,:,:) = global1(isd:ied,jsd:jed,:) - do j = 1, nj - do i = 1, ni - global2D(i,j) = sum(global1(i,j,:)) - enddo - enddo - !test mpp_global_sum - - if(type(1:6) == 'Simple') then - gsum = sum( global2D(1:ni,1:nj) ) - else - gsum = sum( global2D(1:nx, 1:ny) ) - endif - id = mpp_clock_id( type//' sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lsum = mpp_global_sum( domain, x, position = position ) - call mpp_clock_end (id) - if( pe.EQ.mpp_root_pe() )print '(a,2es15.8,a,es12.4)', type//' Fast sum=', lsum, gsum - - !test exact mpp_global_sum - id = mpp_clock_id( type//' exact sum', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lsum = mpp_global_sum( domain, x, BITWISE_EXACT_SUM, position = position ) - call mpp_clock_end (id) - !--- The following check will fail on altix in normal mode, but it is ok - !--- in debugging mode. It is ok on irix. - call compare_data_scalar(lsum, gsum, FATAL, type//' mpp_global_exact_sum') - - !test mpp_global_min - gmin = minval(global1(1:ni, 1:nj, :)) - id = mpp_clock_id( type//' min', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lmin = mpp_global_min( domain, x, position = position ) - call mpp_clock_end (id) - call compare_data_scalar(lmin, gmin, FATAL, type//' mpp_global_min') - - !test mpp_global_max - gmax = maxval(global1(1:ni, 1:nj, :)) - id = mpp_clock_id( type//' max', flags=MPP_CLOCK_SYNC+MPP_CLOCK_DETAILED ) - call mpp_clock_begin(id) - lmax = mpp_global_max( domain, x, position = position ) - call mpp_clock_end (id) - call compare_data_scalar(lmax, gmax, FATAL, type//' mpp_global_max' ) - - deallocate(global1, x) - - end subroutine test_global_reduce - subroutine test_parallel_2D ( ) integer :: npes, layout(2), i, j, k,is, ie, js, je, isd, ied, jsd, jed diff --git a/test_fms/mpp/test_mpp_gatscat.F90 b/test_fms/mpp/test_mpp_gatscat.F90 index 47ff6cf81c..d5709b91c7 100644 --- a/test_fms/mpp/test_mpp_gatscat.F90 +++ b/test_fms/mpp/test_mpp_gatscat.F90 @@ -34,7 +34,6 @@ program test_mpp_gatscat use mpp_mod, only : mpp_sync use mpp_mod, only : mpp_declare_pelist, mpp_set_current_pelist, mpp_set_stack_size use mpp_mod, only : mpp_gather, mpp_scatter, mpp_error, FATAL - use mpp_io_mod, only: mpp_io_init, mpp_flush use mpp_mod, only : mpp_init_test_requests_allocated use platform_mod @@ -59,7 +58,6 @@ program test_mpp_gatscat integer :: ierr call mpp_init(mpp_init_test_requests_allocated) - call mpp_io_init() call mpp_set_stack_size(3145746) pe = mpp_pe() npes = mpp_npes() diff --git a/test_fms/mpp/test_mpp_global_sum_ad.F90 b/test_fms/mpp/test_mpp_global_sum_ad.F90 index 696d732d40..c50f9a060e 100644 --- a/test_fms/mpp/test_mpp_global_sum_ad.F90 +++ b/test_fms/mpp/test_mpp_global_sum_ad.F90 @@ -38,7 +38,6 @@ program test_mpp_global_sum_ad use mpp_domains_mod, only : mpp_define_layout, mpp_define_domains use mpp_domains_mod, only : NORTH, EAST, CORNER, CENTER use mpp_domains_mod, only : mpp_global_sum_ad - use mpp_io_mod, only : mpp_io_init use platform_mod @@ -51,7 +50,6 @@ program test_mpp_global_sum_ad call mpp_init(test_level=mpp_init_test_requests_allocated) call mpp_domains_init(MPP_DEBUG) - call mpp_io_init() call mpp_domains_set_stack_size(stackmax) pe = mpp_pe() diff --git a/test_fms/mpp/test_mpp_nesting.F90 b/test_fms/mpp/test_mpp_nesting.F90 index d086992c4b..833c580bf5 100644 --- a/test_fms/mpp/test_mpp_nesting.F90 +++ b/test_fms/mpp/test_mpp_nesting.F90 @@ -19,7 +19,9 @@ !> Tests nested domain operations and routines in mpp_domains program test_mpp_nesting - use fms + use fms_mod + use mpp_domains_mod + use mpp_mod use compare_data_checksums use test_domains_utility_mod use platform_mod @@ -1406,10 +1408,10 @@ subroutine test_update_nest_domain_r8( type ) if( isw_f .NE. isw_f2 .OR. iew_f .NE. iew_f2 .OR. jsw_f .NE. jsw_f2 .OR. jew_f .NE. jew_f2 .OR. & isw_c .NE. isw_c2 .OR. iew_c .NE. iew_c2 .OR. jsw_c .NE. jsw_c2 .OR. jew_c .NE. jew_c2 ) then - write(5000+mpp_pe(),*), "west buffer fine index = ", isw_f, iew_f, jsw_f, jew_f - write(5000+mpp_pe(),*), "west buffer fine index2 = ", isw_f2, iew_f2, jsw_f2, jew_f2 - write(5000+mpp_pe(),*), "west buffer coarse index = ", isw_c, iew_c, jsw_c, jew_c - write(5000+mpp_pe(),*), "west buffer coarse index2 = ", isw_c2, iew_c2, jsw_c2, jew_c2 + write(5000+mpp_pe(),*) "west buffer fine index = ", isw_f, iew_f, jsw_f, jew_f + write(5000+mpp_pe(),*) "west buffer fine index2 = ", isw_f2, iew_f2, jsw_f2, jew_f2 + write(5000+mpp_pe(),*) "west buffer coarse index = ", isw_c, iew_c, jsw_c, jew_c + write(5000+mpp_pe(),*) "west buffer coarse index2 = ", isw_c2, iew_c2, jsw_c2, jew_c2 call mpp_error(FATAL, "test_mpp_domains: west buffer index mismatch for coarse to fine scalar") endif if( ise_f .NE. ise_f2 .OR. iee_f .NE. iee_f2 .OR. jse_f .NE. jse_f2 .OR. jee_f .NE. jee_f2 .OR. & @@ -3433,10 +3435,10 @@ subroutine test_update_nest_domain_r4( type ) if( isw_f .NE. isw_f2 .OR. iew_f .NE. iew_f2 .OR. jsw_f .NE. jsw_f2 .OR. jew_f .NE. jew_f2 .OR. & isw_c .NE. isw_c2 .OR. iew_c .NE. iew_c2 .OR. jsw_c .NE. jsw_c2 .OR. jew_c .NE. jew_c2 ) then - write(5000+mpp_pe(),*), "west buffer fine index = ", isw_f, iew_f, jsw_f, jew_f - write(5000+mpp_pe(),*), "west buffer fine index2 = ", isw_f2, iew_f2, jsw_f2, jew_f2 - write(5000+mpp_pe(),*), "west buffer coarse index = ", isw_c, iew_c, jsw_c, jew_c - write(5000+mpp_pe(),*), "west buffer coarse index2 = ", isw_c2, iew_c2, jsw_c2, jew_c2 + write(5000+mpp_pe(),*) "west buffer fine index = ", isw_f, iew_f, jsw_f, jew_f + write(5000+mpp_pe(),*) "west buffer fine index2 = ", isw_f2, iew_f2, jsw_f2, jew_f2 + write(5000+mpp_pe(),*) "west buffer coarse index = ", isw_c, iew_c, jsw_c, jew_c + write(5000+mpp_pe(),*) "west buffer coarse index2 = ", isw_c2, iew_c2, jsw_c2, jew_c2 call mpp_error(FATAL, "test_mpp_domains: west buffer index mismatch for coarse to fine scalar") endif if( ise_f .NE. ise_f2 .OR. iee_f .NE. iee_f2 .OR. jse_f .NE. jse_f2 .OR. jee_f .NE. jee_f2 .OR. & diff --git a/test_fms/mpp/test_mpp_sendrecv.F90 b/test_fms/mpp/test_mpp_sendrecv.F90 index d6c315994e..5f82683e14 100644 --- a/test_fms/mpp/test_mpp_sendrecv.F90 +++ b/test_fms/mpp/test_mpp_sendrecv.F90 @@ -34,7 +34,6 @@ program test_mpp_sendrecv use mpp_mod, only : mpp_sync use mpp_mod, only : mpp_declare_pelist, mpp_set_current_pelist, mpp_set_stack_size use mpp_mod, only : mpp_send, mpp_recv, mpp_error, FATAL - use mpp_io_mod, only: mpp_io_init, mpp_flush use mpp_mod, only : mpp_init_test_requests_allocated use platform_mod @@ -59,7 +58,6 @@ program test_mpp_sendrecv integer :: ierr call mpp_init(mpp_init_test_requests_allocated) - call mpp_io_init() call mpp_set_stack_size(3145746) pe = mpp_pe() npes = mpp_npes() diff --git a/test_fms/mpp/test_mpp_update_domains_ad.F90 b/test_fms/mpp/test_mpp_update_domains_ad.F90 index 07739e8e65..aeaf253528 100644 --- a/test_fms/mpp/test_mpp_update_domains_ad.F90 +++ b/test_fms/mpp/test_mpp_update_domains_ad.F90 @@ -33,7 +33,6 @@ program test_mpp_update_domains_ad use mpp_domains_mod, only : mpp_update_domains, mpp_update_domains_ad, mpp_check_field use mpp_domains_mod, only : mpp_define_layout, mpp_define_domains, mpp_modify_domain use mpp_domains_mod, only : mpp_get_global_domain - use mpp_io_mod, only : mpp_io_init use platform_mod, only : r4_kind, r8_kind implicit none @@ -48,7 +47,6 @@ program test_mpp_update_domains_ad !> Initialize mpp and mpp IO modules call mpp_init(test_level=mpp_init_test_requests_allocated) call mpp_domains_init(MPP_DOMAIN_TIME) - call mpp_io_init() call mpp_domains_set_stack_size(stackmax) pe = mpp_pe() npes = mpp_npes() diff --git a/test_fms/mpp/test_mpp_update_domains_int.F90 b/test_fms/mpp/test_mpp_update_domains_int.F90 index 611894af3f..11e3e80aa6 100644 --- a/test_fms/mpp/test_mpp_update_domains_int.F90 +++ b/test_fms/mpp/test_mpp_update_domains_int.F90 @@ -47,7 +47,6 @@ module test_mpp_update_domains_int use mpp_domains_mod, only : SOUTH, SOUTH_WEST, WEST, NORTH_WEST, mpp_define_mosaic_pelist use mpp_domains_mod, only : mpp_get_global_domain, ZERO, NINETY, MINUS_NINETY use mpp_domains_mod, only : mpp_deallocate_domain - use mpp_io_mod, only: mpp_io_init use platform_mod, only: i4_kind, i8_kind implicit none diff --git a/test_fms/mpp/test_mpp_update_domains_main.F90 b/test_fms/mpp/test_mpp_update_domains_main.F90 index 0eb5223df1..c1c094fbc9 100644 --- a/test_fms/mpp/test_mpp_update_domains_main.F90 +++ b/test_fms/mpp/test_mpp_update_domains_main.F90 @@ -31,7 +31,6 @@ program test_mpp_update_domains_main use mpp_mod, only : mpp_init_test_requests_allocated use mpp_domains_mod, only : MPP_DOMAIN_TIME, mpp_domains_set_stack_size use mpp_domains_mod, only : mpp_domains_init, mpp_domains_exit - use mpp_io_mod, only: mpp_io_init use platform_mod implicit none @@ -41,7 +40,6 @@ program test_mpp_update_domains_main !> Initialize mpp and mpp IO modules call mpp_init(test_level=mpp_init_test_requests_allocated) call mpp_domains_init(MPP_DOMAIN_TIME) - call mpp_io_init() call mpp_domains_set_stack_size(stackmax) !> run the tests !> run the tests diff --git a/test_fms/mpp/test_update_domains_performance.F90 b/test_fms/mpp/test_update_domains_performance.F90 index 32bfcdd121..a0a81443e2 100644 --- a/test_fms/mpp/test_update_domains_performance.F90 +++ b/test_fms/mpp/test_update_domains_performance.F90 @@ -38,7 +38,6 @@ program test_update_domains_performance use mpp_domains_mod, only : NORTH, SOUTH, WEST, EAST, CENTER use mpp_domains_mod, only : mpp_get_global_domain, ZERO use mpp_domains_mod, only : mpp_start_update_domains, mpp_complete_update_domains - use mpp_io_mod, only: mpp_io_init use platform_mod implicit none @@ -65,7 +64,6 @@ program test_update_domains_performance logical :: mix_2D_3D = .false. !> Initialize mpp and mpp IO modules call mpp_init(test_level=mpp_init_test_requests_allocated) - call mpp_io_init() call mpp_domains_init(MPP_DOMAIN_TIME) call mpp_domains_set_stack_size(stackmax) pe = mpp_pe() diff --git a/test_fms/mpp_io/Makefile.am b/test_fms/mpp_io/Makefile.am index af5ec8d488..2357549cfa 100644 --- a/test_fms/mpp_io/Makefile.am +++ b/test_fms/mpp_io/Makefile.am @@ -38,6 +38,10 @@ test_mpp_io_SOURCES = test_mpp_io.F90 test_io_R4_R8_SOURCES = test_io_R4_R8.F90 test_io_mosaic_R4_R8_SOURCES = test_io_mosaic_R4_R8.F90 +if SKIP_DEPRECATED_IO_TESTS +TESTS_ENVIRONMENT= SKIP_TESTS="test_mpp_io2.1 test_io_R4_R8.1 test_io_mosaic_R4_R8.1" +endif + # Run the test program. TESTS = test_mpp_io2.sh \ test_io_R4_R8.sh \ diff --git a/test_fms/mpp_io/test_io_R4_R8.F90 b/test_fms/mpp_io/test_io_R4_R8.F90 index 49c17e0b4d..37282cf970 100644 --- a/test_fms/mpp_io/test_io_R4_R8.F90 +++ b/test_fms/mpp_io/test_io_R4_R8.F90 @@ -22,6 +22,7 @@ !> @description Tests mpp_write and mpp_read for reads/writes !> with mixed precision reals on non-mosaic files program test_io_R4_R8 +#ifdef use_deprecated_io use platform_mod, only : r4_kind, r8_kind, i8_kind use mpp_mod, only : mpp_init, mpp_pe, mpp_npes, mpp_root_pe, mpp_error, mpp_sync_self @@ -513,5 +514,5 @@ subroutine test_netcdf_io_R8(type) deallocate( rdata8, gdata8, data8) end subroutine test_netcdf_io_R8 - +#endif end program test_io_R4_R8 diff --git a/test_fms/mpp_io/test_io_mosaic_R4_R8.F90 b/test_fms/mpp_io/test_io_mosaic_R4_R8.F90 index 8360bd2523..b76dac7f77 100644 --- a/test_fms/mpp_io/test_io_mosaic_R4_R8.F90 +++ b/test_fms/mpp_io/test_io_mosaic_R4_R8.F90 @@ -23,6 +23,7 @@ !> @description Performs reads and writes on mosaic files using mpp_write !> and mpp_read using 32 and 64 bit reals program test_io_mosaic_R4_R8 +#ifdef use_deprecated_io use platform_mod use mpp_mod, only : mpp_init, mpp_pe, mpp_npes, mpp_root_pe, mpp_error, mpp_sync_self @@ -413,5 +414,5 @@ subroutine test_netcdf_io_mosaic_R8(type, layout, ntiles_x, ntiles_y, io_layout) call mpp_deallocate_domain(domain) end subroutine test_netcdf_io_mosaic_R8 - +#endif end program test_io_mosaic_R4_R8 diff --git a/test_fms/mpp_io/test_mpp_io.F90 b/test_fms/mpp_io/test_mpp_io.F90 index 907d45600b..46cefef2d7 100644 --- a/test_fms/mpp_io/test_mpp_io.F90 +++ b/test_fms/mpp_io/test_mpp_io.F90 @@ -17,7 +17,7 @@ !* License along with FMS. If not, see . !*********************************************************************** program test - +#ifdef use_deprecated_io use platform_mod, only : i8_kind, r8_kind use mpp_mod, only : mpp_init, mpp_pe, mpp_npes, mpp_root_pe, mpp_error, mpp_sync_self use mpp_mod, only : FATAL, NOTE, mpp_chksum, MPP_DEBUG, mpp_set_stack_size, MPP_CLOCK_SYNC @@ -565,5 +565,5 @@ subroutine test_netcdf_io_mosaic(type, layout, ntiles_x, ntiles_y, io_layout) call mpp_deallocate_domain(domain) end subroutine test_netcdf_io_mosaic - +#endif end program test diff --git a/test_fms/parser/parser_demo.F90 b/test_fms/parser/parser_demo.F90 index 16bc1c81ac..5b4ccfd88e 100644 --- a/test_fms/parser/parser_demo.F90 +++ b/test_fms/parser/parser_demo.F90 @@ -115,5 +115,4 @@ program parser_demo deallocate(file_ids) #endif - end program parser_demo diff --git a/test_fms/test-lib.sh.in b/test_fms/test-lib.sh.in index a2cfe8ebf8..b983b48d84 100644 --- a/test_fms/test-lib.sh.in +++ b/test_fms/test-lib.sh.in @@ -33,11 +33,6 @@ TEST_NAME="$(basename "$0" .sh)" TEST_NUMBER="${TEST_NAME%%-*}" TEST_NUMBER="${TEST_NUMBER#t}" -# if using intel with a limited stack size, sets to run smaller tests -if [ "$($FC --version | grep ifort)" -a "$(ulimit -s)" != "unlimited" 2> /dev/null ]; then - STACK_LIMITED=1 -fi - exec 7>&2 # For now, write all output #if test -n "$VERBOSE" diff --git a/time_interp/include/time_interp_external.inc b/time_interp/include/time_interp_external.inc index c25f694dea..7c446f4c52 100644 --- a/time_interp/include/time_interp_external.inc +++ b/time_interp/include/time_interp_external.inc @@ -32,6 +32,7 @@ !> @addtogroup time_interp_external_mod !> @{ module time_interp_external_mod +#ifdef use_deprecated_io #include ! !M.J. Harrison @@ -1417,7 +1418,7 @@ end subroutine end subroutine time_interp_external_exit ! NAME="time_interp_external_exit" - +#endif end module time_interp_external_mod !> @} ! close documentation grouping diff --git a/time_interp/include/time_interp_external2.inc b/time_interp/include/time_interp_external2.inc index fbe2f9e6f1..7716e17ea4 100644 --- a/time_interp/include/time_interp_external2.inc +++ b/time_interp/include/time_interp_external2.inc @@ -408,15 +408,6 @@ module time_interp_external2_mod init_external_field = -1 nfields_orig = num_fields - tavg = -1.0 - tstart = tstamp - tend = tstamp - if(variable_att_exists(fileobj, fieldname, 'time_avg_info')) then - if(variable_exists(fileobj, 'average_T1')) call read_data(fileobj, 'average_T1', tstart) - if(variable_exists(fileobj, 'average_T2')) call read_data(fileobj, 'average_T2', tend) - if(variable_exists(fileobj, 'average_DT')) call read_data(fileobj, 'average_DT', tavg) - endif - if (.not. variable_exists(fileobj, fieldname) ) then if (present(ierr)) then ierr = ERR_FIELD_NOT_FOUND @@ -426,6 +417,15 @@ module time_interp_external2_mod endif endif + tavg = -1.0 + tstart = tstamp + tend = tstamp + if(variable_att_exists(fileobj, fieldname, 'time_avg_info')) then + if(variable_exists(fileobj, 'average_T1')) call read_data(fileobj, 'average_T1', tstart) + if(variable_exists(fileobj, 'average_T2')) call read_data(fileobj, 'average_T2', tend) + if(variable_exists(fileobj, 'average_DT')) call read_data(fileobj, 'average_DT', tavg) + endif + num_fields = num_fields + 1 if(num_fields > max_fields) then !--- z1l: For the case of multiple thread, realoc_fields will cause memory leak. diff --git a/time_interp/time_interp_external.F90 b/time_interp/time_interp_external.F90 index c25f694dea..7c446f4c52 100644 --- a/time_interp/time_interp_external.F90 +++ b/time_interp/time_interp_external.F90 @@ -32,6 +32,7 @@ !> @addtogroup time_interp_external_mod !> @{ module time_interp_external_mod +#ifdef use_deprecated_io #include ! !M.J. Harrison @@ -1417,7 +1418,7 @@ subroutine time_interp_external_exit() end subroutine time_interp_external_exit ! NAME="time_interp_external_exit" - +#endif end module time_interp_external_mod !> @} ! close documentation grouping diff --git a/time_interp/time_interp_external2.F90 b/time_interp/time_interp_external2.F90 index fbe2f9e6f1..7716e17ea4 100644 --- a/time_interp/time_interp_external2.F90 +++ b/time_interp/time_interp_external2.F90 @@ -408,15 +408,6 @@ function init_external_field(file,fieldname,domain,desired_units,& init_external_field = -1 nfields_orig = num_fields - tavg = -1.0 - tstart = tstamp - tend = tstamp - if(variable_att_exists(fileobj, fieldname, 'time_avg_info')) then - if(variable_exists(fileobj, 'average_T1')) call read_data(fileobj, 'average_T1', tstart) - if(variable_exists(fileobj, 'average_T2')) call read_data(fileobj, 'average_T2', tend) - if(variable_exists(fileobj, 'average_DT')) call read_data(fileobj, 'average_DT', tavg) - endif - if (.not. variable_exists(fileobj, fieldname) ) then if (present(ierr)) then ierr = ERR_FIELD_NOT_FOUND @@ -426,6 +417,15 @@ function init_external_field(file,fieldname,domain,desired_units,& endif endif + tavg = -1.0 + tstart = tstamp + tend = tstamp + if(variable_att_exists(fileobj, fieldname, 'time_avg_info')) then + if(variable_exists(fileobj, 'average_T1')) call read_data(fileobj, 'average_T1', tstart) + if(variable_exists(fileobj, 'average_T2')) call read_data(fileobj, 'average_T2', tend) + if(variable_exists(fileobj, 'average_DT')) call read_data(fileobj, 'average_DT', tavg) + endif + num_fields = num_fields + 1 if(num_fields > max_fields) then !--- z1l: For the case of multiple thread, realoc_fields will cause memory leak. From 313d03213ab0a619788fd693675b6402bb7a079c Mon Sep 17 00:00:00 2001 From: mlee03 Date: Wed, 19 Jul 2023 11:29:50 -0400 Subject: [PATCH 43/51] spaces --- diag_manager/Makefile.am | 66 +++++++++++++++++------------------ fms/Makefile.am | 74 ++++++++++++++++++++-------------------- 2 files changed, 70 insertions(+), 70 deletions(-) diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 7de8a5e753..13ea77d8b7 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -31,57 +31,57 @@ noinst_LTLIBRARIES = libdiag_manager.la # Each convenience library depends on its source. libdiag_manager_la_SOURCES = \ - diag_axis.F90 \ - diag_data.F90 \ - diag_grid.F90 \ - diag_manager.F90 \ - diag_output.F90 \ - diag_table.F90 \ - diag_util.F90 \ - fms_diag_time_reduction.F90 \ - fms_diag_outfield.F90 \ - fms_diag_elem_weight_procs.F90 \ - fms_diag_fieldbuff_update.F90 \ + diag_axis.F90 \ + diag_data.F90 \ + diag_grid.F90 \ + diag_manager.F90 \ + diag_output.F90 \ + diag_table.F90 \ + diag_util.F90 \ + fms_diag_time_reduction.F90 \ + fms_diag_outfield.F90 \ + fms_diag_elem_weight_procs.F90 \ + fms_diag_fieldbuff_update.F90 \ fms_diag_bbox.F90 \ - include/fms_diag_fieldbuff_update.inc \ - include/fms_diag_fieldbuff_update.fh + include/fms_diag_fieldbuff_update.inc \ + include/fms_diag_fieldbuff_update.fh # Some mods are dependant on other mods in this dir. diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) \ - diag_grid_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) + diag_grid_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ - fms_diag_outfield_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ - fms_diag_bbox_mod.$(FC_MODEXT) + fms_diag_outfield_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ + fms_diag_bbox_mod.$(FC_MODEXT) diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ - diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ - fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ - fms_diag_fieldbuff_update_mod.$(FC_MODEXT) + diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ + fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_fieldbuff_update_mod.$(FC_MODEXT) # Mod files are built and then installed as headers. MODFILES = \ - diag_data_mod.$(FC_MODEXT) \ - diag_axis_mod.$(FC_MODEXT) \ - diag_grid_mod.$(FC_MODEXT) \ - diag_output_mod.$(FC_MODEXT) \ - diag_util_mod.$(FC_MODEXT) \ - diag_table_mod.$(FC_MODEXT) \ - fms_diag_time_reduction_mod.$(FC_MODEXT) \ - fms_diag_outfield_mod.$(FC_MODEXT) \ - fms_diag_bbox_mod.$(FC_MODEXT) \ - fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ - fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \ - diag_manager_mod.$(FC_MODEXT) \ - include/fms_diag_fieldbuff_update.inc \ - include/fms_diag_fieldbuff_update.fh + diag_data_mod.$(FC_MODEXT) \ + diag_axis_mod.$(FC_MODEXT) \ + diag_grid_mod.$(FC_MODEXT) \ + diag_output_mod.$(FC_MODEXT) \ + diag_util_mod.$(FC_MODEXT) \ + diag_table_mod.$(FC_MODEXT) \ + fms_diag_time_reduction_mod.$(FC_MODEXT) \ + fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_bbox_mod.$(FC_MODEXT) \ + fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ + fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \ + diag_manager_mod.$(FC_MODEXT) \ + include/fms_diag_fieldbuff_update.inc \ + include/fms_diag_fieldbuff_update.fh nodist_include_HEADERS = $(MODFILES) BUILT_SOURCES = $(MODFILES) diff --git a/fms/Makefile.am b/fms/Makefile.am index 84e2287b24..ca8b107941 100644 --- a/fms/Makefile.am +++ b/fms/Makefile.am @@ -31,50 +31,50 @@ noinst_LTLIBRARIES = libfms.la # Each convenience library depends on its source. libfms_la_SOURCES = \ - fms.F90 \ - fms_stacksize.c \ - include/fms.inc \ - include/fms_r4.fh \ - include/fms_r8.fh \ - fms_io.F90 \ - fms_io_unstructured_field_exist.inc \ - fms_io_unstructured_get_file_name.inc \ - fms_io_unstructured_register_restart_axis.inc \ - fms_io_unstructured_setup_one_field.inc read_data_4d.inc \ - fms_io_unstructured_file_unit.inc \ - fms_io_unstructured_get_file_unit.inc \ - fms_io_unstructured_register_restart_field.inc \ - read_data_2d.inc \ - write_data.inc \ - fms_io_unstructured_get_field_size.inc \ - fms_io_unstructured_read.inc \ - fms_io_unstructured_save_restart.inc \ - read_data_3d.inc + fms.F90 \ + fms_stacksize.c \ + include/fms.inc \ + include/fms_r4.fh \ + include/fms_r8.fh \ + fms_io.F90 \ + fms_io_unstructured_field_exist.inc \ + fms_io_unstructured_get_file_name.inc \ + fms_io_unstructured_register_restart_axis.inc \ + fms_io_unstructured_setup_one_field.inc read_data_4d.inc \ + fms_io_unstructured_file_unit.inc \ + fms_io_unstructured_get_file_unit.inc \ + fms_io_unstructured_register_restart_field.inc \ + read_data_2d.inc \ + write_data.inc \ + fms_io_unstructured_get_field_size.inc \ + fms_io_unstructured_read.inc \ + fms_io_unstructured_save_restart.inc \ + read_data_3d.inc fms_mod.$(FC_MODEXT): fms_io_mod.$(FC_MODEXT) \ - fms.F90 \ - include/fms.inc \ - include/fms_r4.fh \ - include/fms_r8.fh + fms.F90 \ + include/fms.inc \ + include/fms_r4.fh \ + include/fms_r8.fh fms_io_mod.$(FC_MODEXT): fms_io_unstructured_field_exist.inc \ - fms_io_unstructured_get_file_name.inc \ - fms_io_unstructured_register_restart_axis.inc \ - fms_io_unstructured_setup_one_field.inc read_data_4d.inc \ - fms_io_unstructured_file_unit.inc \ - fms_io_unstructured_get_file_unit.inc \ - fms_io_unstructured_register_restart_field.inc \ - read_data_2d.inc \ - write_data.inc \ - fms_io_unstructured_get_field_size.inc \ - fms_io_unstructured_read.inc \ - fms_io_unstructured_save_restart.inc \ - read_data_3d.inc + fms_io_unstructured_get_file_name.inc \ + fms_io_unstructured_register_restart_axis.inc \ + fms_io_unstructured_setup_one_field.inc read_data_4d.inc \ + fms_io_unstructured_file_unit.inc \ + fms_io_unstructured_get_file_unit.inc \ + fms_io_unstructured_register_restart_field.inc \ + read_data_2d.inc \ + write_data.inc \ + fms_io_unstructured_get_field_size.inc \ + fms_io_unstructured_read.inc \ + fms_io_unstructured_save_restart.inc \ + read_data_3d.inc # Mod files are built and then installed as headers. MODFILES = \ - fms_io_mod.$(FC_MODEXT) \ - fms_mod.$(FC_MODEXT) + fms_io_mod.$(FC_MODEXT) \ + fms_mod.$(FC_MODEXT) BUILT_SOURCES = $(MODFILES) nodist_include_HEADERS = $(MODFILES) $(FMS_INC_FILES) From 18fb8720d8d12ae79eb2dbde5f34f3ce3641b642 Mon Sep 17 00:00:00 2001 From: mlee03 Date: Wed, 19 Jul 2023 11:54:10 -0400 Subject: [PATCH 44/51] fix configure.ac --- configure.ac | 1 + 1 file changed, 1 insertion(+) diff --git a/configure.ac b/configure.ac index a2a9729a01..82588b6c84 100644 --- a/configure.ac +++ b/configure.ac @@ -441,6 +441,7 @@ AC_CONFIG_FILES([ time_interp/Makefile time_manager/Makefile constants/Makefile + constants4/Makefile platform/Makefile fms/Makefile fms2_io/Makefile From 670e6beceea890f1ec2f56861df976b231a97720 Mon Sep 17 00:00:00 2001 From: mlee03 Date: Wed, 19 Jul 2023 11:55:17 -0400 Subject: [PATCH 45/51] one more update to configure.ac --- configure.ac | 1 - 1 file changed, 1 deletion(-) diff --git a/configure.ac b/configure.ac index 82588b6c84..a2a9729a01 100644 --- a/configure.ac +++ b/configure.ac @@ -441,7 +441,6 @@ AC_CONFIG_FILES([ time_interp/Makefile time_manager/Makefile constants/Makefile - constants4/Makefile platform/Makefile fms/Makefile fms2_io/Makefile From 59225277e222b650a13b1a17e25ccb3fbb1a8e41 Mon Sep 17 00:00:00 2001 From: mlee03 Date: Wed, 19 Jul 2023 12:27:56 -0400 Subject: [PATCH 46/51] constants4 --- Makefile.am | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile.am b/Makefile.am index 2b2a1e9dc8..ffb12344ea 100644 --- a/Makefile.am +++ b/Makefile.am @@ -38,6 +38,7 @@ SUBDIRS = \ tridiagonal \ mpp \ constants \ + constants4 \ memutils \ string_utils \ fms2_io \ From 39949fe78067f317b80cac77ef5d704ee13b486c Mon Sep 17 00:00:00 2001 From: mlee03 Date: Mon, 24 Jul 2023 14:03:50 -0400 Subject: [PATCH 47/51] constants4 debacle --- CMakeLists.txt | 2 ++ configure.ac | 1 + 2 files changed, 3 insertions(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index 204cb32bb1..270539cd4d 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -110,6 +110,8 @@ list(APPEND fms_fortran_src_files column_diagnostics/column_diagnostics.F90 constants/constants.F90 constants/fmsconstants.F90 + constants4/constantsr4.F90 + constants4/fmsconstantsr4.F90 coupler/atmos_ocean_fluxes.F90 coupler/coupler_types.F90 coupler/ensemble_manager.F90 diff --git a/configure.ac b/configure.ac index a2a9729a01..82588b6c84 100644 --- a/configure.ac +++ b/configure.ac @@ -441,6 +441,7 @@ AC_CONFIG_FILES([ time_interp/Makefile time_manager/Makefile constants/Makefile + constants4/Makefile platform/Makefile fms/Makefile fms2_io/Makefile From 4437240a2b6f1be6a49eaa451c4244a0aa65167b Mon Sep 17 00:00:00 2001 From: mlee03 Date: Wed, 26 Jul 2023 12:13:18 -0400 Subject: [PATCH 48/51] correct sat vap pres merge errors? --- sat_vapor_pres/sat_vapor_pres.F90 | 1 - sat_vapor_pres/sat_vapor_pres_k.F90 | 1 + test_fms/fms/test_fms.F90 | 1 + 3 files changed, 2 insertions(+), 1 deletion(-) diff --git a/sat_vapor_pres/sat_vapor_pres.F90 b/sat_vapor_pres/sat_vapor_pres.F90 index c860f46948..b5591e99d4 100644 --- a/sat_vapor_pres/sat_vapor_pres.F90 +++ b/sat_vapor_pres/sat_vapor_pres.F90 @@ -202,7 +202,6 @@ module sat_vapor_pres_mod !public :: compute_es public :: escomp, descomp ! for backward compatibility ! use lookup_es, lookup_des instead - public :: check_1d, check_2d, temp_check, show_all_bad !----------------------------------------------------------------------- diff --git a/sat_vapor_pres/sat_vapor_pres_k.F90 b/sat_vapor_pres/sat_vapor_pres_k.F90 index 0e0f1522d3..66f44549cc 100644 --- a/sat_vapor_pres/sat_vapor_pres_k.F90 +++ b/sat_vapor_pres/sat_vapor_pres_k.F90 @@ -47,6 +47,7 @@ module sat_vapor_pres_k_mod ! not be a fortran module. This complicates things greatly for questionable ! benefit and could be done as a second step anyway, if necessary. + use fms_mod, only: error_mesg, FATAL use platform_mod, only : r4_kind, r8_kind implicit none diff --git a/test_fms/fms/test_fms.F90 b/test_fms/fms/test_fms.F90 index faffd998eb..0827e3c91c 100644 --- a/test_fms/fms/test_fms.F90 +++ b/test_fms/fms/test_fms.F90 @@ -79,6 +79,7 @@ program test_fms contains + #include "test_fms_r4.fh" #include "test_fms_r8.fh" From db0dcca869920c55dd08b86e83330c096d0ccaa9 Mon Sep 17 00:00:00 2001 From: mlee03 Date: Wed, 26 Jul 2023 12:19:30 -0400 Subject: [PATCH 49/51] undo sat vap changes?! --- sat_vapor_pres/sat_vapor_pres.F90 | 1 + sat_vapor_pres/sat_vapor_pres_k.F90 | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/sat_vapor_pres/sat_vapor_pres.F90 b/sat_vapor_pres/sat_vapor_pres.F90 index b5591e99d4..c860f46948 100644 --- a/sat_vapor_pres/sat_vapor_pres.F90 +++ b/sat_vapor_pres/sat_vapor_pres.F90 @@ -202,6 +202,7 @@ module sat_vapor_pres_mod !public :: compute_es public :: escomp, descomp ! for backward compatibility ! use lookup_es, lookup_des instead + public :: check_1d, check_2d, temp_check, show_all_bad !----------------------------------------------------------------------- diff --git a/sat_vapor_pres/sat_vapor_pres_k.F90 b/sat_vapor_pres/sat_vapor_pres_k.F90 index 66f44549cc..0e0f1522d3 100644 --- a/sat_vapor_pres/sat_vapor_pres_k.F90 +++ b/sat_vapor_pres/sat_vapor_pres_k.F90 @@ -47,7 +47,6 @@ module sat_vapor_pres_k_mod ! not be a fortran module. This complicates things greatly for questionable ! benefit and could be done as a second step anyway, if necessary. - use fms_mod, only: error_mesg, FATAL use platform_mod, only : r4_kind, r8_kind implicit none From e3f08ece597aeaac2742f0ad399272c373ec0197 Mon Sep 17 00:00:00 2001 From: mlee03 Date: Wed, 26 Jul 2023 12:36:02 -0400 Subject: [PATCH 50/51] resolve merge conflict in axis_utils2 --- axis_utils/include/axis_utils2.inc | 4 ---- 1 file changed, 4 deletions(-) diff --git a/axis_utils/include/axis_utils2.inc b/axis_utils/include/axis_utils2.inc index 9734888d0c..3535e70df7 100644 --- a/axis_utils/include/axis_utils2.inc +++ b/axis_utils/include/axis_utils2.inc @@ -1,7 +1,3 @@ -<<<<<<< HEAD -======= - ->>>>>>> origin/main !*********************************************************************** !* GNU Lesser General Public License !* From ade3087ca8c333e42bc09c2879ba8caf84c4397e Mon Sep 17 00:00:00 2001 From: mlee03 Date: Wed, 26 Jul 2023 12:58:20 -0400 Subject: [PATCH 51/51] fix sat_vapor_pres merge weirdness --- sat_vapor_pres/sat_vapor_pres.F90 | 1 - sat_vapor_pres/sat_vapor_pres_k.F90 | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/sat_vapor_pres/sat_vapor_pres.F90 b/sat_vapor_pres/sat_vapor_pres.F90 index c860f46948..b5591e99d4 100644 --- a/sat_vapor_pres/sat_vapor_pres.F90 +++ b/sat_vapor_pres/sat_vapor_pres.F90 @@ -202,7 +202,6 @@ module sat_vapor_pres_mod !public :: compute_es public :: escomp, descomp ! for backward compatibility ! use lookup_es, lookup_des instead - public :: check_1d, check_2d, temp_check, show_all_bad !----------------------------------------------------------------------- diff --git a/sat_vapor_pres/sat_vapor_pres_k.F90 b/sat_vapor_pres/sat_vapor_pres_k.F90 index 0e0f1522d3..66f44549cc 100644 --- a/sat_vapor_pres/sat_vapor_pres_k.F90 +++ b/sat_vapor_pres/sat_vapor_pres_k.F90 @@ -47,6 +47,7 @@ module sat_vapor_pres_k_mod ! not be a fortran module. This complicates things greatly for questionable ! benefit and could be done as a second step anyway, if necessary. + use fms_mod, only: error_mesg, FATAL use platform_mod, only : r4_kind, r8_kind implicit none