diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 4421b72854..b9d65285a0 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -25,7 +25,7 @@ # These owners will be the default owners for all the files in the # repository. Unless a later match is found, these owners # will be requested for a review when a PR is opened. -* @thomas-robinson @bensonr @rem1776 +* @uramirez8707 @bensonr @rem1776 # GNU autotools files Makefile.am @uramirez8707 @rem1776 @@ -41,7 +41,7 @@ cmake @mlee03 /.github/ @rem1776 # Testing files -/test_fms/ @uramirez8707 @mlee03 @bensonr @thomas-robinson @rem1776 +/test_fms/ @uramirez8707 @mlee03 @bensonr @rem1776 # Specific component directories /affinity/ @bensonr @@ -53,15 +53,15 @@ cmake @mlee03 #/data_override/ Currently no code owner /test_fms/data_override/ @rem1776 -/diag_manager @thomas-robinson -/test_fms/diag_manager/ @thomas-robinson +/diag_manager @uramirez8707 +/test_fms/diag_manager/ @uramirez8707 -/fms/ @thomas-robinson @rem1776 -/test_fms/fms/ @thomas-robinson @rem1776 +/fms/ @uramirez8707 @rem1776 +/test_fms/fms/ @uramirez8707 @rem1776 /fms2/ @uramirez8707 /test_fms/fms2/ @uramirez8707 -/libFMS/ @thomas-robinson @rem1776 +/libFMS/ @uramirez8707 @rem1776 -/mpp/ @thomas-robinson @bensonr -/test_fms/mpp/ @thomas-robinson @bensonr @rem1776 +/mpp/ @uramirez8707 @bensonr +/test_fms/mpp/ @uramirez8707 @bensonr @rem1776 diff --git a/CMakeLists.txt b/CMakeLists.txt index 5082a98e0f..17db1a4620 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -168,9 +168,7 @@ list(APPEND fms_fortran_src_files memutils/memutils.F90 monin_obukhov/monin_obukhov_inter.F90 monin_obukhov/monin_obukhov.F90 - mosaic/gradient.F90 - mosaic/grid.F90 - mosaic/mosaic.F90 + grid_utils/gradient.F90 mosaic2/grid2.F90 mosaic2/mosaic2.F90 mpp/mpp.F90 @@ -205,11 +203,10 @@ list(APPEND fms_fortran_src_files list(APPEND fms_c_src_files affinity/affinity.c fms/fms_stacksize.c - mosaic/create_xgrid.c - mosaic/gradient_c2l.c - mosaic/interp.c - mosaic/mosaic_util.c - mosaic/read_mosaic.c + grid_utils/gradient_c2l.c + grid_utils/grid_utils.c + grid_utils/tree_utils.c + horiz_interp/include/horiz_interp_conserve_xgrid.c mpp/mpp_memuse.c parser/yaml_parser_binding.c parser/yaml_output_functions.c @@ -257,6 +254,8 @@ if(WITH_YAML) endif() if(USE_DEPRECATED_IO) + message( WARNING "fms_io WILL BE DEPRECATED IN A FUTURE RELEASE. PLEASE UPDATE TO USE FMS2_IO AND REMOVE " + "-DUSE_DEPRECATED_IO=on FROM YOUR OPTIONS") list(APPEND fms_defs use_deprecated_io) endif() @@ -298,7 +297,8 @@ foreach(kind ${kinds}) # C add_library(${libTgt}_c OBJECT ${fms_c_src_files}) - target_include_directories(${libTgt}_c PRIVATE include) + target_include_directories(${libTgt}_c PRIVATE include + grid_utils) target_compile_definitions(${libTgt}_c PRIVATE "${fms_defs}") target_link_libraries(${libTgt}_c PRIVATE NetCDF::NetCDF_C @@ -386,6 +386,7 @@ foreach(kind ${kinds}) $ $ $ + $ $ $ $ @@ -429,13 +430,13 @@ endforeach() install( TARGETS ${LIB_TARGETS} EXPORT FMSExports - RUNTIME DESTINATION bin - LIBRARY DESTINATION lib - ARCHIVE DESTINATION lib) + RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR} + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR}) ### Package config include(CMakePackageConfigHelpers) -set(CONFIG_INSTALL_DESTINATION lib/cmake/fms) +set(CONFIG_INSTALL_DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/fms) export(EXPORT FMSExports NAMESPACE FMS:: @@ -458,3 +459,34 @@ install(EXPORT FMSExports NAMESPACE FMS:: FILE fms-targets.cmake DESTINATION ${CONFIG_INSTALL_DESTINATION}) + +# pkgconf +set(prefix ${CMAKE_INSTALL_PREFIX}) +set(exec_prefix ${CMAKE_INSTALL_PREFIX}) +set(libdir ${CMAKE_INSTALL_PREFIX}/${CMAKE_INSTALL_LIBDIR}) +set(includedir ${CMAKE_INSTALL_PREFIX}/${includeDir}) + +set(CC ${CMAKE_C_COMPILER}) +set(FC ${CMAKE_Fortran_COMPILER}) +set(CFLAGS "${CMAKE_C_FLAGS} ${CMAKE_C_FLAGS_${CMAKE_BUILD_TYPE}}") +set(CPPFLAGS "${CMAKE_CPP_FLAGS} ${CMAKE_CPP_FLAGS_${CMAKE_BUILD_TYPE}}") +set(FCFLAGS "${CMAKE_Fortran_FLAGS} ${CMAKE_Fortran_FLAGS_${CMAKE_BUILD_TYPE}}") +set(LDFLAGS "${CMAKE_SHARED_LINKER_FLAGS} ${CMAKE_SHARED_LINKER_FLAGS_${CMAKE_BUILD_TYPE}}") + +set(VERSION ${PROJECT_VERSION}) + +# TODO: If FMS depends on a library that is built as a static library, it +# should be listed here as an ldflag. +set(LIBS "") + +if(NOT ${NetCDF_Fortran_LIBRARY_SHARED}) + # autotools: Libs.private: -lnetcdff -lnetcdf + string(APPEND LIBS ${NetCDF_Fortran_LIBRARIES}) +endif() + +configure_file(${CMAKE_CURRENT_SOURCE_DIR}/FMS.pc.in + ${CMAKE_CURRENT_BINARY_DIR}/FMS.pc @ONLY) + +install(FILES ${CMAKE_CURRENT_BINARY_DIR}/FMS.pc + DESTINATION ${CMAKE_INSTALL_LIBDIR}/pkgconfig + COMPONENT utilities) diff --git a/FMS.pc.in b/FMS.pc.in index bc993b5740..c9f2a96e5c 100644 --- a/FMS.pc.in +++ b/FMS.pc.in @@ -35,7 +35,7 @@ Name: FMS Description: The Flexible Modeling System Infrastructure Library URL: https://www.gfdl.noaa.gov/fms Version: @VERSION@ -Libs: -L$(libdir) -lFMS +Libs: -L${libdir} -lFMS Libs.private: @LIBS@ Cflags: -I${includedir} Fflags: -I${includedir} diff --git a/Makefile.am b/Makefile.am index b07346ea3e..c97869a75d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -47,7 +47,7 @@ SUBDIRS = \ parser \ string_utils \ affinity \ - mosaic \ + grid_utils \ time_manager \ axis_utils \ diag_manager \ @@ -147,4 +147,3 @@ install-data-hook: @echo '| please see our page: https://www.github.com/NOAA-GFDL/FMS |' @echo '+-------------------------------------------------------------+' @echo '' - diff --git a/block_control/block_control.F90 b/block_control/block_control.F90 index fd385e8266..f78e8659f3 100644 --- a/block_control/block_control.F90 +++ b/block_control/block_control.F90 @@ -23,8 +23,9 @@ module block_control_mod -use mpp_mod, only: mpp_error, NOTE, WARNING, FATAL +use mpp_mod, only: mpp_error, NOTE, WARNING, FATAL, mpp_sum, mpp_npes use mpp_domains_mod, only: mpp_compute_extent +use fms_string_utils_mod, only: string implicit none public block_control_type @@ -104,15 +105,19 @@ subroutine define_blocks (component, Block, isc, iec, jsc, jec, kpts, & integer, dimension(ny_block) :: j1, j2 character(len=256) :: text integer :: i, j, nblks, ix, ii, jj + integer :: non_uniform_blocks !< Number of non uniform blocks if (message) then + non_uniform_blocks = 0 if ((mod(iec-isc+1,nx_block) .ne. 0) .or. (mod(jec-jsc+1,ny_block) .ne. 0)) then - write( text,'(a,a,2i4,a,2i4,a)' ) trim(component),'define_blocks: domain (',& - (iec-isc+1), (jec-jsc+1),') is not an even divisor with definition (',& - nx_block, ny_block,') - blocks will not be uniform' - call mpp_error (WARNING, trim(text)) + non_uniform_blocks = 1 + endif + call mpp_sum(non_uniform_blocks) + if (non_uniform_blocks > 0 ) then + call mpp_error(NOTE, string(non_uniform_blocks)//" out of "//string(mpp_npes())//" total domains "//& + "have non-uniform blocks for block size ("//string(nx_block)//","//string(ny_block)//")") + message = .false. endif - message = .false. endif !--- set up blocks diff --git a/configure.ac b/configure.ac index e7dc02506e..7079b9c450 100644 --- a/configure.ac +++ b/configure.ac @@ -479,7 +479,7 @@ AC_CONFIG_FILES([ tridiagonal/Makefile tracer_manager/Makefile topography/Makefile - mosaic/Makefile + grid_utils/Makefile mosaic2/Makefile monin_obukhov/Makefile memutils/Makefile @@ -533,7 +533,12 @@ AC_CONFIG_FILES([ test_fms/random_numbers/Makefile test_fms/topography/Makefile test_fms/column_diagnostics/Makefile + test_fms/block_control/Makefile FMS.pc ]) AC_OUTPUT() + +if test $enable_deprecated_io = yes; then + AC_MSG_WARN(FMS_IO WILL BE DEPRECATED IN A FUTURE RLEASE. PLEASE UPDATE TO USE FMS2_IO AND REMOVE --enable-deprecated-io FROM YOUR CONFIGURE OPTIONS) +fi diff --git a/data_override/README.MD b/data_override/README.MD index b35879edf2..fd83965638 100644 --- a/data_override/README.MD +++ b/data_override/README.MD @@ -8,6 +8,7 @@ - [Converting legacy data_table to data_table.yaml](README.MD#3-converting-legacy-data_table-to-data_tableyaml) - [Examples](README.MD#4-examples) - [External Weight File Structure](README.MD#5-external-weight-file-structure) +- [Ensemble and Nest Support](README.MD#6-ensemble-and-nest-support) #### 1. YAML Data Table format: Each entry in the data_table has the following key values: @@ -200,3 +201,7 @@ variables: - weight(:,:,2) -> (i,j+1) - weight(:,:,3) -> (i+1,j) - weight(:,:,4) -> (i+1,j+1) + +#### 6. Ensemble and Nest Support + +It may be desired to have each member of an ensemble use a different forcing file. In other to support this, FMS allows for each ensemble member to have its own data_table.yaml. For example, for a run with 2 ensemble members, fms will search for data_table_ens_01.yaml and data_table_ens_02.yaml. However, if both the data_table.yaml and the data_table_ens_* files are present, the code will crash as only 1 option is allowed. Similary, each nest can have its own data_table (data_table_nest_01.yaml), but in this case FMS will not crash if both data_table_nest_01.yaml and data_table.yaml are present. The main grid will use the data_table.yaml and the first nest will use the data_table_nest_01.yaml file. \ No newline at end of file diff --git a/data_override/include/data_override.inc b/data_override/include/data_override.inc index d5cc939029..17360d0b85 100644 --- a/data_override/include/data_override.inc +++ b/data_override/include/data_override.inc @@ -21,7 +21,7 @@ ! modules. These modules are not intended to be used directly - they should be ! used through the data_override_mod API. See data_override.F90 for details. -use platform_mod, only: r4_kind, r8_kind, FMS_PATH_LEN +use platform_mod, only: r4_kind, r8_kind, FMS_PATH_LEN, FMS_FILE_LEN use yaml_parser_mod use constants_mod, only: DEG_TO_RAD use mpp_mod, only : mpp_error, FATAL, WARNING, NOTE, stdout, stdlog, mpp_max @@ -45,7 +45,7 @@ use mpp_domains_mod, only : domainUG, mpp_pass_SG_to_UG, mpp_get_UG_SG_domain, N use time_manager_mod, only: time_type, OPERATOR(>), OPERATOR(<) use fms2_io_mod, only : FmsNetcdfFile_t, open_file, close_file, & read_data, fms2_io_init, variable_exists, & - get_mosaic_tile_file, file_exists + get_mosaic_tile_file, file_exists, get_instance_filename use get_grid_version_mod, only: get_grid_version_1, get_grid_version_2 use fms_string_utils_mod, only: string @@ -591,9 +591,18 @@ subroutine read_table_yaml(data_table) integer :: nentries, mentries integer :: i character(len=50) :: buffer + character(len=FMS_FILE_LEN) :: filename !< Name of the expected data_table.yaml integer :: file_id - file_id = open_and_parse_file("data_table.yaml") + ! If doing and ensemble or nest run add the filename appendix (ens_XX or nest_XX) to the filename + call get_instance_filename("data_table.yaml", filename) + if (index(trim(filename), "ens_") .ne. 0) then + if (file_exists(filename) .and. file_exists("data_table.yaml")) & + call mpp_error(FATAL, "Both data_table.yaml and "//trim(filename)//" exists, pick one!") + endif + + file_id = open_and_parse_file(trim(filename)) + if (file_id==999) then nentries = 0 else diff --git a/diag_integral/diag_integral.F90 b/diag_integral/diag_integral.F90 index f4c2e75ab1..4bf39b8ebe 100644 --- a/diag_integral/diag_integral.F90 +++ b/diag_integral/diag_integral.F90 @@ -40,7 +40,7 @@ module diag_integral_mod fms_init, & mpp_pe, mpp_root_pe,& FATAL, write_version_number, & - stdlog + stdlog, string use fms2_io_mod, only: file_exists use constants_mod, only: radius, constants_init use mpp_mod, only: mpp_sum, mpp_init @@ -195,7 +195,6 @@ module diag_integral_mod !------------------------------------------------------------------------------- character(len=160) :: format_text !< format statement for header character(len=160) :: format_data !< format statement for data output -logical :: do_format_data = .true. !< a data format needs to be generated ? integer :: nd !< number of characters in data format statement integer :: nt !< number of characters in text format statement @@ -711,6 +710,8 @@ subroutine write_field_averages (Time) integer :: nn, ninc, nst, nend, fields_to_print integer :: i, kount integer(i8_kind) :: icount + character(len=128) :: xtime_str + logical :: use_exp_format !------------------------------------------------------------------------------- ! each header and data format may be different and must be generated @@ -764,6 +765,12 @@ subroutine write_field_averages (Time) !------------------------------------------------------------------------------- xtime = get_axis_time (Time-Time_init_save, time_units) +!------------------------------------------------------------------------------- +! check if the time value is too long for decimal output +!------------------------------------------------------------------------------- + xtime_str = trim(string(xtime)) + use_exp_format = len_trim(xtime_str(1:INDEX(xtime_str, "."))) .ge. 9 + !------------------------------------------------------------------------------- ! generate the new header and data formats. !------------------------------------------------------------------------------- @@ -774,7 +781,7 @@ subroutine write_field_averages (Time) nst = 1 + (nn-1)*fields_per_print_line nend = MIN (nn*fields_per_print_line, num_field) if (print_header) call format_text_init (nst, nend) - call format_data_init (nst, nend) + call format_data_init (nst, nend, use_exp_format) if (diag_unit /= 0) then write (diag_unit,format_data(1:nd)) & xtime, (field_avg(i),i=nst,nend) @@ -890,18 +897,22 @@ end subroutine format_text_init !! Parameters: !! !! @code{.f90} -!! integer, intent(in), optional :: nst_in, nend_in +!! integer, intent(in) :: nst_in, nend_in !! @endcode !! !! @param [in] starting/ending integral index which will be !! included in this format statement +!! @param [in] if true, uses exponent notation for the first format code +!! to avoid overflow with larger time values !! -subroutine format_data_init (nst_in, nend_in) +subroutine format_data_init (nst_in, nend_in, use_exp_format) -integer, intent(in), optional :: nst_in !< starting/ending integral index which will be +integer, intent(in) :: nst_in !< starting/ending integral index which will be !! included in this format statement -integer, intent(in), optional :: nend_in !< starting/ending integral index which will be +integer, intent(in) :: nend_in !< starting/ending integral index which will be !! included in this format statement +logical, intent(in) :: use_exp_format !< if true, uses exponent notation for the first format code + !! to avoid overflow with larger time values !------------------------------------------------------------------------------- ! local variables: @@ -917,19 +928,18 @@ subroutine format_data_init (nst_in, nend_in) ! integrals. this section is 9 characters long. !------------------------------------------------------------------------------- nd = 9 - format_data(1:nd) = '(1x,f10.2' + if( use_exp_format ) then + format_data(1:nd) = '(1x,e10.2' + else + format_data(1:nd) = '(1x,f10.2' + endif !------------------------------------------------------------------------------- ! define the indices of the integrals that are to be written by this ! format statement. !------------------------------------------------------------------------------- - if ( present (nst_in) ) then - nst = nst_in - nend = nend_in - else - nst = 1 - nend = num_field - endif + nst = nst_in + nend = nend_in !------------------------------------------------------------------------------- ! complete the data format. use the format defined for the @@ -937,8 +947,8 @@ subroutine format_data_init (nst_in, nend_in) !------------------------------------------------------------------------------- do i=nst,nend nc = len_trim(field_format(i)) - format_data(nd+1:nd+nc+5) = ',1x,' // field_format(i)(1:nc) - nd = nd+nc+5 + format_data(nd+1:nd+nc+4) = ',1x,' // field_format(i)(1:nc) + nd = nd+nc+4 end do !------------------------------------------------------------------------------- diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 0714cfe59f..d6078b653a 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1789,7 +1789,7 @@ LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, allocate(mask_remap(1:size(mask,1), 1:size(mask,2), 1:size(mask,3), 1)) mask_remap(:,:,:,1) = mask endif - diag_send_data = fms_diag_object%fms_diag_accept_data(diag_field_id, field_remap, mask_remap, rmask_remap, & + call fms_diag_object%fms_diag_accept_data(diag_field_id, field_remap, mask_remap, rmask_remap, & time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, & err_msg) deallocate (field_remap) @@ -3518,7 +3518,7 @@ LOGICAL FUNCTION send_data_4d(diag_field_id, field, time, is_in, js_in, ks_in, & if (present(mask)) mask_local = mask if (present(rmask)) rmask_local = rmask - send_data_4d = fms_diag_object%fms_diag_accept_data(diag_field_id, field, mask_local, rmask_local, & + call fms_diag_object%fms_diag_accept_data(diag_field_id, field, mask_local, rmask_local, & time, is_in, js_in, ks_in, ie_in, je_in, ke_in, weight, & err_msg) diff --git a/diag_manager/diag_yaml_format.md b/diag_manager/diag_yaml_format.md index d9e93c3593..b561445fdc 100644 --- a/diag_manager/diag_yaml_format.md +++ b/diag_manager/diag_yaml_format.md @@ -15,6 +15,7 @@ The purpose of this document is to explain the diag_table yaml format. - [2.6 Sub_region Section](diag_yaml_format.md#26-sub_region-section) - [3. More examples](diag_yaml_format.md#3-more-examples) - [4. Schema](diag_yaml_format.md#4-schema) +- [5. Ensemble and Nest Support](diag_yaml_format.md#5-ensemble-and-nest-support) ### 1. Converting from legacy ascii diag_table format @@ -349,3 +350,6 @@ diag_files: A formal specification of the file format, in the form of a JSON schema, can be found in the [gfdl_msd_schemas](https://github.com/NOAA-GFDL/gfdl_msd_schemas) repository on Github. + +### 5. Ensemble and Nest Support +When using nests, it may be desired for a nest to have a different file frequency or number of variables from the parent grid. This may allow users to save disk space and reduce simulations time. In order to supports, FMS allows each nest to have a different diag_table.yaml from the parent grid. For example, if running with 1 test FMS will use diag_table.yaml for the parent grid and diag_table.nest_01.yaml for the first nest Similary, each ensemble member can have its own diag_table (diag_table_ens_XX.yaml, where XX is the ensemble number). However, for the ensemble case if both the diag_table.yaml and the diag_table_ens_* files are present, the code will crash as only 1 option is allowed. \ No newline at end of file diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index c985a6c30d..7f8ad6d9ac 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -224,6 +224,7 @@ integer function fms_register_diag_field_obj & integer, allocatable :: file_ids(:) !< The file IDs for this variable integer :: i !< For do loops integer, allocatable :: diag_field_indices(:) !< indices where the field was found in the yaml + class(diagDomain_t), pointer :: null_diag_domain => NULL() !< Workaround for a Cray bug which will be fixed in CCE 19 #endif #ifndef use_yaml fms_register_diag_field_obj = DIAG_FIELD_NOT_FOUND @@ -267,7 +268,7 @@ integer function fms_register_diag_field_obj & call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i)) call fileptr%add_buffer_id(fieldptr%buffer_ids(i)) if(fieldptr%get_type_of_domain() .eq. NO_DOMAIN) then - call fileptr%set_file_domain(NULL(), fieldptr%get_type_of_domain()) + call fileptr%set_file_domain(null_diag_domain, fieldptr%get_type_of_domain()) else call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain()) endif @@ -284,7 +285,7 @@ integer function fms_register_diag_field_obj & call fileptr%add_buffer_id(fieldptr%buffer_ids(i)) call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i)) if(fieldptr%get_type_of_domain() .eq. NO_DOMAIN) then - call fileptr%set_file_domain(NULL(), fieldptr%get_type_of_domain()) + call fileptr%set_file_domain(null_diag_domain, fieldptr%get_type_of_domain()) else call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain()) endif @@ -536,7 +537,7 @@ end function fms_diag_axis_init !! multithreaded case. !! \note If some of the diag manager is offloaded in the future, then it should be treated similarly !! to the multi-threaded option for processing later -logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rmask, & +subroutine fms_diag_accept_data (this, diag_field_id, field_data, mask, rmask, & time, is_in, js_in, ks_in, & ie_in, je_in, ke_in, weight, err_msg) class(fmsDiagObject_type),TARGET, INTENT(inout) :: this !< Diaj_obj to fill @@ -680,8 +681,6 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm !$omp end critical call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data, oor_mask, field_weight, & is, js, ks, ie, je, ke) - fms_diag_accept_data = .TRUE. - return else !< At this point if we are no longer in an openmp region or running with 1 thread @@ -709,13 +708,10 @@ logical function fms_diag_accept_data (this, diag_field_id, field_data, mask, rm if(.not. this%FMS_diag_fields(diag_field_id)%has_mask_allocated()) & call this%FMS_diag_fields(diag_field_id)%allocate_mask(oor_mask) call this%FMS_diag_fields(diag_field_id)%set_mask(oor_mask, field_info) - return end if main_if !> Return false if nothing is done - fms_diag_accept_data = .FALSE. - return #endif -end function fms_diag_accept_data +end subroutine fms_diag_accept_data !< @brief Do the math for all the buffers subroutine do_buffer_math(this) diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 index a1c9b0b805..26f631414c 100644 --- a/diag_manager/fms_diag_yaml.F90 +++ b/diag_manager/fms_diag_yaml.F90 @@ -45,6 +45,7 @@ module fms_diag_yaml_mod fms_f2c_string use platform_mod, only: r4_kind, i4_kind, r8_kind, i8_kind, FMS_FILE_LEN use fms_mod, only: lowercase +use fms2_io_mod, only: file_exists, get_instance_filename implicit none @@ -381,10 +382,17 @@ subroutine diag_yaml_object_init(diag_subset_output) !! outputing data at every frequency) character(len=:), allocatable :: filename!< Diag file name (for error messages) logical :: is_instantaneous !< .True. if the file is instantaneous (i.e no averaging) + character(len=FMS_FILE_LEN) :: yamlfilename !< Name of the expected diag_table.yaml if (diag_yaml_module_initialized) return - diag_yaml_id = open_and_parse_file("diag_table.yaml") + ! If doing and ensemble or nest run add the filename appendix (ens_XX or nest_XX) to the filename + call get_instance_filename("diag_table.yaml", yamlfilename) + if (index(trim(yamlfilename), "ens_") .ne. 0) then + if (file_exists(yamlfilename) .and. file_exists("diag_table.yaml")) & + call mpp_error(FATAL, "Both diag_table.yaml and "//trim(yamlfilename)//" exists, pick one!") + endif + diag_yaml_id = open_and_parse_file(trim(yamlfilename)) call diag_get_value_from_key(diag_yaml_id, 0, "title", diag_yaml%diag_title) call get_value_from_key(diag_yaml_id, 0, "base_date", diag_yaml%diag_basedate) diff --git a/field_manager/field_manager.F90 b/field_manager/field_manager.F90 index 5c4b44294b..ba26417195 100644 --- a/field_manager/field_manager.F90 +++ b/field_manager/field_manager.F90 @@ -190,7 +190,7 @@ module field_manager_mod use fms_mod, only : lowercase, & write_version_number, & check_nml_error -use fms2_io_mod, only: file_exists +use fms2_io_mod, only: file_exists, get_instance_filename use platform_mod, only: r4_kind, r8_kind, FMS_PATH_LEN, FMS_FILE_LEN #ifdef use_yaml use fm_yaml_mod @@ -606,18 +606,27 @@ subroutine read_field_table_yaml(nfields, table_name) logical :: fm_success !< logical for whether fm_change_list was a success logical :: subparams !< logical whether subparams exist in this iteration +character(len=FMS_FILE_LEN) :: filename !< Name of the expected field_table.yaml + if (.not.PRESENT(table_name)) then tbl_name = 'field_table.yaml' else tbl_name = trim(table_name) endif -if (.not. file_exists(trim(tbl_name))) then + +call get_instance_filename(tbl_name, filename) +if (index(trim(filename), "ens_") .ne. 0) then + if (file_exists(filename) .and. file_exists(tbl_name)) & + call mpp_error(FATAL, "Both "//trim(tbl_name)//" and "//trim(filename)//" exists, pick one!") +endif + +if (.not. file_exists(trim(filename))) then if(present(nfields)) nfields = 0 return endif ! Construct my_table object -call build_fmTable(my_table, trim(tbl_name)) +call build_fmTable(my_table, trim(filename)) do h=1,size(my_table%types) do i=1,size(my_table%types(h)%models) diff --git a/fms/fms_io.F90 b/fms/fms_io.F90 index 06ca5a0627..47854fb997 100644 --- a/fms/fms_io.F90 +++ b/fms/fms_io.F90 @@ -693,6 +693,11 @@ subroutine fms_io_init() call mpp_error(FATAL,'=>fms_io_init: Error reading input nml file') endif + call mpp_error(NOTE, "fms_io_init: fms_io WILL BE DEPRECATED IN A FUTURE RELEASE! "//& + "PLEASE REMOVE -Duse_deprecated_io FROM YOUR COMPILE FLAGS "// & + "AND MOVE TO FMS2_IO. CONTACT YOUR MODEL LIASISON IF YOU NEED "// & + "ASSISTANCE") + ! take namelist options if present ! read_data_bug is no longer supported. if (read_data_bug) then @@ -802,6 +807,11 @@ subroutine fms_io_exit() if( .NOT.module_is_initialized )return !make sure it's only called once per PE + call mpp_error(NOTE, "fms_io_exit: fms_io WILL BE DEPRECATED IN A FUTURE RELEASE! "//& + "PLEASE REMOVE -Duse_deprecated_io FROM YOUR COMPILE FLAGS "// & + "AND MOVE TO FMS2_IO. CONTACT YOUR MODEL LIASISON IF YOU NEED "// & + "ASSISTANCE") + do i=1,max_axis_size axisdata(i) = i enddo diff --git a/fms2_io/fms_io_utils.F90 b/fms2_io/fms_io_utils.F90 index 85b34aa840..605c7d08e9 100644 --- a/fms2_io/fms_io_utils.F90 +++ b/fms2_io/fms_io_utils.F90 @@ -824,8 +824,14 @@ subroutine get_instance_filename(name_in,name_out) if ( i .ne. 0 ) then name_out = name_in(1:i-1)//'.'//trim(filename_appendix)//name_in(i:length) else - !< If .nc is not in the name, add the appendix at the end of the file - name_out = name_in(1:length) //'.'//trim(filename_appendix) + i = index(trim(name_in), ".yaml", back=.true.) + if (i .ne. 0) then + !< If .yaml is in the filename add the appendix before it + name_out = name_in(1:i-1)//'.'//trim(filename_appendix)//name_in(i:length) + else + !< If .nc and .yaml are not in the name, add the appendix at the end of the file + name_out = name_in(1:length) //'.'//trim(filename_appendix) + endif end if end if diff --git a/fms2_io/include/domain_read.inc b/fms2_io/include/domain_read.inc index 13f142c19a..3afdbded3f 100644 --- a/fms2_io/include/domain_read.inc +++ b/fms2_io/include/domain_read.inc @@ -334,7 +334,10 @@ subroutine domain_read_3d(fileobj, variable_name, vdata, unlim_dim_level, & xpos, ypos, isd, isc, xc_size, jsd, jsc, yc_size, buffer_includes_halos, & msg="file:"//trim(fileobj%path)//" and variable:"//trim(variable_name)) c(:) = 1 + if (present(corner)) c = corner + e(:) = shape(vdata) + if (present(edge_lengths)) e = edge_lengths 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) @@ -503,6 +506,7 @@ subroutine domain_read_4d(fileobj, variable_name, vdata, unlim_dim_level, & msg="file:"//trim(fileobj%path)//" and variable:"//trim(variable_name)) c(:) = 1 e(:) = shape(vdata) + if (present(edge_lengths)) e = edge_lengths !I/O root reads in the data and scatters it. if (fileobj%is_root) then @@ -515,6 +519,7 @@ subroutine domain_read_4d(fileobj, variable_name, vdata, unlim_dim_level, & 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) + if (present(corner)) c = corner c(xdim_index) = pe_isc(i) c(ydim_index) = pe_jsc(i) if (fileobj%adjust_indices) then @@ -532,13 +537,11 @@ subroutine domain_read_4d(fileobj, variable_name, vdata, unlim_dim_level, & corner=c, edge_lengths=e, broadcast=.false.) if (i .eq. 1) then !Root rank stores data directly. + c = 1 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 @@ -555,13 +558,11 @@ subroutine domain_read_4d(fileobj, variable_name, vdata, unlim_dim_level, & corner=c, edge_lengths=e, broadcast=.false.) if (i .eq. 1) then !Root rank stores data directly. + c = 1 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 @@ -578,13 +579,11 @@ subroutine domain_read_4d(fileobj, variable_name, vdata, unlim_dim_level, & corner=c, edge_lengths=e, broadcast=.false.) if (i .eq. 1) then !Root rank stores data directly. + c = 1 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 @@ -601,13 +600,11 @@ subroutine domain_read_4d(fileobj, variable_name, vdata, unlim_dim_level, & corner=c, edge_lengths=e, broadcast=.false.) if (i .eq. 1) then !Root rank stores data directly. + c = 1 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 @@ -626,6 +623,7 @@ subroutine domain_read_4d(fileobj, variable_name, vdata, unlim_dim_level, & deallocate(pe_jsc) deallocate(pe_jcsize) else + c = 1 if (buffer_includes_halos) then c(xdim_index) = isc - isd + 1 c(ydim_index) = jsc - jsd + 1 @@ -724,6 +722,7 @@ subroutine domain_read_5d(fileobj, variable_name, vdata, unlim_dim_level, & msg="file:"//trim(fileobj%path)//" and variable:"//trim(variable_name)) c(:) = 1 e(:) = shape(vdata) + if (present(edge_lengths)) e = edge_lengths !I/O root reads in the data and scatters it. if (fileobj%is_root) then @@ -737,6 +736,7 @@ subroutine domain_read_5d(fileobj, variable_name, vdata, unlim_dim_level, & call mpp_get_global_domain(io_domain, ybegin=ygmin, position=ypos) do i = 1, size(fileobj%pelist) !Calculate the indices of the domain-decomposed chunk relative to its position in the file. + if (present(corner)) c = corner c(xdim_index) = pe_isc(i) c(ydim_index) = pe_jsc(i) if (fileobj%adjust_indices) then @@ -755,13 +755,11 @@ subroutine domain_read_5d(fileobj, variable_name, vdata, unlim_dim_level, & if (i .eq. 1) then !Root rank stores data directly. Re-adjust the indicies relative !to the input buffer vdata. + c = 1 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 @@ -778,13 +776,11 @@ subroutine domain_read_5d(fileobj, variable_name, vdata, unlim_dim_level, & corner=c, edge_lengths=e, broadcast=.false.) if (i .eq. 1) then !Root rank stores data directly. + c = 1 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 @@ -801,13 +797,11 @@ subroutine domain_read_5d(fileobj, variable_name, vdata, unlim_dim_level, & corner=c, edge_lengths=e, broadcast=.false.) if (i .eq. 1) then !Root rank stores data directly. + c = 1 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 @@ -824,13 +818,11 @@ subroutine domain_read_5d(fileobj, variable_name, vdata, unlim_dim_level, & corner=c, edge_lengths=e, broadcast=.false.) if (i .eq. 1) then !Root rank stores data directly. + c = 1 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 @@ -849,6 +841,7 @@ subroutine domain_read_5d(fileobj, variable_name, vdata, unlim_dim_level, & deallocate(pe_jsc) deallocate(pe_jcsize) else + c = 1 if (buffer_includes_halos) then c(xdim_index) = isc - isd + 1 c(ydim_index) = jsc - jsd + 1 diff --git a/mosaic/Makefile.am b/grid_utils/Makefile.am similarity index 77% rename from mosaic/Makefile.am rename to grid_utils/Makefile.am index 32166d34d3..1e80ba2c13 100644 --- a/mosaic/Makefile.am +++ b/grid_utils/Makefile.am @@ -28,32 +28,20 @@ AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build these uninstalled convenience libraries. -noinst_LTLIBRARIES = libmosaic.la +noinst_LTLIBRARIES = libgrid_utils.la -libmosaic_la_SOURCES = \ -mosaic.F90 \ -grid.F90 \ -gradient.F90 \ -create_xgrid.c \ +libgrid_utils_la_SOURCES = \ +grid_utils.c \ +grid_utils.h \ +tree_utils.c \ +tree_utils.h \ gradient_c2l.c \ -interp.c \ -mosaic_util.c \ -read_mosaic.c \ -constant.h \ -create_xgrid.h \ gradient_c2l.h \ -interp.h \ -mosaic_util.h \ -read_mosaic.h - -# Some mods are dependant on other mods in this dir. -grid_mod.$(FC_MODEXT): mosaic_mod.$(FC_MODEXT) +gradient.F90 \ +constant.h # Mod files are built and then installed as headers. -MODFILES = \ - mosaic_mod.$(FC_MODEXT) \ - grid_mod.$(FC_MODEXT) \ - gradient_mod.$(FC_MODEXT) +MODFILES = gradient_mod.$(FC_MODEXT) nodist_include_HEADERS = $(MODFILES) BUILT_SOURCES = $(MODFILES) diff --git a/mosaic/constant.h b/grid_utils/constant.h similarity index 80% rename from mosaic/constant.h rename to grid_utils/constant.h index 7dc75e3526..71f5b645ce 100644 --- a/mosaic/constant.h +++ b/grid_utils/constant.h @@ -16,5 +16,13 @@ * You should have received a copy of the GNU Lesser General Public * License along with FMS. If not, see . **********************************************************************/ -#define RADIUS (6371000.) -#define STRING 255 +#define RADIUS (6371000.) +#define STRING 255 + +#define EPSLN8 (1.e-8) +#define EPSLN15 (1.0e-15) +#define EPSLN30 (1.0e-30) +#define EPSLN10 (1.0e-10) +#define R2D (180/M_PI) +#define TPI (2.0*M_PI) +#define HPI (0.5*M_PI) diff --git a/mosaic/gradient.F90 b/grid_utils/gradient.F90 similarity index 100% rename from mosaic/gradient.F90 rename to grid_utils/gradient.F90 diff --git a/mosaic/gradient_c2l.c b/grid_utils/gradient_c2l.c similarity index 99% rename from mosaic/gradient_c2l.c rename to grid_utils/gradient_c2l.c index 0ab1658ffe..1afb15e9cf 100644 --- a/mosaic/gradient_c2l.c +++ b/grid_utils/gradient_c2l.c @@ -19,7 +19,7 @@ #include #include #include "constant.h" -#include "mosaic_util.h" +#include "grid_utils.h" #include "gradient_c2l.h" #include diff --git a/mosaic/gradient_c2l.h b/grid_utils/gradient_c2l.h similarity index 100% rename from mosaic/gradient_c2l.h rename to grid_utils/gradient_c2l.h diff --git a/grid_utils/grid_utils.c b/grid_utils/grid_utils.c new file mode 100644 index 0000000000..b2693054e5 --- /dev/null +++ b/grid_utils/grid_utils.c @@ -0,0 +1,1737 @@ +/*********************************************************************** + * 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 +#include +#include +#include +#include "grid_utils.h" +#include "tree_utils.h" +#include "constant.h" + +#ifdef use_libMPI +#include +#endif + +/** \file + * \ingroup mosaic + * \brief Error handling and other general utilities for @ref mosaic_mod + */ + +/*********************************************************** + void error_handler(char *str) + error handler: will print out error message and then abort +***********************************************************/ + +void error_handler(const char *msg) +{ + fprintf(stderr, "FATAL Error: %s\n", msg ); +#ifdef use_libMPI + MPI_Abort(MPI_COMM_WORLD, -1); +#else + exit(1); +#endif +} /* error_handler */ + + +/******************************************************************************* + double maxval_double(int size, double *data) + get the maximum value of double array +*******************************************************************************/ +double maxval_double(int size, const double *data) +{ + int n; + double maxval; + + maxval = data[0]; + for(n=1; n maxval ) maxval = data[n]; + } + + return maxval; + +} /* maxval_double */ + + +/******************************************************************************* + double minval_double(int size, double *data) + get the minimum value of double array +*******************************************************************************/ +double minval_double(int size, const double *data) +{ + int n; + double minval; + + minval = data[0]; + for(n=1; n=n_ins;i--) { + x[i+1] = x[i]; + y[i+1] = y[i]; + } + + x[n_ins] = lon_in; + y[n_ins] = lat_in; + return (n+1); +} /* insert_vtx */ + +void v_print(double x[], double y[], int n) +{ + int i; + + for (i=0;i=HPI-TOLERANCE) pole = 1; + if (0&&pole) { + printf("fixing pole cell\n"); + v_print(x, y, nn); + printf("---------"); + } + + /* all pole points must be paired */ + for (i=0;i=HPI-TOLERANCE) { + int im=(i+nn-1)%nn, ip=(i+1)%nn; + + if (y[im]==y[i] && y[ip]==y[i]) { + nn = delete_vtx(x, y, nn, i); + i--; + } else if (y[im]!=y[i] && y[ip]!=y[i]) { + nn = insert_vtx(x, y, nn, i, x[i], y[i]); + i++; + } + } + /* first of pole pair has longitude of previous vertex */ + /* second of pole pair has longitude of subsequent vertex */ + for (i=0;i=HPI-TOLERANCE) { + int im=(i+nn-1)%nn, ip=(i+1)%nn; + + if (y[im]!=y[i]){ + x[i] = x[im]; + } + if (y[ip]!=y[i]){ + x[i] = x[ip]; + } + } + + if (nn){ + x_sum = x[0]; + } + else{ + return(0); + } + for (i=1;i M_PI) dx_ = dx_ - TPI; + x_sum += (x[i] = x[i-1] + dx_); + } + + dx = (x_sum/nn)-tlon; + if (dx < -M_PI){ + for (i=0;i M_PI){ + for (i=0;i angle + \ + \ + p2 + -----------------------------------------------------------------------------*/ +double spherical_angle(const double *v1, const double *v2, const double *v3) +{ + double angle; + long double px, py, pz, qx, qy, qz, ddd; + + /* vector product between v1 and v2 */ + px = v1[1]*v2[2] - v1[2]*v2[1]; + py = v1[2]*v2[0] - v1[0]*v2[2]; + pz = v1[0]*v2[1] - v1[1]*v2[0]; + /* vector product between v1 and v3 */ + qx = v1[1]*v3[2] - v1[2]*v3[1]; + qy = v1[2]*v3[0] - v1[0]*v3[2]; + qz = v1[0]*v3[1] - v1[1]*v3[0]; + + ddd = (px*px+py*py+pz*pz)*(qx*qx+qy*qy+qz*qz); + if ( ddd <= 0.0 ) + angle = 0. ; + else { + ddd = (px*qx+py*qy+pz*qz) / sqrtl(ddd); + if( fabsl(ddd-1) < EPSLN30 ) ddd = 1; + if( fabsl(ddd+1) < EPSLN30 ) ddd = -1; + if ( ddd>1. || ddd<-1. ) { + /*FIX (lmh) to correctly handle co-linear points (angle near pi or 0) */ + if (ddd < 0.) + angle = M_PI; + else + angle = 0.; + } + else + angle = ((double)acosl( ddd )); + } + + return angle; +} /* spherical_angle */ + + +/*---------------------------------------------------------------------- + void vect_cross(e, p1, p2) + Perform cross products of 3D vectors: e = P1 X P2 + -------------------------------------------------------------------*/ + +void vect_cross(const double *p1, const double *p2, double *e ) +{ + + e[0] = p1[1]*p2[2] - p1[2]*p2[1]; + e[1] = p1[2]*p2[0] - p1[0]*p2[2]; + e[2] = p1[0]*p2[1] - p1[1]*p2[0]; + +} /* vect_cross */ + + +/*---------------------------------------------------------------------- + double* vect_cross(p1, p2) + return cross products of 3D vectors: = P1 X P2 + -------------------------------------------------------------------*/ + +double dot(const double *p1, const double *p2) +{ + + return( p1[0]*p2[0] + p1[1]*p2[1] + p1[2]*p2[2] ); + +} + + +double metric(const double *p) { + return (sqrt(p[0]*p[0] + p[1]*p[1]+p[2]*p[2]) ); +} + +void normalize_vect(double *e) +{ + double pdot; + int k; + + pdot = e[0]*e[0] + e[1] * e[1] + e[2] * e[2]; + pdot = sqrt( pdot ); + + for(k=0; k<3; k++) e[k] /= pdot; +} + + +/*------------------------------------------------------------------ + void unit_vect_latlon(int size, lon, lat, vlon, vlat) + calculate unit vector for latlon in cartesian coordinates + ---------------------------------------------------------------------*/ +void unit_vect_latlon(int size, const double *lon, const double *lat, double *vlon, double *vlat) +{ + double sin_lon, cos_lon, sin_lat, cos_lat; + int n; + + for(n=0; n= max_x2+RANGE_CHECK_CRITERIA) return 0; + min_x2 = minval_double(*npts, x2); + if(min_x2 >= x1+RANGE_CHECK_CRITERIA) return 0; + + max_y2 = maxval_double(*npts, y2); + if(y1 >= max_y2+RANGE_CHECK_CRITERIA) return 0; + min_y2 = minval_double(*npts, y2); + if(min_y2 >= y1+RANGE_CHECK_CRITERIA) return 0; + + max_z2 = maxval_double(*npts, z2); + if(z1 >= max_z2+RANGE_CHECK_CRITERIA) return 0; + min_z2 = minval_double(*npts, z2); + if(min_z2 >= z1+RANGE_CHECK_CRITERIA) return 0; + + + /* add x2,y2,z2 to a Node */ + rewindList(); + grid1 = getNext(); + grid2 = getNext(); + + addEnd(grid1, x1, y1, z1, 0, 0, 0, -1); + for(i=0; i<*npts; i++) addEnd(grid2, x2[i], y2[i], z2[i], 0, 0, 0, -1); + + isinside = insidePolygon(grid1, grid2); + + return isinside; + +} + +int inside_a_polygon_(double *lon1, double *lat1, int *npts, double *lon2, double *lat2) +{ + + int isinside; + + isinside = inside_a_polygon(lon1, lat1, npts, lon2, lat2); + + return isinside; + +} + +double get_global_area(void) +{ + double garea; + garea = 4*M_PI*RADIUS*RADIUS; + + return garea; +} + +double get_global_area_(void) +{ + double garea; + garea = 4*M_PI*RADIUS*RADIUS; + + return garea; +} + +double poly_area(const double x[], const double y[], int n) +{ + double area = 0.0; + int i; + + for (i=0;i M_PI) dx = dx - 2.0*M_PI; + if(dx < -M_PI) dx = dx + 2.0*M_PI; + if (dx==0.0) continue; + + if ( fabs(lat1-lat2) < SMALL_VALUE) /* cheap area calculation along latitude */ + area -= dx*sin(0.5*(lat1+lat2)); + else { + dy = 0.5*(lat1-lat2); + dat = sin(dy)/dy; + area -= dx*sin(0.5*(lat1+lat2))*dat; + } + } + if(area < 0) + return -area*RADIUS*RADIUS; + else + return area*RADIUS*RADIUS; + +} /* poly_area */ + +double poly_area_no_adjust(const double x[], const double y[], int n) +{ + double area = 0.0; + int i; + + for (i=0;i M_PI) dx = dx - 2.0*M_PI; + if(dx < -M_PI) dx = dx + 2.0*M_PI; + if (dx==0.0) continue; + + if ( fabs(lat1-lat2) < SMALL_VALUE) /* cheap area calculation along latitude */ + area -= dx*sin(0.5*(lat1+lat2)); + else { + dy = 0.5*(lat1-lat2); + dat = sin(dy)/dy; + area -= dx*sin(0.5*(lat1+lat2))*dat; + } + } + if(area < 0) + return (-area/(4*M_PI)); + else + return (area/(4*M_PI)); + +} /* poly_area */ + +/* Compute the great circle area of a polygon on a sphere */ +double great_circle_area(int n, const double *x, const double *y, const double *z) { + int i; + double pnt0[3], pnt1[3], pnt2[3]; + double sum, area; + + /* sum angles around polygon */ + sum=0.0; + for ( i=0; i= ll_lon); + for (i_in=0,i_out=0;i_in= ll_lon))!=inside_last) { + x_tmp[i_out] = ll_lon; + y_tmp[i_out++] = y_last + (ll_lon - x_last) * (lat_in[i_in] - y_last) / (lon_in[i_in] - x_last); + } + + /* if "to" point is right of LEFT boundary, output it */ + if (inside) { + x_tmp[i_out] = lon_in[i_in]; + y_tmp[i_out++] = lat_in[i_in]; + } + x_last = lon_in[i_in]; + y_last = lat_in[i_in]; + inside_last = inside; + } + if (!(n_out=i_out)) return(0); + + /* clip polygon with RIGHT boundary - clip V_TMP to V_OUT */ + x_last = x_tmp[n_out-1]; + y_last = y_tmp[n_out-1]; + inside_last = (x_last <= ur_lon); + for (i_in=0,i_out=0;i_in= ll_lat); + for (i_in=0,i_out=0;i_in= ll_lat))!=inside_last) { + y_tmp[i_out] = ll_lat; + x_tmp[i_out++] = x_last + (ll_lat - y_last) * (lon_out[i_in] - x_last) / (lat_out[i_in] - y_last); + } + + /* if "to" point is above BOTTOM boundary, output it */ + if (inside) { + x_tmp[i_out] = lon_out[i_in]; + y_tmp[i_out++] = lat_out[i_in]; + } + x_last = lon_out[i_in]; + y_last = lat_out[i_in]; + inside_last = inside; + } + if (!(n_out=i_out)) return(0); + + /* clip polygon with TOP boundary - clip V_TMP to V_OUT */ + x_last = x_tmp[n_out-1]; + y_last = y_tmp[n_out-1]; + inside_last = (y_last <= ur_lat); + for (i_in=0,i_out=0;i_in and + should not parallel to the line between and + may need to consider truncation error */ + dy1 = y1_1-y1_0; + dy2 = y2_1-y2_0; + dx1 = x1_1-x1_0; + dx2 = x2_1-x2_0; + ds1 = y1_0*x1_1 - y1_1*x1_0; + ds2 = y2_0*x2_1 - y2_1*x2_0; + determ = dy2*dx1 - dy1*dx2; + if(fabs(determ) < EPSLN30) { + error_handler("the line between and should not parallel to " + "the line between and "); + } + lon_out[i_out] = (dx2*ds1 - dx1*ds2)/determ; + lat_out[i_out++] = (dy2*ds1 - dy1*ds2)/determ; + + + } + if(inside) { + lon_out[i_out] = x1_1; + lat_out[i_out++] = y1_1; + } + x1_0 = x1_1; + y1_0 = y1_1; + inside_last = inside; + } + if(!(n_out=i_out)) return 0; + for(i1=0; i1= max_x2+RANGE_CHECK_CRITERIA) return 0; + max_x1 = maxval_double(n1_in, x1_in); + min_x2 = minval_double(n2_in, x2_in); + if(min_x2 >= max_x1+RANGE_CHECK_CRITERIA) return 0; + + min_y1 = minval_double(n1_in, y1_in); + max_y2 = maxval_double(n2_in, y2_in); + if(min_y1 >= max_y2+RANGE_CHECK_CRITERIA) return 0; + max_y1 = maxval_double(n1_in, y1_in); + min_y2 = minval_double(n2_in, y2_in); + if(min_y2 >= max_y1+RANGE_CHECK_CRITERIA) return 0; + + min_z1 = minval_double(n1_in, z1_in); + max_z2 = maxval_double(n2_in, z2_in); + if(min_z1 >= max_z2+RANGE_CHECK_CRITERIA) return 0; + max_z1 = maxval_double(n1_in, z1_in); + min_z2 = minval_double(n2_in, z2_in); + if(min_z2 >= max_z1+RANGE_CHECK_CRITERIA) return 0; + + rewindList(); + + grid1List = getNext(); + grid2List = getNext(); + intersectList = getNext(); + polyList = getNext(); + + /* insert points into SubjList and ClipList */ + for(i1=0; i1isInside = 1; + else + temp->isInside = 0; + temp = getNextNode(temp); + } + + /* check if grid2List is inside grid1List */ + temp = grid2List; + + while(temp) { + if(insidePolygon(temp, grid1List)) + temp->isInside = 1; + else + temp->isInside = 0; + temp = getNextNode(temp); + } + + /* make sure the grid box is clockwise */ + + /*make sure each polygon is convex, which is equivalent that the great_circle_area is positive */ + if( gridArea(grid1List) <= 0 ) + error_handler("create_xgrid.c(clip_2dx2d_great_circle): grid box 1 is not convex"); + if( gridArea(grid2List) <= 0 ) + error_handler("create_xgrid.c(clip_2dx2d_great_circle): grid box 2 is not convex"); + + /* get the coordinates from grid1List and grid2List. + Please not npts1 might not equal n1_in, npts2 might not equal n2_in because of pole + */ + + temp = grid1List; + for(i1=0; i1Next; + } + temp = grid2List; + for(i2=0; i2Next; + } + + firstIntersect=getNext(); + curIntersect = getNext(); + + /* first find all the intersection points */ + nintersect = 0; + for(i1=0; i1 1) { + getFirstInbound(intersectList, firstIntersect); + if(firstIntersect->initialized) { + has_inbound = 1; + } + } + + /* when has_inbound == 0, get the grid1List and grid2List */ + if( !has_inbound && nintersect > 1) { + setInbound(intersectList, grid1List); + getFirstInbound(intersectList, firstIntersect); + if(firstIntersect->initialized) has_inbound = 1; + } + + /* if has_inbound = 1, find the overlapping */ + n_out = 0; + + if(has_inbound) { + maxiter1 = nintersect; + temp1 = getNode(grid1List, *firstIntersect); + if( temp1 == NULL) { + double lon[10], lat[10]; + int i; + xyz2latlon(n1_in, x1_in, y1_in, z1_in, lon, lat); + for(i=0; i< n1_in; i++) printf("lon1 = %g, lat1 = %g\n", lon[i]*R2D, lat[i]*R2D); + printf("\n"); + xyz2latlon(n2_in, x2_in, y2_in, z2_in, lon, lat); + for(i=0; i< n2_in; i++) printf("lon2 = %g, lat2 = %g\n", lon[i]*R2D, lat[i]*R2D); + printf("\n"); + + error_handler("firstIntersect is not in the grid1List"); + } + addNode(polyList, *firstIntersect); + nintersect--; + + /* Loop over the grid1List and grid2List to find again the firstIntersect */ + curList = grid1List; + curListNum = 0; + + /* Loop through curList to find the next intersection, the loop will end + when come back to firstIntersect + */ + copyNode(curIntersect, *firstIntersect); + iter1 = 0; + found1 = 0; + + while( iter1 < maxiter1 ) { + /* find the curIntersect in curList and get the next intersection points */ + temp1 = getNode(curList, *curIntersect); + temp2 = temp1->Next; + if( temp2 == NULL ) temp2 = curList; + + maxiter2 = length(curList); + found2 = 0; + iter2 = 0; + /* Loop until find the next intersection */ + while( iter2 < maxiter2 ) { + int temp2IsIntersect; + + temp2IsIntersect = 0; + if( isIntersect( *temp2 ) ) { /* copy the point and switch to the grid2List */ + struct Node *temp3; + + /* first check if temp2 is the firstIntersect */ + if( sameNode( *temp2, *firstIntersect) ) { + found1 = 1; + break; + } + + temp3 = temp2->Next; + if( temp3 == NULL) temp3 = curList; + if( temp3 == NULL) error_handler("creat_xgrid.c: temp3 can not be NULL"); + found2 = 1; + /* if next node is inside or an intersection, + need to keep on curList + */ + temp2IsIntersect = 1; + if( isIntersect(*temp3) || (temp3->isInside == 1) ) found2 = 0; + } + if(found2) { + copyNode(curIntersect, *temp2); + break; + } + else { + addNode(polyList, *temp2); + if(temp2IsIntersect) { + nintersect--; + } + } + temp2 = temp2->Next; + if( temp2 == NULL ) temp2 = curList; + iter2 ++; + } + if(found1) break; + + if( !found2 ) error_handler(" not found the next intersection "); + + /* if find the first intersection, the poly found */ + if( sameNode( *curIntersect, *firstIntersect) ) { + found1 = 1; + break; + } + + /* add curIntersect to polyList and remove it from intersectList and curList */ + addNode(polyList, *curIntersect); + nintersect--; + + + /* switch curList */ + if( curListNum == 0) { + curList = grid2List; + curListNum = 1; + } + else { + curList = grid1List; + curListNum = 0; + } + iter1++; + } + if(!found1) error_handler("not return back to the first intersection"); + + /* currently we are only clipping convex polygon to convex polygon */ + if( nintersect > 0) error_handler("After clipping, nintersect should be 0"); + + /* copy the polygon to x_out, y_out, z_out */ + temp1 = polyList; + while (temp1 != NULL) { + getCoordinate(*temp1, x_out+n_out, y_out+n_out, z_out+n_out); + temp1 = temp1->Next; + n_out++; + } + + /* if(n_out < 3) error_handler(" The clipped region has < 3 vertices"); */ + if( n_out < 3) n_out = 0; + } + + /* check if grid1 is inside grid2 */ + if(n_out==0){ + /* first check number of points in grid1 is inside grid2 */ + int n, n1in2; + /* One possible is that grid1List is inside grid2List */ + n1in2 = 0; + temp = grid1List; + while(temp) { + if(temp->intersect != 1) { + if( temp->isInside == 1) n1in2++; + } + temp = getNextNode(temp); + } + if(npts1==n1in2) { /* grid1 is inside grid2 */ + n_out = npts1; + n = 0; + temp = grid1List; + while( temp ) { + getCoordinate(*temp, &x_out[n], &y_out[n], &z_out[n]); + n++; + temp = getNextNode(temp); + } + } + if(n_out>0) return n_out; + } + + /* check if grid2List is inside grid1List */ + if(n_out ==0){ + int n, n2in1; + + temp = grid2List; + n2in1 = 0; + while(temp) { + if(temp->intersect != 1) { + if( temp->isInside == 1) n2in1++; + } + temp = getNextNode(temp); + } + + if(npts2==n2in1) { /* grid2 is inside grid1 */ + n_out = npts2; + n = 0; + temp = grid2List; + while( temp ) { + getCoordinate(*temp, &x_out[n], &y_out[n], &z_out[n]); + n++; + temp = getNextNode(temp); + } + + } + } + + + return n_out; +} + + +/* Intersects between the line a and the seqment s + where both line and segment are great circle lines on the sphere represented by + 3D cartesian points. + [sin sout] are the ends of a line segment + returns true if the lines could be intersected, false otherwise. + inbound means the direction of (a1,a2) go inside or outside of (q1,q2,q3) +*/ + +int line_intersect_2D_3D(double *a1, double *a2, double *q1, double *q2, double *q3, + double *intersect, double *u_a, double *u_q, int *inbound){ + + /* Do this intersection by reprsenting the line a1 to a2 as a plane through the + two line points and the origin of the sphere (0,0,0). This is the + definition of a great circle arc. + */ + double plane[9]; + double plane_p[2]; + double u; + double p1[3], v1[3], v2[3]; + double c1[3], c2[3], c3[3]; + double coincident, sense, norm; + int i; + int is_inter1, is_inter2; + + *inbound = 0; + + /* first check if any vertices are the same */ + if(samePoint(a1[0], a1[1], a1[2], q1[0], q1[1], q1[2])) { + *u_a = 0; + *u_q = 0; + intersect[0] = a1[0]; + intersect[1] = a1[1]; + intersect[2] = a1[2]; + return 1; + } + else if (samePoint(a1[0], a1[1], a1[2], q2[0], q2[1], q2[2])) { + *u_a = 0; + *u_q = 1; + intersect[0] = a1[0]; + intersect[1] = a1[1]; + intersect[2] = a1[2]; + return 1; + } + else if(samePoint(a2[0], a2[1], a2[2], q1[0], q1[1], q1[2])) { + *u_a = 1; + *u_q = 0; + intersect[0] = a2[0]; + intersect[1] = a2[1]; + intersect[2] = a2[2]; + return 1; + } + else if (samePoint(a2[0], a2[1], a2[2], q2[0], q2[1], q2[2])) { + *u_a = 1; + *u_q = 1; + intersect[0] = a2[0]; + intersect[1] = a2[1]; + intersect[2] = a2[2]; + return 1; + } + + + /* Load points defining plane into variable (these are supposed to be in counterclockwise order) */ + plane[0]=q1[0]; + plane[1]=q1[1]; + plane[2]=q1[2]; + plane[3]=q2[0]; + plane[4]=q2[1]; + plane[5]=q2[2]; + plane[6]=0.0; + plane[7]=0.0; + plane[8]=0.0; + + /* Intersect the segment with the plane */ + is_inter1 = intersect_tri_with_line(plane, a1, a2, plane_p, u_a); + + if(!is_inter1) + return 0; + + if(fabs(*u_a) < EPSLN8) *u_a = 0; + if(fabs(*u_a-1) < EPSLN8) *u_a = 1; + + + if( (*u_a < 0) || (*u_a > 1) ) return 0; + + /* Load points defining plane into variable (these are supposed to be in counterclockwise order) */ + plane[0]=a1[0]; + plane[1]=a1[1]; + plane[2]=a1[2]; + plane[3]=a2[0]; + plane[4]=a2[1]; + plane[5]=a2[2]; + plane[6]=0.0; + plane[7]=0.0; + plane[8]=0.0; + + /* Intersect the segment with the plane */ + is_inter2 = intersect_tri_with_line(plane, q1, q2, plane_p, u_q); + + if(!is_inter2) + return 0; + + if(fabs(*u_q) < EPSLN8) *u_q = 0; + if(fabs(*u_q-1) < EPSLN8) *u_q = 1; + + + if( (*u_q < 0) || (*u_q > 1) ) return 0; + + u =*u_a; + + /* The two planes are coincidental */ + vect_cross(a1, a2, c1); + vect_cross(q1, q2, c2); + vect_cross(c1, c2, c3); + coincident = metric(c3); + + if(fabs(coincident) < EPSLN30) return 0; + + /* Calculate point of intersection */ + intersect[0]=a1[0] + u*(a2[0]-a1[0]); + intersect[1]=a1[1] + u*(a2[1]-a1[1]); + intersect[2]=a1[2] + u*(a2[2]-a1[2]); + + norm = metric( intersect ); + for(i = 0; i < 3; i ++) intersect[i] /= norm; + + /* when u_q =0 or u_q =1, the following could not decide the inbound value */ + if(*u_q != 0 && *u_q != 1){ + + p1[0] = a2[0]-a1[0]; + p1[1] = a2[1]-a1[1]; + p1[2] = a2[2]-a1[2]; + v1[0] = q2[0]-q1[0]; + v1[1] = q2[1]-q1[1]; + v1[2] = q2[2]-q1[2]; + v2[0] = q3[0]-q2[0]; + v2[1] = q3[1]-q2[1]; + v2[2] = q3[2]-q2[2]; + + vect_cross(v1, v2, c1); + vect_cross(v1, p1, c2); + + sense = dot(c1, c2); + *inbound = 1; + if(sense > 0) *inbound = 2; /* v1 going into v2 in CCW sense */ + } + + return 1; +} + + +/*------------------------------------------------------------------------------ + double poly_ctrlat(const double x[], const double y[], int n) + This routine is used to calculate the latitude of the centroid + ---------------------------------------------------------------------------*/ + +double poly_ctrlat(const double x[], const double y[], int n) +{ + double ctrlat = 0.0; + int i; + + for (i=0;i M_PI) dx = dx - 2.0*M_PI; + if(dx < -M_PI) dx = dx + 2.0*M_PI; + + if ( fabs(hdy)< SMALL_VALUE ) /* cheap area calculation along latitude */ + ctrlat -= dx*(2*cos(avg_y) + lat2*sin(avg_y) - cos(lat1) ); + else + ctrlat -= dx*( (sin(hdy)/hdy)*(2*cos(avg_y) + lat2*sin(avg_y)) - cos(lat1) ); + } + return (ctrlat*RADIUS*RADIUS); +} /* poly_ctrlat */ + +/*------------------------------------------------------------------------------ + double poly_ctrlon(const double x[], const double y[], int n, double clon) + This routine is used to calculate the lontitude of the centroid. + ---------------------------------------------------------------------------*/ +double poly_ctrlon(const double x[], const double y[], int n, double clon) +{ + double ctrlon = 0.0; + int i; + + for (i=0;i M_PI) dphi = dphi - 2.0*M_PI; + if(dphi < -M_PI) dphi = dphi + 2.0*M_PI; + dphi1 = phi1 - clon; + if( dphi1 > M_PI) dphi1 -= 2.0*M_PI; + if( dphi1 <-M_PI) dphi1 += 2.0*M_PI; + dphi2 = phi2 -clon; + if( dphi2 > M_PI) dphi2 -= 2.0*M_PI; + if( dphi2 <-M_PI) dphi2 += 2.0*M_PI; + + if(fabs(dphi2 -dphi1) < M_PI) { + ctrlon -= dphi * (dphi1*f1+dphi2*f2)/2.0; + } + else { + if(dphi1 > 0.0) + fac = M_PI; + else + fac = -M_PI; + fint = f1 + (f2-f1)*(fac-dphi1)/fabs(dphi); + ctrlon -= 0.5*dphi1*(dphi1-fac)*f1 - 0.5*dphi2*(dphi2+fac)*f2 + + 0.5*fac*(dphi1+dphi2)*fint; + } + + } + return (ctrlon*RADIUS*RADIUS); +} /* poly_ctrlon */ + +/******************************************************************************* + int inside_edge(double x0, double y0, double x1, double y1, double x, double y) + determine a point(x,y) is inside or outside a given edge with vertex, + (x0,y0) and (x1,y1). return 1 if inside and 0 if outside. is + the outward edge normal from vertex to . is the vector + from to . + if Inner produce * > 0, outside, otherwise inside. + inner product value = 0 also treate as inside. +*******************************************************************************/ +int inside_edge(double x0, double y0, double x1, double y1, double x, double y) +{ + const double SMALL = 1.e-12; + double product; + + product = ( x-x0 )*(y1-y0) + (x0-x1)*(y-y0); + return (product<=SMALL) ? 1:0; + +} /* inside_edge */ diff --git a/grid_utils/grid_utils.h b/grid_utils/grid_utils.h new file mode 100644 index 0000000000..d6d9e91046 --- /dev/null +++ b/grid_utils/grid_utils.h @@ -0,0 +1,143 @@ +/*********************************************************************** + * 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 . + **********************************************************************/ +/*********************************************************************** + mosaic_util.h + This header file provide some utilities routine that will be used in many tools. + + contact: Zhi.Liang@noaa.gov +***********************************************************************/ +#ifndef GRID_UTILS_H_ +#define GRID_UTILS_H_ + +#define TOLERANCE (1.e-6) +#ifndef RANGE_CHECK_CRITERIA +#define RANGE_CHECK_CRITERIA 0.05 +#endif + +#define MV 50 + +#define min(a,b) (ab ? a:b) +#define SMALL_VALUE ( 1.e-10 ) + +void error_handler(const char *msg); + +int lon_fix(double *x, double *y, int n_in, double tlon); + +double minval_double(int size, const double *data); + +double maxval_double(int size, const double *data); + +double avgval_double(int size, const double *data); + +void latlon2xyz(int size, const double *lon, const double *lat, double *x, double *y, double *z); + +void xyz2latlon(int size, const double *x, const double *y, const double *z, double *lon, double *lat); + +int delete_vtx(double x[], double y[], int n, int n_del); + +int insert_vtx(double x[], double y[], int n, int n_ins, double lon_in, double lat_in); + +int fix_lon(double lon[], double lat[], int n, double tlon); + +double great_circle_distance(double *p1, double *p2); + +void vect_cross(const double *p1, const double *p2, double *e ); + +double spherical_angle(const double *v1, const double *v2, const double *v3); + +double great_circle_area(int n, const double *x, const double *y, const double *z); + +double * cross(const double *p1, const double *p2); + +double dot(const double *p1, const double *p2); + +void normalize_vect(double *e); + +void unit_vect_latlon(int size, const double *lon, const double *lat, double *vlon, double *vlat); + +int intersect_tri_with_line(const double *plane, const double *l1, const double *l2, double *p, + double *t); + +int invert_matrix_3x3(long double m[], long double m_inv[]); + +void mult(long double m[], long double v[], long double out_v[]); + +double metric(const double *p); + +int inside_a_polygon( double *lon1, double *lat1, int *npts, double *lon2, double *lat2); + +int samePoint(double x1, double y1, double z1, double x2, double y2, double z2); + +int inside_a_polygon_(double *lon1, double *lat1, int *npts, double *lon2, double *lat2); + +int inside_edge(double x0, double y0, double x1, double y1, double x, double y); + +int line_intersect_2D_3D(double *a1, double *a2, double *q1, double *q2, double *q3, + double *intersect, double *u_a, double *u_q, int *inbound); + +double poly_ctrlon(const double lon[], const double lat[], int n, double clon); + +double poly_ctrlat(const double lon[], const double lat[], int n); + +int get_maxxgrid(void); + +int get_maxxgrid_(void); + +double get_global_area(void); + +double get_global_area_(void); + +double poly_area(const double lon[], const double lat[], int n); + +double poly_area_dimensionless(const double x[], const double y[], int n); + +double spherical_excess_area(const double* p_ll, const double* p_ul, + const double* p_lr, const double* p_ur, double radius); + +void get_grid_area(const int *nlon, const int *nlat, const double *lon, const double *lat, double *area); + +void get_grid_great_circle_area(const int *nlon, const int *nlat, const double *lon, const double *lat, double *area); + +void get_grid_area_no_adjust(const int *nlon, const int *nlat, const double *lon, const double *lat, double *area); + +int clip(const double lon_in[], const double lat_in[], int n_in, double ll_lon, double ll_lat, + double ur_lon, double ur_lat, double lon_out[], double lat_out[]); + +int clip_2dx2d(const double lon1_in[], const double lat1_in[], int n1_in, + const double lon2_in[], const double lat2_in[], int n2_in, + double lon_out[], double lat_out[]); + +int clip_2dx2d_great_circle(const double x1_in[], const double y1_in[], const double z1_in[], int n1_in, + const double x2_in[], const double y2_in[], const double z2_in [], int n2_in, + double x_out[], double y_out[], double z_out[]); + +void get_grid_area_ug(const int *npts, const double *lon, const double *lat, double *area); + +void get_grid_great_circle_area_ug(const int *npts, const double *lon, const double *lat, double *area); + +void get_grid_area_(const int *nlon, const int *nlat, const double *lon, const double *lat, double *area); + +void get_grid_great_circle_area_(const int *nlon, const int *nlat, const double *lon, const double *lat, double *area); + +void get_grid_area_ug_(const int *npts, const double *lon, const double *lat, double *area); + +void get_grid_great_circle_area_ug_(const int *npts, const double *lon, const double *lat, double *area); + +#endif diff --git a/grid_utils/tree_utils.c b/grid_utils/tree_utils.c new file mode 100644 index 0000000000..96cac1ab06 --- /dev/null +++ b/grid_utils/tree_utils.c @@ -0,0 +1,572 @@ +/*********************************************************************** + * 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 +#include +#include +#include +#include "grid_utils.h" +#include "tree_utils.h" +#include "constant.h" + +/** \file + * \ingroup tree_utils + * \brief utilities for create_xgrid_great_circle + */ + +struct Node *nodeList=NULL; +int curListPos=0; + +void rewindList(void) +{ + int n; + + curListPos = 0; + if(!nodeList) nodeList = (struct Node *)malloc(MAXNODELIST*sizeof(struct Node)); + for(n=0; n MAXNODELIST) error_handler("getNext: curListPos >= MAXNODELIST"); + + return (temp); +} + + +void initNode(struct Node *node) +{ + node->x = 0; + node->y = 0; + node->z = 0; + node->u = 0; + node->intersect = 0; + node->inbound = 0; + node->isInside = 0; + node->Next = NULL; + node->initialized=0; + +} + +void addEnd(struct Node *list, double x, double y, double z, int intersect, double u, int inbound, int inside) +{ + + struct Node *temp=NULL; + + if(list == NULL) error_handler("addEnd: list is NULL"); + + if(list->initialized) { + + /* (x,y,z) might already in the list when intersect is true and u=0 or 1 */ + temp = list; + while (temp) { + if(samePoint(temp->x, temp->y, temp->z, x, y, z)) return; + temp=temp->Next; + } + temp = list; + while(temp->Next) + temp=temp->Next; + + /* Append at the end of the list. */ + temp->Next = getNext(); + temp = temp->Next; + } + else { + temp = list; + } + + temp->x = x; + temp->y = y; + temp->z = z; + temp->u = u; + temp->intersect = intersect; + temp->inbound = inbound; + temp->initialized=1; + temp->isInside = inside; +} + +/* return 1 if the point (x,y,z) is added in the list, return 0 if it is already in the list */ + +int addIntersect(struct Node *list, double x, double y, double z, int intersect, double u1, double u2, int inbound, + int is1, int ie1, int is2, int ie2) +{ + + double u1_cur, u2_cur; + int i1_cur, i2_cur; + struct Node *temp=NULL; + + if(list == NULL) error_handler("addEnd: list is NULL"); + + /* first check to make sure this point is not in the list */ + u1_cur = u1; + i1_cur = is1; + u2_cur = u2; + i2_cur = is2; + if(u1_cur == 1) { + u1_cur = 0; + i1_cur = ie1; + } + if(u2_cur == 1) { + u2_cur = 0; + i2_cur = ie2; + } + + if(list->initialized) { + temp = list; + while(temp) { + if( temp->u == u1_cur && temp->subj_index == i1_cur) return 0; + if( temp->u_clip == u2_cur && temp->clip_index == i2_cur) return 0; + if( !temp->Next ) break; + temp=temp->Next; + } + + /* Append at the end of the list. */ + temp->Next = getNext(); + temp = temp->Next; + } + else { + temp = list; + } + + temp->x = x; + temp->y = y; + temp->z = z; + temp->intersect = intersect; + temp->inbound = inbound; + temp->initialized=1; + temp->isInside = 0; + temp->u = u1_cur; + temp->subj_index = i1_cur; + temp->u_clip = u2_cur; + temp->clip_index = i2_cur; + + return 1; +} + + +int length(struct Node *list) +{ + struct Node *cur_ptr=NULL; + int count=0; + + cur_ptr=list; + + while(cur_ptr) + { + if(cur_ptr->initialized ==0) break; + cur_ptr=cur_ptr->Next; + count++; + } + return(count); +} + +/* two points are the same if there are close enough */ +int samePoint(double x1, double y1, double z1, double x2, double y2, double z2) +{ + if( fabs(x1-x2) > EPSLN10 || fabs(y1-y2) > EPSLN10 || fabs(z1-z2) > EPSLN10 ) + return 0; + else + return 1; +} + + +int sameNode(struct Node node1, struct Node node2) +{ + if( node1.x == node2.x && node1.y == node2.y && node1.z==node2.z ) + return 1; + else + return 0; +} + + +void addNode(struct Node *list, struct Node inNode) +{ + + addEnd(list, inNode.x, inNode.y, inNode.z, inNode.intersect, inNode.u, inNode.inbound, inNode.isInside); + +} + +struct Node *getNode(struct Node *list, struct Node inNode) +{ + struct Node *thisNode=NULL; + struct Node *temp=NULL; + + temp = list; + while( temp ) { + if( sameNode( *temp, inNode ) ) { + thisNode = temp; + temp = NULL; + break; + } + temp = temp->Next; + } + + return thisNode; +} + +struct Node *getNextNode(struct Node *list) +{ + return list->Next; +} + +void copyNode(struct Node *node_out, struct Node node_in) +{ + + node_out->x = node_in.x; + node_out->y = node_in.y; + node_out->z = node_in.z; + node_out->u = node_in.u; + node_out->intersect = node_in.intersect; + node_out->inbound = node_in.inbound; + node_out->Next = NULL; + node_out->initialized = node_in.initialized; + node_out->isInside = node_in.isInside; +} + +void printNode(struct Node *list, char *str) +{ + struct Node *temp; + + if(list == NULL) error_handler("printNode: list is NULL"); + if(str) printf(" %s \n", str); + temp = list; + while(temp) { + if(temp->initialized ==0) break; + printf(" (x, y, z, interset, inbound, isInside) = (%19.15f,%19.15f,%19.15f,%d,%d,%d)\n", + temp->x, temp->y, temp->z, temp->intersect, temp->inbound, temp->isInside); + temp = temp->Next; + } + printf("\n"); +} + +int intersectInList(struct Node *list, double x, double y, double z) +{ + struct Node *temp; + int found=0; + + temp = list; + found = 0; + while ( temp ) { + if( temp->x == x && temp->y == y && temp->z == z ) { + found = 1; + break; + } + temp=temp->Next; + } + if (!found) error_handler("intersectInList: point (x,y,z) is not found in the list"); + if( temp->intersect == 2 ) + return 1; + else + return 0; + +} + + +/* The following insert a intersection after non-intersect point (x2,y2,z2), if the point + after (x2,y2,z2) is an intersection, if u is greater than the u value of the intersection, + insert after, otherwise insert before +*/ +void insertIntersect(struct Node *list, double x, double y, double z, double u1, double u2, int inbound, + double x2, double y2, double z2) +{ + struct Node *temp1=NULL, *temp2=NULL; + struct Node *temp; + double u_cur; + int found=0; + + temp1 = list; + found = 0; + while ( temp1 ) { + if( temp1->x == x2 && temp1->y == y2 && temp1->z == z2 ) { + found = 1; + break; + } + temp1=temp1->Next; + } + if (!found) error_handler("inserAfter: point (x,y,z) is not found in the list"); + + /* when u = 0 or u = 1, set the grid point to be the intersection point to solve truncation error isuse */ + u_cur = u1; + if(u1 == 1) { + u_cur = 0; + temp1 = temp1->Next; + if(!temp1) temp1 = list; + } + if(u_cur==0) { + temp1->intersect = 2; + temp1->isInside = 1; + temp1->u = u_cur; + temp1->x = x; + temp1->y = y; + temp1->z = z; + return; + } + + /* when u2 != 0 and u2 !=1, can decide if one end of the point is outside depending on inbound value */ + if(u2 != 0 && u2 != 1) { + if(inbound == 1) { /* goes outside, then temp1->Next is an outside point */ + /* find the next non-intersect point */ + temp2 = temp1->Next; + if(!temp2) temp2 = list; + while(temp2->intersect) { + temp2=temp2->Next; + if(!temp2) temp2 = list; + } + + temp2->isInside = 0; + } + else if(inbound ==2) { /* goes inside, then temp1 is an outside point */ + temp1->isInside = 0; + } + } + + temp2 = temp1->Next; + while ( temp2 ) { + if( temp2->intersect == 1 ) { + if( temp2->u > u_cur ) { + break; + } + } + else + break; + temp1 = temp2; + temp2 = temp2->Next; + } + + /* assign value */ + temp = getNext(); + temp->x = x; + temp->y = y; + temp->z = z; + temp->u = u_cur; + temp->intersect = 1; + temp->inbound = inbound; + temp->isInside = 1; + temp->initialized = 1; + temp1->Next = temp; + temp->Next = temp2; + +} + +double gridArea(struct Node *grid) { + double x[20], y[20], z[20]; + struct Node *temp=NULL; + double area; + int n; + + temp = grid; + n = 0; + while( temp ) { + x[n] = temp->x; + y[n] = temp->y; + z[n] = temp->z; + n++; + temp = temp->Next; + } + + area = great_circle_area(n, x, y, z); + + return area; + +} + +int isIntersect(struct Node node) { + + return node.intersect; + +} + + +int getInbound( struct Node node ) +{ + return node.inbound; +} + +struct Node *getLast(struct Node *list) +{ + struct Node *temp1; + + temp1 = list; + if( temp1 ) { + while( temp1->Next ) { + temp1 = temp1->Next; + } + } + + return temp1; +} + + +int getFirstInbound( struct Node *list, struct Node *nodeOut) +{ + struct Node *temp=NULL; + + temp=list; + + while(temp) { + if( temp->inbound == 2 ) { + copyNode(nodeOut, *temp); + return 1; + } + temp=temp->Next; + } + + return 0; +} + +void getCoordinate(struct Node node, double *x, double *y, double *z) +{ + + + *x = node.x; + *y = node.y; + *z = node.z; + +} + +void getCoordinates(struct Node *node, double *p) +{ + + + p[0] = node->x; + p[1] = node->y; + p[2] = node->z; + +} + +void setCoordinate(struct Node *node, double x, double y, double z) +{ + + + node->x = x; + node->y = y; + node->z = z; + +} + +/* set inbound value for the points in interList that has inbound =0, + this will also set some inbound value of the points in list1 +*/ + +void setInbound(struct Node *interList, struct Node *list) +{ + + struct Node *temp1=NULL, *temp=NULL; + struct Node *temp1_prev=NULL, *temp1_next=NULL; + int prev_is_inside, next_is_inside; + + /* for each point in interList, search through list to decide the inbound value the interList point */ + /* For each inbound point, the prev node should be outside and the next is inside. */ + if(length(interList) == 0) return; + + temp = interList; + + while(temp) { + if( !temp->inbound) { + /* search in grid1 to find the prev and next point of temp, when prev point is outside and next point is inside + inbound = 2, else inbound = 1*/ + temp1 = list; + temp1_prev = NULL; + temp1_next = NULL; + while(temp1) { + if(sameNode(*temp1, *temp)) { + if(!temp1_prev) temp1_prev = getLast(list); + temp1_next = temp1->Next; + if(!temp1_next) temp1_next = list; + break; + } + temp1_prev = temp1; + temp1 = temp1->Next; + } + if(!temp1_next) error_handler("Error from create_xgrid.c: temp is not in list1"); + if( temp1_prev->isInside == 0 && temp1_next->isInside == 1) + temp->inbound = 2; /* go inside */ + else + temp->inbound = 1; + } + temp=temp->Next; + } +} + +int isInside(struct Node *node) { + + if(node->isInside == -1) error_handler("Error from mosaic_util.c: node->isInside is not set"); + return(node->isInside); + +} + +/* #define debug_test_create_xgrid */ + +/* check if node is inside polygon list or not */ +int insidePolygon( struct Node *node, struct Node *list) +{ + int is_inside; + double pnt0[3], pnt1[3], pnt2[3]; + double anglesum; + struct Node *p1=NULL, *p2=NULL; + + anglesum = 0; + + pnt0[0] = node->x; + pnt0[1] = node->y; + pnt0[2] = node->z; + + p1 = list; + p2 = list->Next; + is_inside = 0; + + + while(p1) { + pnt1[0] = p1->x; + pnt1[1] = p1->y; + pnt1[2] = p1->z; + pnt2[0] = p2->x; + pnt2[1] = p2->y; + pnt2[2] = p2->z; + if( samePoint(pnt0[0], pnt0[1], pnt0[2], pnt1[0], pnt1[1], pnt1[2]) ){ + return 1; + } + anglesum += spherical_angle(pnt0, pnt2, pnt1); + p1 = p1->Next; + p2 = p2->Next; + if(p2==NULL){ + p2 = list; + } + } + + if( fabs(anglesum - 2*M_PI) < EPSLN8 ){ + is_inside = 1; + } + else{ + is_inside = 0; + } + + return is_inside; + +} diff --git a/mosaic/mosaic_util.h b/grid_utils/tree_utils.h similarity index 55% rename from mosaic/mosaic_util.h rename to grid_utils/tree_utils.h index c12eb08d03..572fe0a350 100644 --- a/mosaic/mosaic_util.h +++ b/grid_utils/tree_utils.h @@ -22,17 +22,13 @@ contact: Zhi.Liang@noaa.gov ***********************************************************************/ -#ifndef MOSAIC_UTIL_H_ -#define MOSAIC_UTIL_H_ +#ifndef TREE_UTILS_H_ +#define TREE_UTILS_H_ -#ifndef RANGE_CHECK_CRITERIA -#define RANGE_CHECK_CRITERIA 0.05 +#ifndef MAXNODELIST +#define MAXNODELIST 100 #endif -#define min(a,b) (ab ? a:b) -#define SMALL_VALUE ( 1.e-10 ) - struct Node{ double x, y, z, u, u_clip; int intersect; /* indicate if this point is an intersection, 0 = no, 1= yes, 2=both intersect and vertices */ @@ -44,72 +40,6 @@ struct Node{ struct Node *Next; }; - -void error_handler(const char *msg); - -int nearest_index(double value, const double *array, int ia); - -int lon_fix(double *x, double *y, int n_in, double tlon); - -double minval_double(int size, const double *data); - -double maxval_double(int size, const double *data); - -double avgval_double(int size, const double *data); - -void latlon2xyz(int size, const double *lon, const double *lat, double *x, double *y, double *z); - -void xyz2latlon(int size, const double *x, const double *y, const double *z, double *lon, double *lat); - -double box_area(double ll_lon, double ll_lat, double ur_lon, double ur_lat); - -double poly_area(const double lon[], const double lat[], int n); - -int delete_vtx(double x[], double y[], int n, int n_del); - -int insert_vtx(double x[], double y[], int n, int n_ins, double lon_in, double lat_in); - -double poly_area_dimensionless(const double lon[], const double lat[], int n); - -double poly_area_no_adjust(const double x[], const double y[], int n); - -int fix_lon(double lon[], double lat[], int n, double tlon); - -void tokenize(const char * const string, const char *tokens, unsigned int varlen, - unsigned int maxvar, char * pstring, unsigned int * const nstr); - -double great_circle_distance(double *p1, double *p2); - -double spherical_excess_area(const double* p_ll, const double* p_ul, - const double* p_lr, const double* p_ur, double radius); - -void vect_cross(const double *p1, const double *p2, double *e ); - -double spherical_angle(const double *v1, const double *v2, const double *v3); - -void normalize_vect(double *e); - -void unit_vect_latlon(int size, const double *lon, const double *lat, double *vlon, double *vlat); - -double great_circle_area(int n, const double *x, const double *y, const double *z); - -double * cross(const double *p1, const double *p2); - -double dot(const double *p1, const double *p2); - -int intersect_tri_with_line(const double *plane, const double *l1, const double *l2, double *p, - double *t); - -int invert_matrix_3x3(long double m[], long double m_inv[]); - -void mult(long double m[], long double v[], long double out_v[]); - -double metric(const double *p); - -int insidePolygon(struct Node *node, struct Node *list ); - -int inside_a_polygon( double *lon1, double *lat1, int *npts, double *lon2, double *lat2); - void rewindList(void); struct Node *getNext(); @@ -123,8 +53,6 @@ int addIntersect(struct Node *list, double x, double y, double z, int intersect, int length(struct Node *list); -int samePoint(double x1, double y1, double z1, double x2, double y2, double z2); - int sameNode(struct Node node1, struct Node node2); void addNode(struct Node *list, struct Node nodeIn); @@ -165,6 +93,6 @@ void setInbound(struct Node *interList, struct Node *list); int isInside(struct Node *node); -int inside_a_polygon_(double *lon1, double *lat1, int *npts, double *lon2, double *lat2); +int insidePolygon( struct Node *node, struct Node *list); #endif diff --git a/horiz_interp/Makefile.am b/horiz_interp/Makefile.am index 55f8f1cbbd..3c5289e62a 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 -I$(top_srcdir)/horiz_interp/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/horiz_interp/include -I$(top_srcdir)/grid_utils AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build these uninstalled convenience libraries. @@ -44,6 +44,8 @@ libhoriz_interp_la_SOURCES = \ include/horiz_interp_spherical.inc \ include/horiz_interp_type.inc \ include/horiz_interp_bicubic_r4.fh \ + include/horiz_interp_conserve_xgrid.h \ + include/horiz_interp_conserve_xgrid.c \ include/horiz_interp_bilinear_r4.fh \ include/horiz_interp_conserve_r4.fh \ include/horiz_interp_r4.fh \ diff --git a/horiz_interp/horiz_interp_type.F90 b/horiz_interp/horiz_interp_type.F90 index e87870698c..a2bc90a821 100644 --- a/horiz_interp/horiz_interp_type.F90 +++ b/horiz_interp/horiz_interp_type.F90 @@ -164,58 +164,131 @@ 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%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 + if( allocated(horiz_interp_in%ilon )) & + horiz_interp_out%ilon = horiz_interp_in%ilon + + if( allocated(horiz_interp_in%jlat )) & + horiz_interp_out%jlat = horiz_interp_in%jlat + + if( allocated(horiz_interp_in%i_lon )) & + horiz_interp_out%i_lon = horiz_interp_in%i_lon + + if( allocated(horiz_interp_in%j_lat )) & + horiz_interp_out%j_lat = horiz_interp_in%j_lat + + if( allocated(horiz_interp_in%found_neighbors )) & + horiz_interp_out%found_neighbors = horiz_interp_in%found_neighbors + + if( allocated(horiz_interp_in%num_found )) & + horiz_interp_out%num_found = horiz_interp_in%num_found + + if( allocated(horiz_interp_in%i_src )) & + horiz_interp_out%i_src = horiz_interp_in%i_src + + if( allocated(horiz_interp_in%j_src )) & + horiz_interp_out%j_src = horiz_interp_in%j_src + + if( allocated(horiz_interp_in%i_dst )) & + horiz_interp_out%i_dst = horiz_interp_in%i_dst + + if( allocated(horiz_interp_in%j_dst )) & + horiz_interp_out%j_dst = horiz_interp_in%j_dst + + 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%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 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. + + if( allocated(horiz_interp_in%horizInterpReals8_type%faci)) & + horiz_interp_out%horizInterpReals8_type%faci = horiz_interp_in%horizInterpReals8_type%faci + + if( allocated( horiz_interp_in%horizInterpReals8_type%facj)) & + horiz_interp_out%horizInterpReals8_type%facj = horiz_interp_in%horizInterpReals8_type%facj + + if( allocated( horiz_interp_in%horizInterpReals8_type%area_src)) & + horiz_interp_out%horizInterpReals8_type%area_src = horiz_interp_in%horizInterpReals8_type%area_src + + if( allocated( horiz_interp_in%horizInterpReals8_type%area_dst)) & + horiz_interp_out%horizInterpReals8_type%area_dst = horiz_interp_in%horizInterpReals8_type%area_dst + + if( allocated( horiz_interp_in%horizInterpReals8_type%wti)) & + horiz_interp_out%horizInterpReals8_type%wti = horiz_interp_in%horizInterpReals8_type%wti + + if( allocated( horiz_interp_in%horizInterpReals8_type%wtj)) & + horiz_interp_out%horizInterpReals8_type%wtj = horiz_interp_in%horizInterpReals8_type%wtj + + if( allocated( horiz_interp_in%horizInterpReals8_type%src_dist)) & + horiz_interp_out%horizInterpReals8_type%src_dist = horiz_interp_in%horizInterpReals8_type%src_dist + + if( allocated( horiz_interp_in%horizInterpReals8_type%rat_x)) & + horiz_interp_out%horizInterpReals8_type%rat_x = horiz_interp_in%horizInterpReals8_type%rat_x + + if( allocated( horiz_interp_in%horizInterpReals8_type%rat_y)) & + horiz_interp_out%horizInterpReals8_type%rat_y = horiz_interp_in%horizInterpReals8_type%rat_y + + if( allocated( horiz_interp_in%horizInterpReals8_type%lon_in)) & + horiz_interp_out%horizInterpReals8_type%lon_in = horiz_interp_in%horizInterpReals8_type%lon_in + + if( allocated( horiz_interp_in%horizInterpReals8_type%lat_in)) & + horiz_interp_out%horizInterpReals8_type%lat_in = horiz_interp_in%horizInterpReals8_type%lat_in + + if( allocated( horiz_interp_in%horizInterpReals8_type%area_frac_dst)) & + 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 + if( allocated(horiz_interp_in%horizInterpReals8_type%mask_in)) & + 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. + if( allocated(horiz_interp_in%horizInterpReals4_type%faci)) & + horiz_interp_out%horizInterpReals4_type%faci = horiz_interp_in%horizInterpReals4_type%faci + + if( allocated( horiz_interp_in%horizInterpReals4_type%facj)) & + horiz_interp_out%horizInterpReals4_type%facj = horiz_interp_in%horizInterpReals4_type%facj + + if( allocated( horiz_interp_in%horizInterpReals4_type%area_src)) & + horiz_interp_out%horizInterpReals4_type%area_src = horiz_interp_in%horizInterpReals4_type%area_src + + if( allocated( horiz_interp_in%horizInterpReals4_type%area_dst)) & + horiz_interp_out%horizInterpReals4_type%area_dst = horiz_interp_in%horizInterpReals4_type%area_dst + + if( allocated( horiz_interp_in%horizInterpReals4_type%wti)) & + horiz_interp_out%horizInterpReals4_type%wti = horiz_interp_in%horizInterpReals4_type%wti + + if( allocated( horiz_interp_in%horizInterpReals4_type%wtj)) & + horiz_interp_out%horizInterpReals4_type%wtj = horiz_interp_in%horizInterpReals4_type%wtj + + if( allocated( horiz_interp_in%horizInterpReals4_type%src_dist)) & + horiz_interp_out%horizInterpReals4_type%src_dist = horiz_interp_in%horizInterpReals4_type%src_dist + + if( allocated( horiz_interp_in%horizInterpReals4_type%rat_x)) & + horiz_interp_out%horizInterpReals4_type%rat_x = horiz_interp_in%horizInterpReals4_type%rat_x + + if( allocated( horiz_interp_in%horizInterpReals4_type%rat_y)) & + horiz_interp_out%horizInterpReals4_type%rat_y = horiz_interp_in%horizInterpReals4_type%rat_y + + if( allocated( horiz_interp_in%horizInterpReals4_type%lon_in)) & + horiz_interp_out%horizInterpReals4_type%lon_in = horiz_interp_in%horizInterpReals4_type%lon_in + + if( allocated( horiz_interp_in%horizInterpReals4_type%lat_in)) & + horiz_interp_out%horizInterpReals4_type%lat_in = horiz_interp_in%horizInterpReals4_type%lat_in + + if( allocated( horiz_interp_in%horizInterpReals4_type%area_frac_dst)) & + 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 + if( allocated(horiz_interp_in%horizInterpReals4_type%mask_in)) & + 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") diff --git a/horiz_interp/include/horiz_interp_conserve_xgrid.c b/horiz_interp/include/horiz_interp_conserve_xgrid.c new file mode 100644 index 0000000000..9b7233ea13 --- /dev/null +++ b/horiz_interp/include/horiz_interp_conserve_xgrid.c @@ -0,0 +1,1321 @@ +/*********************************************************************** + * 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 +#include +#include +#include "grid_utils.h" +#include "tree_utils.h" +#include "horiz_interp_conserve_xgrid.h" +#include "constant.h" + +#if defined(_OPENMP) +#include +#endif + +/** \file + * \ingroup mosaic + * \brief Grid creation and calculation functions for use in @ref mosaic_mod + * / + +/******************************************************************************* + void create_xgrid_1dx2d_order1 + This routine generate exchange grids between two grids for the first order + conservative interpolation. nlon_in,nlat_in,nlon_out,nlat_out are the size of the grid cell + and lon_in,lat_in are 1-D grid bounds, lon_out,lat_out are geographic grid location of grid cell bounds. +*******************************************************************************/ +int create_xgrid_1dx2d_order1_(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, + const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, + const double *mask_in, int *i_in, int *j_in, int *i_out, int *j_out, double *xgrid_area) +{ + int nxgrid; + + nxgrid = create_xgrid_1dx2d_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in, lat_in, lon_out, lat_out, mask_in, + i_in, j_in, i_out, j_out, xgrid_area); + return nxgrid; + +} + +int create_xgrid_1dx2d_order1(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, const double *lon_in, + const double *lat_in, const double *lon_out, const double *lat_out, + const double *mask_in, int *i_in, int *j_in, int *i_out, + int *j_out, double *xgrid_area) +{ + + int nx1, ny1, nx2, ny2, nx1p, nx2p; + int i1, j1, i2, j2, nxgrid; + double ll_lon, ll_lat, ur_lon, ur_lat, x_in[MV], y_in[MV], x_out[MV], y_out[MV]; + double *area_in, *area_out, min_area; + double *tmpx, *tmpy; + + nx1 = *nlon_in; + ny1 = *nlat_in; + nx2 = *nlon_out; + ny2 = *nlat_out; + + nxgrid = 0; + nx1p = nx1 + 1; + nx2p = nx2 + 1; + + area_in = (double *)malloc(nx1*ny1*sizeof(double)); + area_out = (double *)malloc(nx2*ny2*sizeof(double)); + tmpx = (double *)malloc((nx1+1)*(ny1+1)*sizeof(double)); + tmpy = (double *)malloc((nx1+1)*(ny1+1)*sizeof(double)); + for(j1=0; j1<=ny1; j1++) for(i1=0; i1<=nx1; i1++) { + tmpx[j1*nx1p+i1] = lon_in[i1]; + tmpy[j1*nx1p+i1] = lat_in[j1]; + } + /* This is just a temporary fix to solve the issue that there is one point in zonal direction */ + if(nx1 > 1) + get_grid_area(nlon_in, nlat_in, tmpx, tmpy, area_in); + else + get_grid_area_no_adjust(nlon_in, nlat_in, tmpx, tmpy, area_in); + + get_grid_area(nlon_out, nlat_out, lon_out, lat_out, area_out); + free(tmpx); + free(tmpy); + + for(j1=0; j1 MASK_THRESH ) { + + ll_lon = lon_in[i1]; ll_lat = lat_in[j1]; + ur_lon = lon_in[i1+1]; ur_lat = lat_in[j1+1]; + for(j2=0; j2=ur_lat) && (y_in[1]>=ur_lat) + && (y_in[2]>=ur_lat) && (y_in[3]>=ur_lat) ) continue; + + x_in[0] = lon_out[j2*nx2p+i2]; + x_in[1] = lon_out[j2*nx2p+i2+1]; + x_in[2] = lon_out[(j2+1)*nx2p+i2+1]; + x_in[3] = lon_out[(j2+1)*nx2p+i2]; + n_in = fix_lon(x_in, y_in, 4, (ll_lon+ur_lon)/2); + + if ( (n_out = clip ( x_in, y_in, n_in, ll_lon, ll_lat, ur_lon, ur_lat, x_out, y_out )) > 0 ) { + Xarea = poly_area (x_out, y_out, n_out ) * mask_in[j1*nx1+i1]; + min_area = min(area_in[j1*nx1+i1], area_out[j2*nx2+i2]); + if( Xarea/min_area > AREA_RATIO_THRESH ) { + xgrid_area[nxgrid] = Xarea; + i_in[nxgrid] = i1; + j_in[nxgrid] = j1; + i_out[nxgrid] = i2; + j_out[nxgrid] = j2; + ++nxgrid; + if(nxgrid > MAXXGRID) error_handler("nxgrid is greater than MAXXGRID, increase MAXXGRID"); + } + } + } + } + + free(area_in); + free(area_out); + + return nxgrid; + +} /* create_xgrid_1dx2d_order1 */ + + +/******************************************************************************* + void create_xgrid_1dx2d_order1_ug + This routine generate exchange grids between two grids for the first order + conservative interpolation. nlon_in,nlat_in,nlon_out,nlat_out are the size of the grid cell + and lon_in,lat_in are 1-D grid bounds, lon_out,lat_out are geographic grid location of grid cell bounds. +*******************************************************************************/ +int create_xgrid_1dx2d_order1_ug_(const int *nlon_in, const int *nlat_in, const int *npts_out, + const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, + const double *mask_in, int *i_in, int *j_in, int *l_out, double *xgrid_area) +{ + int nxgrid; + + nxgrid = create_xgrid_1dx2d_order1_ug(nlon_in, nlat_in, npts_out, lon_in, lat_in, lon_out, lat_out, mask_in, + i_in, j_in, l_out, xgrid_area); + return nxgrid; + +} + +int create_xgrid_1dx2d_order1_ug(const int *nlon_in, const int *nlat_in, const int *npts_out, const double *lon_in, + const double *lat_in, const double *lon_out, const double *lat_out, + const double *mask_in, int *i_in, int *j_in, int *l_out, double *xgrid_area) +{ + + int nx1, ny1, nx1p, nv, npts2; + int i1, j1, l2, nxgrid; + double ll_lon, ll_lat, ur_lon, ur_lat, x_in[MV], y_in[MV], x_out[MV], y_out[MV]; + double *area_in, *area_out, min_area; + double *tmpx, *tmpy; + + nx1 = *nlon_in; + ny1 = *nlat_in; + nv = 4; + npts2 = *npts_out; + + nxgrid = 0; + nx1p = nx1 + 1; + + area_in = (double *)malloc(nx1*ny1*sizeof(double)); + area_out = (double *)malloc(npts2*sizeof(double)); + tmpx = (double *)malloc((nx1+1)*(ny1+1)*sizeof(double)); + tmpy = (double *)malloc((nx1+1)*(ny1+1)*sizeof(double)); + for(j1=0; j1<=ny1; j1++) for(i1=0; i1<=nx1; i1++) { + tmpx[j1*nx1p+i1] = lon_in[i1]; + tmpy[j1*nx1p+i1] = lat_in[j1]; + } + /* This is just a temporary fix to solve the issue that there is one point in zonal direction */ + if(nx1 > 1) + get_grid_area(nlon_in, nlat_in, tmpx, tmpy, area_in); + else + get_grid_area_no_adjust(nlon_in, nlat_in, tmpx, tmpy, area_in); + + get_grid_area_ug(npts_out, lon_out, lat_out, area_out); + free(tmpx); + free(tmpy); + + for(j1=0; j1 MASK_THRESH ) { + + ll_lon = lon_in[i1]; ll_lat = lat_in[j1]; + ur_lon = lon_in[i1+1]; ur_lat = lat_in[j1+1]; + for(l2=0; l2=ur_lat) && (y_in[1]>=ur_lat) + && (y_in[2]>=ur_lat) && (y_in[3]>=ur_lat) ) continue; + + x_in[0] = lon_out[l2*nv]; + x_in[1] = lon_out[l2*nv+1]; + x_in[2] = lon_out[l2*nv+2]; + x_in[3] = lon_out[l2*nv+3]; + n_in = fix_lon(x_in, y_in, 4, (ll_lon+ur_lon)/2); + + if ( (n_out = clip ( x_in, y_in, n_in, ll_lon, ll_lat, ur_lon, ur_lat, x_out, y_out )) > 0 ) { + Xarea = poly_area (x_out, y_out, n_out ) * mask_in[j1*nx1+i1]; + min_area = min(area_in[j1*nx1+i1], area_out[l2]); + if( Xarea/min_area > AREA_RATIO_THRESH ) { + xgrid_area[nxgrid] = Xarea; + i_in[nxgrid] = i1; + j_in[nxgrid] = j1; + l_out[nxgrid] = l2; + ++nxgrid; + if(nxgrid > MAXXGRID) error_handler("nxgrid is greater than MAXXGRID, increase MAXXGRID"); + } + } + } + } + + free(area_in); + free(area_out); + + return nxgrid; + +} /* create_xgrid_1dx2d_order1_ug */ + +/******************************************************************************** + void create_xgrid_1dx2d_order2 + This routine generate exchange grids between two grids for the second order + conservative interpolation. nlon_in,nlat_in,nlon_out,nlat_out are the size of the grid cell + and lon_in,lat_in are 1-D grid bounds, lon_out,lat_out are geographic grid location of grid cell bounds. +********************************************************************************/ +int create_xgrid_1dx2d_order2_(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, + const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, + const double *mask_in, int *i_in, int *j_in, int *i_out, int *j_out, + double *xgrid_area, double *xgrid_clon, double *xgrid_clat) +{ + int nxgrid; + nxgrid = create_xgrid_1dx2d_order2(nlon_in, nlat_in, nlon_out, nlat_out, lon_in, lat_in, lon_out, lat_out, mask_in, i_in, + j_in, i_out, j_out, xgrid_area, xgrid_clon, xgrid_clat); + return nxgrid; + +} +int create_xgrid_1dx2d_order2(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, + const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, + const double *mask_in, int *i_in, int *j_in, int *i_out, int *j_out, + double *xgrid_area, double *xgrid_clon, double *xgrid_clat) +{ + + int nx1, ny1, nx2, ny2, nx1p, nx2p; + int i1, j1, i2, j2, nxgrid; + double ll_lon, ll_lat, ur_lon, ur_lat, x_in[MV], y_in[MV], x_out[MV], y_out[MV]; + double *area_in, *area_out, min_area; + double *tmpx, *tmpy; + + nx1 = *nlon_in; + ny1 = *nlat_in; + nx2 = *nlon_out; + ny2 = *nlat_out; + + nxgrid = 0; + nx1p = nx1 + 1; + nx2p = nx2 + 1; + + area_in = (double *)malloc(nx1*ny1*sizeof(double)); + area_out = (double *)malloc(nx2*ny2*sizeof(double)); + tmpx = (double *)malloc((nx1+1)*(ny1+1)*sizeof(double)); + tmpy = (double *)malloc((nx1+1)*(ny1+1)*sizeof(double)); + for(j1=0; j1<=ny1; j1++) for(i1=0; i1<=nx1; i1++) { + tmpx[j1*nx1p+i1] = lon_in[i1]; + tmpy[j1*nx1p+i1] = lat_in[j1]; + } + get_grid_area(nlon_in, nlat_in, tmpx, tmpy, area_in); + get_grid_area(nlon_out, nlat_out, lon_out, lat_out, area_out); + free(tmpx); + free(tmpy); + + for(j1=0; j1 MASK_THRESH ) { + + ll_lon = lon_in[i1]; ll_lat = lat_in[j1]; + ur_lon = lon_in[i1+1]; ur_lat = lat_in[j1+1]; + for(j2=0; j2=ur_lat) && (y_in[1]>=ur_lat) + && (y_in[2]>=ur_lat) && (y_in[3]>=ur_lat) ) continue; + + x_in[0] = lon_out[j2*nx2p+i2]; + x_in[1] = lon_out[j2*nx2p+i2+1]; + x_in[2] = lon_out[(j2+1)*nx2p+i2+1]; + x_in[3] = lon_out[(j2+1)*nx2p+i2]; + n_in = fix_lon(x_in, y_in, 4, (ll_lon+ur_lon)/2); + lon_in_avg = avgval_double(n_in, x_in); + + if ( (n_out = clip ( x_in, y_in, n_in, ll_lon, ll_lat, ur_lon, ur_lat, x_out, y_out )) > 0 ) { + xarea = poly_area (x_out, y_out, n_out ) * mask_in[j1*nx1+i1]; + min_area = min(area_in[j1*nx1+i1], area_out[j2*nx2+i2]); + if(xarea/min_area > AREA_RATIO_THRESH ) { + xgrid_area[nxgrid] = xarea; + xgrid_clon[nxgrid] = poly_ctrlon(x_out, y_out, n_out, lon_in_avg); + xgrid_clat[nxgrid] = poly_ctrlat (x_out, y_out, n_out ); + i_in[nxgrid] = i1; + j_in[nxgrid] = j1; + i_out[nxgrid] = i2; + j_out[nxgrid] = j2; + ++nxgrid; + if(nxgrid > MAXXGRID) error_handler("nxgrid is greater than MAXXGRID, increase MAXXGRID"); + } + } + } + } + free(area_in); + free(area_out); + + return nxgrid; + +} /* create_xgrid_1dx2d_order2 */ + +/******************************************************************************* + void create_xgrid_2dx1d_order1 + This routine generate exchange grids between two grids for the first order + conservative interpolation. nlon_in,nlat_in,nlon_out,nlat_out are the size of the grid cell + and lon_out,lat_out are 1-D grid bounds, lon_in,lat_in are geographic grid location of grid cell bounds. + mask is on grid lon_in/lat_in. +*******************************************************************************/ +int create_xgrid_2dx1d_order1_(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, + const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, + const double *mask_in, int *i_in, int *j_in, int *i_out, + int *j_out, double *xgrid_area) +{ + int nxgrid; + + nxgrid = create_xgrid_2dx1d_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in, lat_in, lon_out, lat_out, mask_in, + i_in, j_in, i_out, j_out, xgrid_area); + return nxgrid; + +} +int create_xgrid_2dx1d_order1(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, const double *lon_in, + const double *lat_in, const double *lon_out, const double *lat_out, + const double *mask_in, int *i_in, int *j_in, int *i_out, + int *j_out, double *xgrid_area) +{ + + int nx1, ny1, nx2, ny2, nx1p, nx2p; + int i1, j1, i2, j2, nxgrid; + double ll_lon, ll_lat, ur_lon, ur_lat, x_in[MV], y_in[MV], x_out[MV], y_out[MV]; + double *area_in, *area_out, min_area; + double *tmpx, *tmpy; + int n_in, n_out; + double Xarea; + + + nx1 = *nlon_in; + ny1 = *nlat_in; + nx2 = *nlon_out; + ny2 = *nlat_out; + + nxgrid = 0; + nx1p = nx1 + 1; + nx2p = nx2 + 1; + area_in = (double *)malloc(nx1*ny1*sizeof(double)); + area_out = (double *)malloc(nx2*ny2*sizeof(double)); + tmpx = (double *)malloc((nx2+1)*(ny2+1)*sizeof(double)); + tmpy = (double *)malloc((nx2+1)*(ny2+1)*sizeof(double)); + for(j2=0; j2<=ny2; j2++) for(i2=0; i2<=nx2; i2++) { + tmpx[j2*nx2p+i2] = lon_out[i2]; + tmpy[j2*nx2p+i2] = lat_out[j2]; + } + get_grid_area(nlon_in, nlat_in, lon_in, lat_in, area_in); + get_grid_area(nlon_out, nlat_out, tmpx, tmpy, area_out); + + free(tmpx); + free(tmpy); + + for(j2=0; j2 MASK_THRESH ) { + + y_in[0] = lat_in[j1*nx1p+i1]; + y_in[1] = lat_in[j1*nx1p+i1+1]; + y_in[2] = lat_in[(j1+1)*nx1p+i1+1]; + y_in[3] = lat_in[(j1+1)*nx1p+i1]; + if ( (y_in[0]<=ll_lat) && (y_in[1]<=ll_lat) + && (y_in[2]<=ll_lat) && (y_in[3]<=ll_lat) ) continue; + if ( (y_in[0]>=ur_lat) && (y_in[1]>=ur_lat) + && (y_in[2]>=ur_lat) && (y_in[3]>=ur_lat) ) continue; + + x_in[0] = lon_in[j1*nx1p+i1]; + x_in[1] = lon_in[j1*nx1p+i1+1]; + x_in[2] = lon_in[(j1+1)*nx1p+i1+1]; + x_in[3] = lon_in[(j1+1)*nx1p+i1]; + + n_in = fix_lon(x_in, y_in, 4, (ll_lon+ur_lon)/2); + + if ( (n_out = clip ( x_in, y_in, n_in, ll_lon, ll_lat, ur_lon, ur_lat, x_out, y_out )) > 0 ) { + Xarea = poly_area ( x_out, y_out, n_out ) * mask_in[j1*nx1+i1]; + min_area = min(area_in[j1*nx1+i1], area_out[j2*nx2+i2]); + if( Xarea/min_area > AREA_RATIO_THRESH ) { + xgrid_area[nxgrid] = Xarea; + i_in[nxgrid] = i1; + j_in[nxgrid] = j1; + i_out[nxgrid] = i2; + j_out[nxgrid] = j2; + ++nxgrid; + if(nxgrid > MAXXGRID) error_handler("nxgrid is greater than MAXXGRID, increase MAXXGRID"); + } + } + } + } + + free(area_in); + free(area_out); + + return nxgrid; + +} /* create_xgrid_2dx1d_order1 */ + + +/******************************************************************************** + void create_xgrid_2dx1d_order2 + This routine generate exchange grids between two grids for the second order + conservative interpolation. nlon_in,nlat_in,nlon_out,nlat_out are the size of the grid cell + and lon_out,lat_out are 1-D grid bounds, lon_in,lat_in are geographic grid location of grid cell bounds. + mask is on grid lon_in/lat_in. +********************************************************************************/ +int create_xgrid_2dx1d_order2_(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, + const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, + const double *mask_in, int *i_in, int *j_in, int *i_out, int *j_out, + double *xgrid_area, double *xgrid_clon, double *xgrid_clat) +{ + int nxgrid; + nxgrid = create_xgrid_2dx1d_order2(nlon_in, nlat_in, nlon_out, nlat_out, lon_in, lat_in, lon_out, lat_out, mask_in, i_in, + j_in, i_out, j_out, xgrid_area, xgrid_clon, xgrid_clat); + return nxgrid; + +} + +int create_xgrid_2dx1d_order2(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, + const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, + const double *mask_in, int *i_in, int *j_in, int *i_out, int *j_out, + double *xgrid_area, double *xgrid_clon, double *xgrid_clat) +{ + + int nx1, ny1, nx2, ny2, nx1p, nx2p; + int i1, j1, i2, j2, nxgrid; + double ll_lon, ll_lat, ur_lon, ur_lat, x_in[MV], y_in[MV], x_out[MV], y_out[MV]; + double *tmpx, *tmpy; + double *area_in, *area_out, min_area; + double lon_in_avg; + int n_in, n_out; + double xarea; + + + nx1 = *nlon_in; + ny1 = *nlat_in; + nx2 = *nlon_out; + ny2 = *nlat_out; + + nxgrid = 0; + nx1p = nx1 + 1; + nx2p = nx2 + 1; + + area_in = (double *)malloc(nx1*ny1*sizeof(double)); + area_out = (double *)malloc(nx2*ny2*sizeof(double)); + tmpx = (double *)malloc((nx2+1)*(ny2+1)*sizeof(double)); + tmpy = (double *)malloc((nx2+1)*(ny2+1)*sizeof(double)); + for(j2=0; j2<=ny2; j2++) for(i2=0; i2<=nx2; i2++) { + tmpx[j2*nx2p+i2] = lon_out[i2]; + tmpy[j2*nx2p+i2] = lat_out[j2]; + } + get_grid_area(nlon_in, nlat_in, lon_in, lat_in, area_in); + get_grid_area(nlon_out, nlat_out, tmpx, tmpy, area_out); + + free(tmpx); + free(tmpy); + + for(j2=0; j2 MASK_THRESH ) { + + y_in[0] = lat_in[j1*nx1p+i1]; + y_in[1] = lat_in[j1*nx1p+i1+1]; + y_in[2] = lat_in[(j1+1)*nx1p+i1+1]; + y_in[3] = lat_in[(j1+1)*nx1p+i1]; + if ( (y_in[0]<=ll_lat) && (y_in[1]<=ll_lat) + && (y_in[2]<=ll_lat) && (y_in[3]<=ll_lat) ) continue; + if ( (y_in[0]>=ur_lat) && (y_in[1]>=ur_lat) + && (y_in[2]>=ur_lat) && (y_in[3]>=ur_lat) ) continue; + + x_in[0] = lon_in[j1*nx1p+i1]; + x_in[1] = lon_in[j1*nx1p+i1+1]; + x_in[2] = lon_in[(j1+1)*nx1p+i1+1]; + x_in[3] = lon_in[(j1+1)*nx1p+i1]; + + n_in = fix_lon(x_in, y_in, 4, (ll_lon+ur_lon)/2); + lon_in_avg = avgval_double(n_in, x_in); + + if ( (n_out = clip ( x_in, y_in, n_in, ll_lon, ll_lat, ur_lon, ur_lat, x_out, y_out )) > 0 ) { + xarea = poly_area (x_out, y_out, n_out ) * mask_in[j1*nx1+i1]; + min_area = min(area_in[j1*nx1+i1], area_out[j2*nx2+i2]); + if(xarea/min_area > AREA_RATIO_THRESH ) { + xgrid_area[nxgrid] = xarea; + xgrid_clon[nxgrid] = poly_ctrlon(x_out, y_out, n_out, lon_in_avg); + xgrid_clat[nxgrid] = poly_ctrlat (x_out, y_out, n_out ); + i_in[nxgrid] = i1; + j_in[nxgrid] = j1; + i_out[nxgrid] = i2; + j_out[nxgrid] = j2; + ++nxgrid; + if(nxgrid > MAXXGRID) error_handler("nxgrid is greater than MAXXGRID, increase MAXXGRID"); + } + } + } + } + + free(area_in); + free(area_out); + + return nxgrid; + +} /* create_xgrid_2dx1d_order2 */ + +/******************************************************************************* + void create_xgrid_2DX2D_order1 + This routine generate exchange grids between two grids for the first order + conservative interpolation. nlon_in,nlat_in,nlon_out,nlat_out are the size of the grid cell + and lon_in,lat_in, lon_out,lat_out are geographic grid location of grid cell bounds. + mask is on grid lon_in/lat_in. +*******************************************************************************/ +int create_xgrid_2dx2d_order1_(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, + const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, + const double *mask_in, int *i_in, int *j_in, int *i_out, + int *j_out, double *xgrid_area) +{ + int nxgrid; + + nxgrid = create_xgrid_2dx2d_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in, lat_in, lon_out, lat_out, mask_in, + i_in, j_in, i_out, j_out, xgrid_area); + return nxgrid; + +} +int create_xgrid_2dx2d_order1(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, + const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, + const double *mask_in, int *i_in, int *j_in, int *i_out, + int *j_out, double *xgrid_area) +{ + + int nx1, nx2, ny1, ny2, nx1p, nx2p, nxgrid; + double *area_in, *area_out; + int nblocks =1; + int *istart2=NULL, *iend2=NULL; + int npts_left, nblks_left, pos, m, npts_my, ij; + double *lon_out_min_list,*lon_out_max_list,*lon_out_avg,*lat_out_min_list,*lat_out_max_list; + double *lon_out_list, *lat_out_list; + int *pnxgrid=NULL, *pstart; + int *pi_in=NULL, *pj_in=NULL, *pi_out=NULL, *pj_out=NULL; + double *pxgrid_area=NULL; + int *n2_list; + int nthreads, nxgrid_block_max; + + nx1 = *nlon_in; + ny1 = *nlat_in; + nx2 = *nlon_out; + ny2 = *nlat_out; + nx1p = nx1 + 1; + nx2p = nx2 + 1; + + area_in = (double *)malloc(nx1*ny1*sizeof(double)); + area_out = (double *)malloc(nx2*ny2*sizeof(double)); + get_grid_area(nlon_in, nlat_in, lon_in, lat_in, area_in); + get_grid_area(nlon_out, nlat_out, lon_out, lat_out, area_out); + + nthreads = 1; +#if defined(_OPENMP) +#pragma omp parallel + nthreads = omp_get_num_threads(); +#endif + + nblocks = nthreads; + + istart2 = (int *)malloc(nblocks*sizeof(int)); + iend2 = (int *)malloc(nblocks*sizeof(int)); + + pstart = (int *)malloc(nblocks*sizeof(int)); + pnxgrid = (int *)malloc(nblocks*sizeof(int)); + + nxgrid_block_max = MAXXGRID/nblocks; + + for(m=0; m MAX_V) error_handler("create_xgrid.c: n2_in is greater than MAX_V"); + lon_out_min_list[n] = minval_double(n2_in, x2_in); + lon_out_max_list[n] = maxval_double(n2_in, x2_in); + lon_out_avg[n] = avgval_double(n2_in, x2_in); + n2_list[n] = n2_in; + for(l=0; l MASK_THRESH ) { + int n0, n1, n2, n3, l,n1_in; + double lat_in_min,lat_in_max,lon_in_min,lon_in_max,lon_in_avg; + double x1_in[MV], y1_in[MV], x_out[MV], y_out[MV]; + + n0 = j1*nx1p+i1; n1 = j1*nx1p+i1+1; + n2 = (j1+1)*nx1p+i1+1; n3 = (j1+1)*nx1p+i1; + x1_in[0] = lon_in[n0]; y1_in[0] = lat_in[n0]; + x1_in[1] = lon_in[n1]; y1_in[1] = lat_in[n1]; + x1_in[2] = lon_in[n2]; y1_in[2] = lat_in[n2]; + x1_in[3] = lon_in[n3]; y1_in[3] = lat_in[n3]; + lat_in_min = minval_double(4, y1_in); + lat_in_max = maxval_double(4, y1_in); + n1_in = fix_lon(x1_in, y1_in, 4, M_PI); + lon_in_min = minval_double(n1_in, x1_in); + lon_in_max = maxval_double(n1_in, x1_in); + lon_in_avg = avgval_double(n1_in, x1_in); + for(ij=istart2[m]; ij<=iend2[m]; ij++) { + int n_out, i2, j2, n2_in; + double xarea, dx, lon_out_min, lon_out_max; + double x2_in[MAX_V], y2_in[MAX_V]; + + i2 = ij%nx2; + j2 = ij/nx2; + + if(lat_out_min_list[ij] >= lat_in_max || lat_out_max_list[ij] <= lat_in_min ) continue; + /* adjust x2_in according to lon_in_avg*/ + n2_in = n2_list[ij]; + for(l=0; l M_PI) { + lon_out_min -= TPI; + lon_out_max -= TPI; + for (l=0; l= lon_in_max || lon_out_max <= lon_in_min ) continue; + if ( (n_out = clip_2dx2d( x1_in, y1_in, n1_in, x2_in, y2_in, n2_in, x_out, y_out )) > 0) { + double min_area; + int nn; + xarea = poly_area (x_out, y_out, n_out ) * mask_in[j1*nx1+i1]; + min_area = min(area_in[j1*nx1+i1], area_out[j2*nx2+i2]); + if( xarea/min_area > AREA_RATIO_THRESH ) { + pnxgrid[m]++; + if(pnxgrid[m]>= MAXXGRID/nthreads) + error_handler("nxgrid is greater than MAXXGRID/nthreads, increase MAXXGRID, decrease nthreads, or increase number of MPI ranks"); + nn = pstart[m] + pnxgrid[m]-1; + + pxgrid_area[nn] = xarea; + pi_in[nn] = i1; + pj_in[nn] = j1; + pi_out[nn] = i2; + pj_out[nn] = j2; + } + + } + + } + } + } + + /*copy data if nblocks > 1 */ + if(nblocks == 1) { + nxgrid = pnxgrid[0]; + pi_in = NULL; + pj_in = NULL; + pi_out = NULL; + pj_out = NULL; + pxgrid_area = NULL; + } + else { + int nn, i; + nxgrid = 0; + for(m=0; m MAX_V) error_handler("create_xgrid.c: n2_in is greater than MAX_V"); + lon_out_min_list[n] = minval_double(n2_in, x2_in); + lon_out_max_list[n] = maxval_double(n2_in, x2_in); + lon_out_avg[n] = avgval_double(n2_in, x2_in); + n2_list[n] = n2_in; + for(l=0; l MASK_THRESH ) { + int n0, n1, n2, n3, l,n1_in; + double lat_in_min,lat_in_max,lon_in_min,lon_in_max,lon_in_avg; + double x1_in[MV], y1_in[MV], x_out[MV], y_out[MV]; + + n0 = j1*nx1p+i1; n1 = j1*nx1p+i1+1; + n2 = (j1+1)*nx1p+i1+1; n3 = (j1+1)*nx1p+i1; + x1_in[0] = lon_in[n0]; y1_in[0] = lat_in[n0]; + x1_in[1] = lon_in[n1]; y1_in[1] = lat_in[n1]; + x1_in[2] = lon_in[n2]; y1_in[2] = lat_in[n2]; + x1_in[3] = lon_in[n3]; y1_in[3] = lat_in[n3]; + lat_in_min = minval_double(4, y1_in); + lat_in_max = maxval_double(4, y1_in); + n1_in = fix_lon(x1_in, y1_in, 4, M_PI); + lon_in_min = minval_double(n1_in, x1_in); + lon_in_max = maxval_double(n1_in, x1_in); + lon_in_avg = avgval_double(n1_in, x1_in); + for(ij=istart2[m]; ij<=iend2[m]; ij++) { + int n_out, i2, j2, n2_in; + double xarea, dx, lon_out_min, lon_out_max; + double x2_in[MAX_V], y2_in[MAX_V]; + + i2 = ij%nx2; + j2 = ij/nx2; + + if(lat_out_min_list[ij] >= lat_in_max || lat_out_max_list[ij] <= lat_in_min ) continue; + /* adjust x2_in according to lon_in_avg*/ + n2_in = n2_list[ij]; + for(l=0; l M_PI) { + lon_out_min -= TPI; + lon_out_max -= TPI; + for (l=0; l= lon_in_max || lon_out_max <= lon_in_min ) continue; + if ( (n_out = clip_2dx2d( x1_in, y1_in, n1_in, x2_in, y2_in, n2_in, x_out, y_out )) > 0) { + double min_area; + int nn; + xarea = poly_area (x_out, y_out, n_out ) * mask_in[j1*nx1+i1]; + min_area = min(area_in[j1*nx1+i1], area_out[j2*nx2+i2]); + if( xarea/min_area > AREA_RATIO_THRESH ) { + pnxgrid[m]++; + if(pnxgrid[m]>= MAXXGRID/nthreads) + error_handler("nxgrid is greater than MAXXGRID/nthreads, increase MAXXGRID, decrease nthreads, or increase number of MPI ranks"); + nn = pstart[m] + pnxgrid[m]-1; + pxgrid_area[nn] = xarea; + pxgrid_clon[nn] = poly_ctrlon(x_out, y_out, n_out, lon_in_avg); + pxgrid_clat[nn] = poly_ctrlat (x_out, y_out, n_out ); + pi_in[nn] = i1; + pj_in[nn] = j1; + pi_out[nn] = i2; + pj_out[nn] = j2; + } + } + } + } + } + + /*copy data if nblocks > 1 */ + if(nblocks == 1) { + nxgrid = pnxgrid[0]; + pi_in = NULL; + pj_in = NULL; + pi_out = NULL; + pj_out = NULL; + pxgrid_area = NULL; + pxgrid_clon = NULL; + pxgrid_clat = NULL; + } + else { + int nn, i; + nxgrid = 0; + for(m=0; m MASK_THRESH ) { + /* clockwise */ + n0 = j1*nx1p+i1; n1 = (j1+1)*nx1p+i1; + n2 = (j1+1)*nx1p+i1+1; n3 = j1*nx1p+i1+1; + x1_in[0] = x1[n0]; y1_in[0] = y1[n0]; z1_in[0] = z1[n0]; + x1_in[1] = x1[n1]; y1_in[1] = y1[n1]; z1_in[1] = z1[n1]; + x1_in[2] = x1[n2]; y1_in[2] = y1[n2]; z1_in[2] = z1[n2]; + x1_in[3] = x1[n3]; y1_in[3] = y1[n3]; z1_in[3] = z1[n3]; + + for(j2=0; j2 0) { + xarea = great_circle_area ( n_out, x_out, y_out, z_out ) * mask_in[j1*nx1+i1]; + min_area = min(area1[j1*nx1+i1], area2[j2*nx2+i2]); + if( xarea/min_area > AREA_RATIO_THRESH ) { + xgrid_area[nxgrid] = xarea; + xgrid_clon[nxgrid] = 0; /*z1l: will be developed very soon */ + xgrid_clat[nxgrid] = 0; + i_in[nxgrid] = i1; + j_in[nxgrid] = j1; + i_out[nxgrid] = i2; + j_out[nxgrid] = j2; + ++nxgrid; + if(nxgrid > MAXXGRID) error_handler("nxgrid is greater than MAXXGRID, increase MAXXGRID"); + } + } + } + } + + + free(area1); + free(area2); + + free(x1); + free(y1); + free(z1); + free(x2); + free(y2); + free(z2); + + return nxgrid; + +}/* create_xgrid_great_circle */ + +int create_xgrid_great_circle_ug_(const int *nlon_in, const int *nlat_in, const int *npts_out, + const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, + const double *mask_in, int *i_in, int *j_in, int *l_out, + double *xgrid_area, double *xgrid_clon, double *xgrid_clat) +{ + int nxgrid; + nxgrid = create_xgrid_great_circle_ug(nlon_in, nlat_in, npts_out, lon_in, lat_in, lon_out, lat_out, + mask_in, i_in, j_in, l_out, xgrid_area, xgrid_clon, xgrid_clat); + + return nxgrid; +} + +int create_xgrid_great_circle_ug(const int *nlon_in, const int *nlat_in, const int *npts_out, + const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, + const double *mask_in, int *i_in, int *j_in, int *l_out, + double *xgrid_area, double *xgrid_clon, double *xgrid_clat) +{ + + int nx1, ny1, npts2, nx1p, ny1p, nxgrid, n1_in, n2_in, nv; + int n0, n1, n2, n3, i1, j1, l2; + double x1_in[MV], y1_in[MV], z1_in[MV]; + double x2_in[MV], y2_in[MV], z2_in[MV]; + double x_out[MV], y_out[MV], z_out[MV]; + double *x1=NULL, *y1=NULL, *z1=NULL; + double *x2=NULL, *y2=NULL, *z2=NULL; + + double *area1, *area2, min_area; + + nx1 = *nlon_in; + ny1 = *nlat_in; + nv = 4; + npts2 = *npts_out; + nxgrid = 0; + nx1p = nx1 + 1; + ny1p = ny1 + 1; + + /* first convert lon-lat to cartesian coordinates */ + x1 = (double *)malloc(nx1p*ny1p*sizeof(double)); + y1 = (double *)malloc(nx1p*ny1p*sizeof(double)); + z1 = (double *)malloc(nx1p*ny1p*sizeof(double)); + x2 = (double *)malloc(npts2*nv*sizeof(double)); + y2 = (double *)malloc(npts2*nv*sizeof(double)); + z2 = (double *)malloc(npts2*nv*sizeof(double)); + + latlon2xyz(nx1p*ny1p, lon_in, lat_in, x1, y1, z1); + latlon2xyz(npts2*nv, lon_out, lat_out, x2, y2, z2); + + area1 = (double *)malloc(nx1*ny1*sizeof(double)); + area2 = (double *)malloc(npts2*sizeof(double)); + get_grid_great_circle_area(nlon_in, nlat_in, lon_in, lat_in, area1); + get_grid_great_circle_area_ug(npts_out, lon_out, lat_out, area2); + n1_in = 4; + n2_in = 4; + + for(j1=0; j1 MASK_THRESH ) { + /* clockwise */ + n0 = j1*nx1p+i1; n1 = (j1+1)*nx1p+i1; + n2 = (j1+1)*nx1p+i1+1; n3 = j1*nx1p+i1+1; + x1_in[0] = x1[n0]; y1_in[0] = y1[n0]; z1_in[0] = z1[n0]; + x1_in[1] = x1[n1]; y1_in[1] = y1[n1]; z1_in[1] = z1[n1]; + x1_in[2] = x1[n2]; y1_in[2] = y1[n2]; z1_in[2] = z1[n2]; + x1_in[3] = x1[n3]; y1_in[3] = y1[n3]; z1_in[3] = z1[n3]; + + for(l2=0; l2 0) { + xarea = great_circle_area ( n_out, x_out, y_out, z_out ) * mask_in[j1*nx1+i1]; + min_area = min(area1[j1*nx1+i1], area2[l2]); + if( xarea/min_area > AREA_RATIO_THRESH ) { + xgrid_area[nxgrid] = xarea; + xgrid_clon[nxgrid] = 0; /*z1l: will be developed very soon */ + xgrid_clat[nxgrid] = 0; + i_in[nxgrid] = i1; + j_in[nxgrid] = j1; + l_out[nxgrid] = l2; + ++nxgrid; + if(nxgrid > MAXXGRID) error_handler("nxgrid is greater than MAXXGRID, increase MAXXGRID"); + } + } + } + } + + + free(area1); + free(area2); + + free(x1); + free(y1); + free(z1); + free(x2); + free(y2); + free(z2); + + return nxgrid; + +}/* create_xgrid_great_circle_ug */ + +/******************************************************************************* + int get_maxxgrid + return constants MAXXGRID. +*******************************************************************************/ +int get_maxxgrid(void) +{ + return MAXXGRID; +} + +int get_maxxgrid_(void) +{ + return get_maxxgrid(); +} diff --git a/mosaic/create_xgrid.h b/horiz_interp/include/horiz_interp_conserve_xgrid.h similarity index 74% rename from mosaic/create_xgrid.h rename to horiz_interp/include/horiz_interp_conserve_xgrid.h index 90c0338b93..4711723357 100644 --- a/mosaic/create_xgrid.h +++ b/horiz_interp/include/horiz_interp_conserve_xgrid.h @@ -16,52 +16,16 @@ * You should have received a copy of the GNU Lesser General Public * License along with FMS. If not, see . **********************************************************************/ -#ifndef CREATE_XGRID_H_ -#define CREATE_XGRID_H_ +#ifndef HORIZ_INTERP_CREATE_XGRID_H_ +#define HORIZ_INTERP_CREATE_XGRID_H_ #ifndef MAXXGRID #define MAXXGRID 1e6 #endif -#define MV 50 -/* this value is small compare to earth area */ - -double grid_box_radius(const double *x, const double *y, const double *z, int n); - -double dist_between_boxes(const double *x1, const double *y1, const double *z1, int n1, - const double *x2, const double *y2, const double *z2, int n2); - -int inside_edge(double x0, double y0, double x1, double y1, double x, double y); - -int line_intersect_2D_3D(double *a1, double *a2, double *q1, double *q2, double *q3, - double *intersect, double *u_a, double *u_q, int *inbound); - -double poly_ctrlon(const double lon[], const double lat[], int n, double clon); - -double poly_ctrlat(const double lon[], const double lat[], int n); - -double box_ctrlon(double ll_lon, double ll_lat, double ur_lon, double ur_lat, double clon); - -double box_ctrlat(double ll_lon, double ll_lat, double ur_lon, double ur_lat); - -int get_maxxgrid(void); - -int get_maxxgrid_(void); - -void get_grid_area(const int *nlon, const int *nlat, const double *lon, const double *lat, double *area); - -void get_grid_great_circle_area(const int *nlon, const int *nlat, const double *lon, const double *lat, double *area); - -void get_grid_area_dimensionless(const int *nlon, const int *nlat, const double *lon, const double *lat, double *area); - -void get_grid_area_no_adjust(const int *nlon, const int *nlat, const double *lon, const double *lat, double *area); - -int clip(const double lon_in[], const double lat_in[], int n_in, double ll_lon, double ll_lat, - double ur_lon, double ur_lat, double lon_out[], double lat_out[]); - -int clip_2dx2d(const double lon1_in[], const double lat1_in[], int n1_in, - const double lon2_in[], const double lat2_in[], int n2_in, - double lon_out[], double lat_out[]); +#define AREA_RATIO_THRESH (1.e-6) +#define MASK_THRESH (0.5) +#define MAX_V 8 int create_xgrid_1dx2d_order1(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, @@ -112,29 +76,20 @@ int create_xgrid_2dx2d_order2(const int *nlon_in, const int *nlat_in, const int const double *mask_in, int *i_in, int *j_in, int *i_out, int *j_out, double *xgrid_area, double *xgrid_clon, double *xgrid_clat); -int clip_2dx2d_great_circle(const double x1_in[], const double y1_in[], const double z1_in[], int n1_in, - const double x2_in[], const double y2_in[], const double z2_in [], int n2_in, - double x_out[], double y_out[], double z_out[]); - int create_xgrid_great_circle(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, const double *mask_in, int *i_in, int *j_in, int *i_out, int *j_out, double *xgrid_area, double *xgrid_clon, double *xgrid_clat); -void get_grid_area_ug(const int *npts, const double *lon, const double *lat, double *area); int create_xgrid_1dx2d_order1_ug(const int *nlon_in, const int *nlat_in, const int *npts_out, const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, const double *mask_in, int *i_in, int *j_in, int *l_out, double *xgrid_area); -void get_grid_great_circle_area_ug(const int *npts, const double *lon, const double *lat, double *area); + int create_xgrid_great_circle_ug(const int *nlon_in, const int *nlat_in, const int *npts_out, const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, const double *mask_in, int *i_in, int *j_in, int *l_out, double *xgrid_area, double *xgrid_clon, double *xgrid_clat); -void get_grid_area_(const int *nlon, const int *nlat, const double *lon, const double *lat, double *area); - -void get_grid_great_circle_area_(const int *nlon, const int *nlat, const double *lon, const double *lat, double *area); - int create_xgrid_2dx2d_order1_(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, const double *mask_in, int *i_in, int *j_in, int *i_out, @@ -144,14 +99,17 @@ int create_xgrid_2dx2d_order2_(const int *nlon_in, const int *nlat_in, const int const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, const double *mask_in, int *i_in, int *j_in, int *i_out, int *j_out, double *xgrid_area, double *xgrid_clon, double *xgrid_clat); -void get_grid_area_ug_(const int *npts, const double *lon, const double *lat, double *area); + int create_xgrid_1dx2d_order1_ug_(const int *nlon_in, const int *nlat_in, const int *npts_out, const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, const double *mask_in, int *i_in, int *j_in, int *l_out, double *xgrid_area); -void get_grid_great_circle_area_ug_(const int *npts, const double *lon, const double *lat, double *area); + int create_xgrid_great_circle_ug_(const int *nlon_in, const int *nlat_in, const int *npts_out, const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, const double *mask_in, int *i_in, int *j_in, int *l_out, double *xgrid_area, double *xgrid_clon, double *xgrid_clat); +int get_maxxgrid(void); +int get_maxxgrid_(void); + #endif diff --git a/libFMS.F90 b/libFMS.F90 index 9180be32f5..09296b76aa 100644 --- a/libFMS.F90 +++ b/libFMS.F90 @@ -742,6 +742,7 @@ module fms 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_f2c_string => fms_f2c_string, & fms_string_utils_c2f_string => fms_c2f_string, & fms_string_utils_cstring2cpointer => fms_cstring2cpointer, & fms_string_utils_copy => string_copy diff --git a/libFMS/Makefile.am b/libFMS/Makefile.am index 91bf057e9a..f508b6c9f4 100644 --- a/libFMS/Makefile.am +++ b/libFMS/Makefile.am @@ -39,7 +39,7 @@ libFMS_la_LIBADD += $(top_builddir)/memutils/libmemutils.la libFMS_la_LIBADD += $(top_builddir)/fms/libfms.la libFMS_la_LIBADD += $(top_builddir)/fms2_io/libfms2_io.la libFMS_la_LIBADD += $(top_builddir)/affinity/libfms_affinity.la -libFMS_la_LIBADD += $(top_builddir)/mosaic/libmosaic.la +libFMS_la_LIBADD += $(top_builddir)/grid_utils/libgrid_utils.la libFMS_la_LIBADD += $(top_builddir)/mosaic2/libmosaic2.la libFMS_la_LIBADD += $(top_builddir)/coupler/libcoupler.la libFMS_la_LIBADD += $(top_builddir)/drifters/libdrifters.la diff --git a/m4/gx_fortran_options.m4 b/m4/gx_fortran_options.m4 index 04980c1b68..294264eadd 100644 --- a/m4/gx_fortran_options.m4 +++ b/m4/gx_fortran_options.m4 @@ -90,13 +90,12 @@ for ac_flag in none \ '-qrealsize=8'; do test "x$ac_flag" != xnone && FCFLAGS="$gx_fc_default_real_kind8_flag_FCFLAGS_save ${ac_flag}" AC_COMPILE_IFELSE([[ program test - interface + real :: b=1.0 + call test_sub(b) + contains subroutine test_sub(a) real(kind=selected_real_kind(15,307)) :: a end subroutine test_sub - end interface - real :: b=1.0 - call test_sub(b) end program test]], [gx_cv_fc_default_real_kind8_flag=$ac_flag; break]) done @@ -148,13 +147,12 @@ for ac_flag in none \ '-qrealsize=4'; do test "x$ac_flag" != xnone && FCFLAGS="$gx_fc_default_real_kind4_flag_FCFLAGS_save ${ac_flag}" AC_COMPILE_IFELSE([[ program test - interface + real :: b=1.0 + call test_sub(b) + contains subroutine test_sub(a) real(kind=selected_real_kind(6, 37)) :: a end subroutine test_sub - end interface - real :: b=1.0 - call test_sub(b) end program test]], [gx_cv_fc_default_real_kind4_flag=$ac_flag; break]) done diff --git a/mosaic/create_xgrid.c b/mosaic/create_xgrid.c deleted file mode 100644 index 7698303b92..0000000000 --- a/mosaic/create_xgrid.c +++ /dev/null @@ -1,3088 +0,0 @@ -/*********************************************************************** - * 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 -#include -#include -#include "mosaic_util.h" -#include "create_xgrid.h" -#include "constant.h" -#if defined(_OPENMP) -#include -#endif - -#define AREA_RATIO_THRESH (1.e-6) -#define MASK_THRESH (0.5) -#define EPSLN8 (1.e-8) -#define EPSLN30 (1.0e-30) -#define EPSLN10 (1.0e-10) -#define R2D (180/M_PI) -#define TPI (2.0*M_PI) - -/** \file - * \ingroup mosaic - * \brief Grid creation and calculation functions for use in @ref mosaic_mod - * / - -/******************************************************************************* - int get_maxxgrid - return constants MAXXGRID. -*******************************************************************************/ -int get_maxxgrid(void) -{ - return MAXXGRID; -} - -int get_maxxgrid_(void) -{ - return get_maxxgrid(); -} - - -/******************************************************************************* -void get_grid_area(const int *nlon, const int *nlat, const double *lon, const double *lat, const double *area) - return the grid area. -*******************************************************************************/ -void get_grid_area_(const int *nlon, const int *nlat, const double *lon, const double *lat, double *area) -{ - get_grid_area(nlon, nlat, lon, lat, area); -} - -void get_grid_area(const int *nlon, const int *nlat, const double *lon, const double *lat, double *area) -{ - int nx, ny, nxp, i, j, n_in; - double x_in[20], y_in[20]; - - nx = *nlon; - ny = *nlat; - nxp = nx + 1; - - for(j=0; j 1) - get_grid_area(nlon_in, nlat_in, tmpx, tmpy, area_in); - else - get_grid_area_no_adjust(nlon_in, nlat_in, tmpx, tmpy, area_in); - - get_grid_area(nlon_out, nlat_out, lon_out, lat_out, area_out); - free(tmpx); - free(tmpy); - - for(j1=0; j1 MASK_THRESH ) { - - ll_lon = lon_in[i1]; ll_lat = lat_in[j1]; - ur_lon = lon_in[i1+1]; ur_lat = lat_in[j1+1]; - for(j2=0; j2=ur_lat) && (y_in[1]>=ur_lat) - && (y_in[2]>=ur_lat) && (y_in[3]>=ur_lat) ) continue; - - x_in[0] = lon_out[j2*nx2p+i2]; - x_in[1] = lon_out[j2*nx2p+i2+1]; - x_in[2] = lon_out[(j2+1)*nx2p+i2+1]; - x_in[3] = lon_out[(j2+1)*nx2p+i2]; - n_in = fix_lon(x_in, y_in, 4, (ll_lon+ur_lon)/2); - - if ( (n_out = clip ( x_in, y_in, n_in, ll_lon, ll_lat, ur_lon, ur_lat, x_out, y_out )) > 0 ) { - Xarea = poly_area (x_out, y_out, n_out ) * mask_in[j1*nx1+i1]; - min_area = min(area_in[j1*nx1+i1], area_out[j2*nx2+i2]); - if( Xarea/min_area > AREA_RATIO_THRESH ) { - xgrid_area[nxgrid] = Xarea; - i_in[nxgrid] = i1; - j_in[nxgrid] = j1; - i_out[nxgrid] = i2; - j_out[nxgrid] = j2; - ++nxgrid; - if(nxgrid > MAXXGRID) error_handler("nxgrid is greater than MAXXGRID, increase MAXXGRID"); - } - } - } - } - - free(area_in); - free(area_out); - - return nxgrid; - -} /* create_xgrid_1dx2d_order1 */ - - -/******************************************************************************* - void create_xgrid_1dx2d_order1_ug - This routine generate exchange grids between two grids for the first order - conservative interpolation. nlon_in,nlat_in,nlon_out,nlat_out are the size of the grid cell - and lon_in,lat_in are 1-D grid bounds, lon_out,lat_out are geographic grid location of grid cell bounds. -*******************************************************************************/ -int create_xgrid_1dx2d_order1_ug_(const int *nlon_in, const int *nlat_in, const int *npts_out, - const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, - const double *mask_in, int *i_in, int *j_in, int *l_out, double *xgrid_area) -{ - int nxgrid; - - nxgrid = create_xgrid_1dx2d_order1_ug(nlon_in, nlat_in, npts_out, lon_in, lat_in, lon_out, lat_out, mask_in, - i_in, j_in, l_out, xgrid_area); - return nxgrid; - -} - -int create_xgrid_1dx2d_order1_ug(const int *nlon_in, const int *nlat_in, const int *npts_out, const double *lon_in, - const double *lat_in, const double *lon_out, const double *lat_out, - const double *mask_in, int *i_in, int *j_in, int *l_out, double *xgrid_area) -{ - - int nx1, ny1, nx1p, nv, npts2; - int i1, j1, l2, nxgrid; - double ll_lon, ll_lat, ur_lon, ur_lat, x_in[MV], y_in[MV], x_out[MV], y_out[MV]; - double *area_in, *area_out, min_area; - double *tmpx, *tmpy; - - nx1 = *nlon_in; - ny1 = *nlat_in; - nv = 4; - npts2 = *npts_out; - - nxgrid = 0; - nx1p = nx1 + 1; - - area_in = (double *)malloc(nx1*ny1*sizeof(double)); - area_out = (double *)malloc(npts2*sizeof(double)); - tmpx = (double *)malloc((nx1+1)*(ny1+1)*sizeof(double)); - tmpy = (double *)malloc((nx1+1)*(ny1+1)*sizeof(double)); - for(j1=0; j1<=ny1; j1++) for(i1=0; i1<=nx1; i1++) { - tmpx[j1*nx1p+i1] = lon_in[i1]; - tmpy[j1*nx1p+i1] = lat_in[j1]; - } - /* This is just a temporary fix to solve the issue that there is one point in zonal direction */ - if(nx1 > 1) - get_grid_area(nlon_in, nlat_in, tmpx, tmpy, area_in); - else - get_grid_area_no_adjust(nlon_in, nlat_in, tmpx, tmpy, area_in); - - get_grid_area_ug(npts_out, lon_out, lat_out, area_out); - free(tmpx); - free(tmpy); - - for(j1=0; j1 MASK_THRESH ) { - - ll_lon = lon_in[i1]; ll_lat = lat_in[j1]; - ur_lon = lon_in[i1+1]; ur_lat = lat_in[j1+1]; - for(l2=0; l2=ur_lat) && (y_in[1]>=ur_lat) - && (y_in[2]>=ur_lat) && (y_in[3]>=ur_lat) ) continue; - - x_in[0] = lon_out[l2*nv]; - x_in[1] = lon_out[l2*nv+1]; - x_in[2] = lon_out[l2*nv+2]; - x_in[3] = lon_out[l2*nv+3]; - n_in = fix_lon(x_in, y_in, 4, (ll_lon+ur_lon)/2); - - if ( (n_out = clip ( x_in, y_in, n_in, ll_lon, ll_lat, ur_lon, ur_lat, x_out, y_out )) > 0 ) { - Xarea = poly_area (x_out, y_out, n_out ) * mask_in[j1*nx1+i1]; - min_area = min(area_in[j1*nx1+i1], area_out[l2]); - if( Xarea/min_area > AREA_RATIO_THRESH ) { - xgrid_area[nxgrid] = Xarea; - i_in[nxgrid] = i1; - j_in[nxgrid] = j1; - l_out[nxgrid] = l2; - ++nxgrid; - if(nxgrid > MAXXGRID) error_handler("nxgrid is greater than MAXXGRID, increase MAXXGRID"); - } - } - } - } - - free(area_in); - free(area_out); - - return nxgrid; - -} /* create_xgrid_1dx2d_order1_ug */ - -/******************************************************************************** - void create_xgrid_1dx2d_order2 - This routine generate exchange grids between two grids for the second order - conservative interpolation. nlon_in,nlat_in,nlon_out,nlat_out are the size of the grid cell - and lon_in,lat_in are 1-D grid bounds, lon_out,lat_out are geographic grid location of grid cell bounds. -********************************************************************************/ -int create_xgrid_1dx2d_order2_(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, - const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, - const double *mask_in, int *i_in, int *j_in, int *i_out, int *j_out, - double *xgrid_area, double *xgrid_clon, double *xgrid_clat) -{ - int nxgrid; - nxgrid = create_xgrid_1dx2d_order2(nlon_in, nlat_in, nlon_out, nlat_out, lon_in, lat_in, lon_out, lat_out, mask_in, i_in, - j_in, i_out, j_out, xgrid_area, xgrid_clon, xgrid_clat); - return nxgrid; - -} -int create_xgrid_1dx2d_order2(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, - const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, - const double *mask_in, int *i_in, int *j_in, int *i_out, int *j_out, - double *xgrid_area, double *xgrid_clon, double *xgrid_clat) -{ - - int nx1, ny1, nx2, ny2, nx1p, nx2p; - int i1, j1, i2, j2, nxgrid; - double ll_lon, ll_lat, ur_lon, ur_lat, x_in[MV], y_in[MV], x_out[MV], y_out[MV]; - double *area_in, *area_out, min_area; - double *tmpx, *tmpy; - - nx1 = *nlon_in; - ny1 = *nlat_in; - nx2 = *nlon_out; - ny2 = *nlat_out; - - nxgrid = 0; - nx1p = nx1 + 1; - nx2p = nx2 + 1; - - area_in = (double *)malloc(nx1*ny1*sizeof(double)); - area_out = (double *)malloc(nx2*ny2*sizeof(double)); - tmpx = (double *)malloc((nx1+1)*(ny1+1)*sizeof(double)); - tmpy = (double *)malloc((nx1+1)*(ny1+1)*sizeof(double)); - for(j1=0; j1<=ny1; j1++) for(i1=0; i1<=nx1; i1++) { - tmpx[j1*nx1p+i1] = lon_in[i1]; - tmpy[j1*nx1p+i1] = lat_in[j1]; - } - get_grid_area(nlon_in, nlat_in, tmpx, tmpy, area_in); - get_grid_area(nlon_out, nlat_out, lon_out, lat_out, area_out); - free(tmpx); - free(tmpy); - - for(j1=0; j1 MASK_THRESH ) { - - ll_lon = lon_in[i1]; ll_lat = lat_in[j1]; - ur_lon = lon_in[i1+1]; ur_lat = lat_in[j1+1]; - for(j2=0; j2=ur_lat) && (y_in[1]>=ur_lat) - && (y_in[2]>=ur_lat) && (y_in[3]>=ur_lat) ) continue; - - x_in[0] = lon_out[j2*nx2p+i2]; - x_in[1] = lon_out[j2*nx2p+i2+1]; - x_in[2] = lon_out[(j2+1)*nx2p+i2+1]; - x_in[3] = lon_out[(j2+1)*nx2p+i2]; - n_in = fix_lon(x_in, y_in, 4, (ll_lon+ur_lon)/2); - lon_in_avg = avgval_double(n_in, x_in); - - if ( (n_out = clip ( x_in, y_in, n_in, ll_lon, ll_lat, ur_lon, ur_lat, x_out, y_out )) > 0 ) { - xarea = poly_area (x_out, y_out, n_out ) * mask_in[j1*nx1+i1]; - min_area = min(area_in[j1*nx1+i1], area_out[j2*nx2+i2]); - if(xarea/min_area > AREA_RATIO_THRESH ) { - xgrid_area[nxgrid] = xarea; - xgrid_clon[nxgrid] = poly_ctrlon(x_out, y_out, n_out, lon_in_avg); - xgrid_clat[nxgrid] = poly_ctrlat (x_out, y_out, n_out ); - i_in[nxgrid] = i1; - j_in[nxgrid] = j1; - i_out[nxgrid] = i2; - j_out[nxgrid] = j2; - ++nxgrid; - if(nxgrid > MAXXGRID) error_handler("nxgrid is greater than MAXXGRID, increase MAXXGRID"); - } - } - } - } - free(area_in); - free(area_out); - - return nxgrid; - -} /* create_xgrid_1dx2d_order2 */ - -/******************************************************************************* - void create_xgrid_2dx1d_order1 - This routine generate exchange grids between two grids for the first order - conservative interpolation. nlon_in,nlat_in,nlon_out,nlat_out are the size of the grid cell - and lon_out,lat_out are 1-D grid bounds, lon_in,lat_in are geographic grid location of grid cell bounds. - mask is on grid lon_in/lat_in. -*******************************************************************************/ -int create_xgrid_2dx1d_order1_(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, - const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, - const double *mask_in, int *i_in, int *j_in, int *i_out, - int *j_out, double *xgrid_area) -{ - int nxgrid; - - nxgrid = create_xgrid_2dx1d_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in, lat_in, lon_out, lat_out, mask_in, - i_in, j_in, i_out, j_out, xgrid_area); - return nxgrid; - -} -int create_xgrid_2dx1d_order1(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, const double *lon_in, - const double *lat_in, const double *lon_out, const double *lat_out, - const double *mask_in, int *i_in, int *j_in, int *i_out, - int *j_out, double *xgrid_area) -{ - - int nx1, ny1, nx2, ny2, nx1p, nx2p; - int i1, j1, i2, j2, nxgrid; - double ll_lon, ll_lat, ur_lon, ur_lat, x_in[MV], y_in[MV], x_out[MV], y_out[MV]; - double *area_in, *area_out, min_area; - double *tmpx, *tmpy; - int n_in, n_out; - double Xarea; - - - nx1 = *nlon_in; - ny1 = *nlat_in; - nx2 = *nlon_out; - ny2 = *nlat_out; - - nxgrid = 0; - nx1p = nx1 + 1; - nx2p = nx2 + 1; - area_in = (double *)malloc(nx1*ny1*sizeof(double)); - area_out = (double *)malloc(nx2*ny2*sizeof(double)); - tmpx = (double *)malloc((nx2+1)*(ny2+1)*sizeof(double)); - tmpy = (double *)malloc((nx2+1)*(ny2+1)*sizeof(double)); - for(j2=0; j2<=ny2; j2++) for(i2=0; i2<=nx2; i2++) { - tmpx[j2*nx2p+i2] = lon_out[i2]; - tmpy[j2*nx2p+i2] = lat_out[j2]; - } - get_grid_area(nlon_in, nlat_in, lon_in, lat_in, area_in); - get_grid_area(nlon_out, nlat_out, tmpx, tmpy, area_out); - - free(tmpx); - free(tmpy); - - for(j2=0; j2 MASK_THRESH ) { - - y_in[0] = lat_in[j1*nx1p+i1]; - y_in[1] = lat_in[j1*nx1p+i1+1]; - y_in[2] = lat_in[(j1+1)*nx1p+i1+1]; - y_in[3] = lat_in[(j1+1)*nx1p+i1]; - if ( (y_in[0]<=ll_lat) && (y_in[1]<=ll_lat) - && (y_in[2]<=ll_lat) && (y_in[3]<=ll_lat) ) continue; - if ( (y_in[0]>=ur_lat) && (y_in[1]>=ur_lat) - && (y_in[2]>=ur_lat) && (y_in[3]>=ur_lat) ) continue; - - x_in[0] = lon_in[j1*nx1p+i1]; - x_in[1] = lon_in[j1*nx1p+i1+1]; - x_in[2] = lon_in[(j1+1)*nx1p+i1+1]; - x_in[3] = lon_in[(j1+1)*nx1p+i1]; - - n_in = fix_lon(x_in, y_in, 4, (ll_lon+ur_lon)/2); - - if ( (n_out = clip ( x_in, y_in, n_in, ll_lon, ll_lat, ur_lon, ur_lat, x_out, y_out )) > 0 ) { - Xarea = poly_area ( x_out, y_out, n_out ) * mask_in[j1*nx1+i1]; - min_area = min(area_in[j1*nx1+i1], area_out[j2*nx2+i2]); - if( Xarea/min_area > AREA_RATIO_THRESH ) { - xgrid_area[nxgrid] = Xarea; - i_in[nxgrid] = i1; - j_in[nxgrid] = j1; - i_out[nxgrid] = i2; - j_out[nxgrid] = j2; - ++nxgrid; - if(nxgrid > MAXXGRID) error_handler("nxgrid is greater than MAXXGRID, increase MAXXGRID"); - } - } - } - } - - free(area_in); - free(area_out); - - return nxgrid; - -} /* create_xgrid_2dx1d_order1 */ - - -/******************************************************************************** - void create_xgrid_2dx1d_order2 - This routine generate exchange grids between two grids for the second order - conservative interpolation. nlon_in,nlat_in,nlon_out,nlat_out are the size of the grid cell - and lon_out,lat_out are 1-D grid bounds, lon_in,lat_in are geographic grid location of grid cell bounds. - mask is on grid lon_in/lat_in. -********************************************************************************/ -int create_xgrid_2dx1d_order2_(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, - const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, - const double *mask_in, int *i_in, int *j_in, int *i_out, int *j_out, - double *xgrid_area, double *xgrid_clon, double *xgrid_clat) -{ - int nxgrid; - nxgrid = create_xgrid_2dx1d_order2(nlon_in, nlat_in, nlon_out, nlat_out, lon_in, lat_in, lon_out, lat_out, mask_in, i_in, - j_in, i_out, j_out, xgrid_area, xgrid_clon, xgrid_clat); - return nxgrid; - -} - -int create_xgrid_2dx1d_order2(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, - const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, - const double *mask_in, int *i_in, int *j_in, int *i_out, int *j_out, - double *xgrid_area, double *xgrid_clon, double *xgrid_clat) -{ - - int nx1, ny1, nx2, ny2, nx1p, nx2p; - int i1, j1, i2, j2, nxgrid; - double ll_lon, ll_lat, ur_lon, ur_lat, x_in[MV], y_in[MV], x_out[MV], y_out[MV]; - double *tmpx, *tmpy; - double *area_in, *area_out, min_area; - double lon_in_avg; - int n_in, n_out; - double xarea; - - - nx1 = *nlon_in; - ny1 = *nlat_in; - nx2 = *nlon_out; - ny2 = *nlat_out; - - nxgrid = 0; - nx1p = nx1 + 1; - nx2p = nx2 + 1; - - area_in = (double *)malloc(nx1*ny1*sizeof(double)); - area_out = (double *)malloc(nx2*ny2*sizeof(double)); - tmpx = (double *)malloc((nx2+1)*(ny2+1)*sizeof(double)); - tmpy = (double *)malloc((nx2+1)*(ny2+1)*sizeof(double)); - for(j2=0; j2<=ny2; j2++) for(i2=0; i2<=nx2; i2++) { - tmpx[j2*nx2p+i2] = lon_out[i2]; - tmpy[j2*nx2p+i2] = lat_out[j2]; - } - get_grid_area(nlon_in, nlat_in, lon_in, lat_in, area_in); - get_grid_area(nlon_out, nlat_out, tmpx, tmpy, area_out); - - free(tmpx); - free(tmpy); - - for(j2=0; j2 MASK_THRESH ) { - - y_in[0] = lat_in[j1*nx1p+i1]; - y_in[1] = lat_in[j1*nx1p+i1+1]; - y_in[2] = lat_in[(j1+1)*nx1p+i1+1]; - y_in[3] = lat_in[(j1+1)*nx1p+i1]; - if ( (y_in[0]<=ll_lat) && (y_in[1]<=ll_lat) - && (y_in[2]<=ll_lat) && (y_in[3]<=ll_lat) ) continue; - if ( (y_in[0]>=ur_lat) && (y_in[1]>=ur_lat) - && (y_in[2]>=ur_lat) && (y_in[3]>=ur_lat) ) continue; - - x_in[0] = lon_in[j1*nx1p+i1]; - x_in[1] = lon_in[j1*nx1p+i1+1]; - x_in[2] = lon_in[(j1+1)*nx1p+i1+1]; - x_in[3] = lon_in[(j1+1)*nx1p+i1]; - - n_in = fix_lon(x_in, y_in, 4, (ll_lon+ur_lon)/2); - lon_in_avg = avgval_double(n_in, x_in); - - if ( (n_out = clip ( x_in, y_in, n_in, ll_lon, ll_lat, ur_lon, ur_lat, x_out, y_out )) > 0 ) { - xarea = poly_area (x_out, y_out, n_out ) * mask_in[j1*nx1+i1]; - min_area = min(area_in[j1*nx1+i1], area_out[j2*nx2+i2]); - if(xarea/min_area > AREA_RATIO_THRESH ) { - xgrid_area[nxgrid] = xarea; - xgrid_clon[nxgrid] = poly_ctrlon(x_out, y_out, n_out, lon_in_avg); - xgrid_clat[nxgrid] = poly_ctrlat (x_out, y_out, n_out ); - i_in[nxgrid] = i1; - j_in[nxgrid] = j1; - i_out[nxgrid] = i2; - j_out[nxgrid] = j2; - ++nxgrid; - if(nxgrid > MAXXGRID) error_handler("nxgrid is greater than MAXXGRID, increase MAXXGRID"); - } - } - } - } - - free(area_in); - free(area_out); - - return nxgrid; - -} /* create_xgrid_2dx1d_order2 */ - -/******************************************************************************* - void create_xgrid_2DX2D_order1 - This routine generate exchange grids between two grids for the first order - conservative interpolation. nlon_in,nlat_in,nlon_out,nlat_out are the size of the grid cell - and lon_in,lat_in, lon_out,lat_out are geographic grid location of grid cell bounds. - mask is on grid lon_in/lat_in. -*******************************************************************************/ -int create_xgrid_2dx2d_order1_(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, - const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, - const double *mask_in, int *i_in, int *j_in, int *i_out, - int *j_out, double *xgrid_area) -{ - int nxgrid; - - nxgrid = create_xgrid_2dx2d_order1(nlon_in, nlat_in, nlon_out, nlat_out, lon_in, lat_in, lon_out, lat_out, mask_in, - i_in, j_in, i_out, j_out, xgrid_area); - return nxgrid; - -} -int create_xgrid_2dx2d_order1(const int *nlon_in, const int *nlat_in, const int *nlon_out, const int *nlat_out, - const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, - const double *mask_in, int *i_in, int *j_in, int *i_out, - int *j_out, double *xgrid_area) -{ - -#define MAX_V 8 - int nx1, nx2, ny1, ny2, nx1p, nx2p, nxgrid; - double *area_in, *area_out; - int nblocks =1; - int *istart2=NULL, *iend2=NULL; - int npts_left, nblks_left, pos, m, npts_my, ij; - double *lon_out_min_list,*lon_out_max_list,*lon_out_avg,*lat_out_min_list,*lat_out_max_list; - double *lon_out_list, *lat_out_list; - int *pnxgrid=NULL, *pstart; - int *pi_in=NULL, *pj_in=NULL, *pi_out=NULL, *pj_out=NULL; - double *pxgrid_area=NULL; - int *n2_list; - int nthreads, nxgrid_block_max; - - nx1 = *nlon_in; - ny1 = *nlat_in; - nx2 = *nlon_out; - ny2 = *nlat_out; - nx1p = nx1 + 1; - nx2p = nx2 + 1; - - area_in = (double *)malloc(nx1*ny1*sizeof(double)); - area_out = (double *)malloc(nx2*ny2*sizeof(double)); - get_grid_area(nlon_in, nlat_in, lon_in, lat_in, area_in); - get_grid_area(nlon_out, nlat_out, lon_out, lat_out, area_out); - - nthreads = 1; -#if defined(_OPENMP) -#pragma omp parallel - nthreads = omp_get_num_threads(); -#endif - - nblocks = nthreads; - - istart2 = (int *)malloc(nblocks*sizeof(int)); - iend2 = (int *)malloc(nblocks*sizeof(int)); - - pstart = (int *)malloc(nblocks*sizeof(int)); - pnxgrid = (int *)malloc(nblocks*sizeof(int)); - - nxgrid_block_max = MAXXGRID/nblocks; - - for(m=0; m MAX_V) error_handler("create_xgrid.c: n2_in is greater than MAX_V"); - lon_out_min_list[n] = minval_double(n2_in, x2_in); - lon_out_max_list[n] = maxval_double(n2_in, x2_in); - lon_out_avg[n] = avgval_double(n2_in, x2_in); - n2_list[n] = n2_in; - for(l=0; l MASK_THRESH ) { - int n0, n1, n2, n3, l,n1_in; - double lat_in_min,lat_in_max,lon_in_min,lon_in_max,lon_in_avg; - double x1_in[MV], y1_in[MV], x_out[MV], y_out[MV]; - - n0 = j1*nx1p+i1; n1 = j1*nx1p+i1+1; - n2 = (j1+1)*nx1p+i1+1; n3 = (j1+1)*nx1p+i1; - x1_in[0] = lon_in[n0]; y1_in[0] = lat_in[n0]; - x1_in[1] = lon_in[n1]; y1_in[1] = lat_in[n1]; - x1_in[2] = lon_in[n2]; y1_in[2] = lat_in[n2]; - x1_in[3] = lon_in[n3]; y1_in[3] = lat_in[n3]; - lat_in_min = minval_double(4, y1_in); - lat_in_max = maxval_double(4, y1_in); - n1_in = fix_lon(x1_in, y1_in, 4, M_PI); - lon_in_min = minval_double(n1_in, x1_in); - lon_in_max = maxval_double(n1_in, x1_in); - lon_in_avg = avgval_double(n1_in, x1_in); - for(ij=istart2[m]; ij<=iend2[m]; ij++) { - int n_out, i2, j2, n2_in; - double xarea, dx, lon_out_min, lon_out_max; - double x2_in[MAX_V], y2_in[MAX_V]; - - i2 = ij%nx2; - j2 = ij/nx2; - - if(lat_out_min_list[ij] >= lat_in_max || lat_out_max_list[ij] <= lat_in_min ) continue; - /* adjust x2_in according to lon_in_avg*/ - n2_in = n2_list[ij]; - for(l=0; l M_PI) { - lon_out_min -= TPI; - lon_out_max -= TPI; - for (l=0; l= lon_in_max || lon_out_max <= lon_in_min ) continue; - if ( (n_out = clip_2dx2d( x1_in, y1_in, n1_in, x2_in, y2_in, n2_in, x_out, y_out )) > 0) { - double min_area; - int nn; - xarea = poly_area (x_out, y_out, n_out ) * mask_in[j1*nx1+i1]; - min_area = min(area_in[j1*nx1+i1], area_out[j2*nx2+i2]); - if( xarea/min_area > AREA_RATIO_THRESH ) { - pnxgrid[m]++; - if(pnxgrid[m]>= MAXXGRID/nthreads) - error_handler("nxgrid is greater than MAXXGRID/nthreads, increase MAXXGRID, decrease nthreads, or increase number of MPI ranks"); - nn = pstart[m] + pnxgrid[m]-1; - - pxgrid_area[nn] = xarea; - pi_in[nn] = i1; - pj_in[nn] = j1; - pi_out[nn] = i2; - pj_out[nn] = j2; - } - - } - - } - } - } - - /*copy data if nblocks > 1 */ - if(nblocks == 1) { - nxgrid = pnxgrid[0]; - pi_in = NULL; - pj_in = NULL; - pi_out = NULL; - pj_out = NULL; - pxgrid_area = NULL; - } - else { - int nn, i; - nxgrid = 0; - for(m=0; m MAX_V) error_handler("create_xgrid.c: n2_in is greater than MAX_V"); - lon_out_min_list[n] = minval_double(n2_in, x2_in); - lon_out_max_list[n] = maxval_double(n2_in, x2_in); - lon_out_avg[n] = avgval_double(n2_in, x2_in); - n2_list[n] = n2_in; - for(l=0; l MASK_THRESH ) { - int n0, n1, n2, n3, l,n1_in; - double lat_in_min,lat_in_max,lon_in_min,lon_in_max,lon_in_avg; - double x1_in[MV], y1_in[MV], x_out[MV], y_out[MV]; - - n0 = j1*nx1p+i1; n1 = j1*nx1p+i1+1; - n2 = (j1+1)*nx1p+i1+1; n3 = (j1+1)*nx1p+i1; - x1_in[0] = lon_in[n0]; y1_in[0] = lat_in[n0]; - x1_in[1] = lon_in[n1]; y1_in[1] = lat_in[n1]; - x1_in[2] = lon_in[n2]; y1_in[2] = lat_in[n2]; - x1_in[3] = lon_in[n3]; y1_in[3] = lat_in[n3]; - lat_in_min = minval_double(4, y1_in); - lat_in_max = maxval_double(4, y1_in); - n1_in = fix_lon(x1_in, y1_in, 4, M_PI); - lon_in_min = minval_double(n1_in, x1_in); - lon_in_max = maxval_double(n1_in, x1_in); - lon_in_avg = avgval_double(n1_in, x1_in); - for(ij=istart2[m]; ij<=iend2[m]; ij++) { - int n_out, i2, j2, n2_in; - double xarea, dx, lon_out_min, lon_out_max; - double x2_in[MAX_V], y2_in[MAX_V]; - - i2 = ij%nx2; - j2 = ij/nx2; - - if(lat_out_min_list[ij] >= lat_in_max || lat_out_max_list[ij] <= lat_in_min ) continue; - /* adjust x2_in according to lon_in_avg*/ - n2_in = n2_list[ij]; - for(l=0; l M_PI) { - lon_out_min -= TPI; - lon_out_max -= TPI; - for (l=0; l= lon_in_max || lon_out_max <= lon_in_min ) continue; - if ( (n_out = clip_2dx2d( x1_in, y1_in, n1_in, x2_in, y2_in, n2_in, x_out, y_out )) > 0) { - double min_area; - int nn; - xarea = poly_area (x_out, y_out, n_out ) * mask_in[j1*nx1+i1]; - min_area = min(area_in[j1*nx1+i1], area_out[j2*nx2+i2]); - if( xarea/min_area > AREA_RATIO_THRESH ) { - pnxgrid[m]++; - if(pnxgrid[m]>= MAXXGRID/nthreads) - error_handler("nxgrid is greater than MAXXGRID/nthreads, increase MAXXGRID, decrease nthreads, or increase number of MPI ranks"); - nn = pstart[m] + pnxgrid[m]-1; - pxgrid_area[nn] = xarea; - pxgrid_clon[nn] = poly_ctrlon(x_out, y_out, n_out, lon_in_avg); - pxgrid_clat[nn] = poly_ctrlat (x_out, y_out, n_out ); - pi_in[nn] = i1; - pj_in[nn] = j1; - pi_out[nn] = i2; - pj_out[nn] = j2; - } - } - } - } - } - - /*copy data if nblocks > 1 */ - if(nblocks == 1) { - nxgrid = pnxgrid[0]; - pi_in = NULL; - pj_in = NULL; - pi_out = NULL; - pj_out = NULL; - pxgrid_area = NULL; - pxgrid_clon = NULL; - pxgrid_clat = NULL; - } - else { - int nn, i; - nxgrid = 0; - for(m=0; m= ll_lon); - for (i_in=0,i_out=0;i_in= ll_lon))!=inside_last) { - x_tmp[i_out] = ll_lon; - y_tmp[i_out++] = y_last + (ll_lon - x_last) * (lat_in[i_in] - y_last) / (lon_in[i_in] - x_last); - } - - /* if "to" point is right of LEFT boundary, output it */ - if (inside) { - x_tmp[i_out] = lon_in[i_in]; - y_tmp[i_out++] = lat_in[i_in]; - } - x_last = lon_in[i_in]; - y_last = lat_in[i_in]; - inside_last = inside; - } - if (!(n_out=i_out)) return(0); - - /* clip polygon with RIGHT boundary - clip V_TMP to V_OUT */ - x_last = x_tmp[n_out-1]; - y_last = y_tmp[n_out-1]; - inside_last = (x_last <= ur_lon); - for (i_in=0,i_out=0;i_in= ll_lat); - for (i_in=0,i_out=0;i_in= ll_lat))!=inside_last) { - y_tmp[i_out] = ll_lat; - x_tmp[i_out++] = x_last + (ll_lat - y_last) * (lon_out[i_in] - x_last) / (lat_out[i_in] - y_last); - } - - /* if "to" point is above BOTTOM boundary, output it */ - if (inside) { - x_tmp[i_out] = lon_out[i_in]; - y_tmp[i_out++] = lat_out[i_in]; - } - x_last = lon_out[i_in]; - y_last = lat_out[i_in]; - inside_last = inside; - } - if (!(n_out=i_out)) return(0); - - /* clip polygon with TOP boundary - clip V_TMP to V_OUT */ - x_last = x_tmp[n_out-1]; - y_last = y_tmp[n_out-1]; - inside_last = (y_last <= ur_lat); - for (i_in=0,i_out=0;i_in and - should not parallel to the line between and - may need to consider truncation error */ - dy1 = y1_1-y1_0; - dy2 = y2_1-y2_0; - dx1 = x1_1-x1_0; - dx2 = x2_1-x2_0; - ds1 = y1_0*x1_1 - y1_1*x1_0; - ds2 = y2_0*x2_1 - y2_1*x2_0; - determ = dy2*dx1 - dy1*dx2; - if(fabs(determ) < EPSLN30) { - error_handler("the line between and should not parallel to " - "the line between and "); - } - lon_out[i_out] = (dx2*ds1 - dx1*ds2)/determ; - lat_out[i_out++] = (dy2*ds1 - dy1*ds2)/determ; - - - } - if(inside) { - lon_out[i_out] = x1_1; - lat_out[i_out++] = y1_1; - } - x1_0 = x1_1; - y1_0 = y1_1; - inside_last = inside; - } - if(!(n_out=i_out)) return 0; - for(i1=0; i1 MASK_THRESH ) { - /* clockwise */ - n0 = j1*nx1p+i1; n1 = (j1+1)*nx1p+i1; - n2 = (j1+1)*nx1p+i1+1; n3 = j1*nx1p+i1+1; - x1_in[0] = x1[n0]; y1_in[0] = y1[n0]; z1_in[0] = z1[n0]; - x1_in[1] = x1[n1]; y1_in[1] = y1[n1]; z1_in[1] = z1[n1]; - x1_in[2] = x1[n2]; y1_in[2] = y1[n2]; z1_in[2] = z1[n2]; - x1_in[3] = x1[n3]; y1_in[3] = y1[n3]; z1_in[3] = z1[n3]; - - for(j2=0; j2 0) { - xarea = great_circle_area ( n_out, x_out, y_out, z_out ) * mask_in[j1*nx1+i1]; - min_area = min(area1[j1*nx1+i1], area2[j2*nx2+i2]); - if( xarea/min_area > AREA_RATIO_THRESH ) { -#ifdef debug_test_create_xgrid - printf("(i2,j2)=(%d,%d), (i1,j1)=(%d,%d), xarea=%g\n", i2, j2, i1, j1, xarea); -#endif - xgrid_area[nxgrid] = xarea; - xgrid_clon[nxgrid] = 0; /*z1l: will be developed very soon */ - xgrid_clat[nxgrid] = 0; - i_in[nxgrid] = i1; - j_in[nxgrid] = j1; - i_out[nxgrid] = i2; - j_out[nxgrid] = j2; - ++nxgrid; - if(nxgrid > MAXXGRID) error_handler("nxgrid is greater than MAXXGRID, increase MAXXGRID"); - } - } - } - } - - - free(area1); - free(area2); - - free(x1); - free(y1); - free(z1); - free(x2); - free(y2); - free(z2); - - return nxgrid; - -}/* create_xgrid_great_circle */ - -int create_xgrid_great_circle_ug_(const int *nlon_in, const int *nlat_in, const int *npts_out, - const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, - const double *mask_in, int *i_in, int *j_in, int *l_out, - double *xgrid_area, double *xgrid_clon, double *xgrid_clat) -{ - int nxgrid; - nxgrid = create_xgrid_great_circle_ug(nlon_in, nlat_in, npts_out, lon_in, lat_in, lon_out, lat_out, - mask_in, i_in, j_in, l_out, xgrid_area, xgrid_clon, xgrid_clat); - - return nxgrid; -} - -int create_xgrid_great_circle_ug(const int *nlon_in, const int *nlat_in, const int *npts_out, - const double *lon_in, const double *lat_in, const double *lon_out, const double *lat_out, - const double *mask_in, int *i_in, int *j_in, int *l_out, - double *xgrid_area, double *xgrid_clon, double *xgrid_clat) -{ - - int nx1, ny1, npts2, nx1p, ny1p, nxgrid, n1_in, n2_in, nv; - int n0, n1, n2, n3, i1, j1, l2; - double x1_in[MV], y1_in[MV], z1_in[MV]; - double x2_in[MV], y2_in[MV], z2_in[MV]; - double x_out[MV], y_out[MV], z_out[MV]; - double *x1=NULL, *y1=NULL, *z1=NULL; - double *x2=NULL, *y2=NULL, *z2=NULL; - - double *area1, *area2, min_area; - - nx1 = *nlon_in; - ny1 = *nlat_in; - nv = 4; - npts2 = *npts_out; - nxgrid = 0; - nx1p = nx1 + 1; - ny1p = ny1 + 1; - - /* first convert lon-lat to cartesian coordinates */ - x1 = (double *)malloc(nx1p*ny1p*sizeof(double)); - y1 = (double *)malloc(nx1p*ny1p*sizeof(double)); - z1 = (double *)malloc(nx1p*ny1p*sizeof(double)); - x2 = (double *)malloc(npts2*nv*sizeof(double)); - y2 = (double *)malloc(npts2*nv*sizeof(double)); - z2 = (double *)malloc(npts2*nv*sizeof(double)); - - latlon2xyz(nx1p*ny1p, lon_in, lat_in, x1, y1, z1); - latlon2xyz(npts2*nv, lon_out, lat_out, x2, y2, z2); - - area1 = (double *)malloc(nx1*ny1*sizeof(double)); - area2 = (double *)malloc(npts2*sizeof(double)); - get_grid_great_circle_area(nlon_in, nlat_in, lon_in, lat_in, area1); - get_grid_great_circle_area_ug(npts_out, lon_out, lat_out, area2); - n1_in = 4; - n2_in = 4; - - for(j1=0; j1 MASK_THRESH ) { - /* clockwise */ - n0 = j1*nx1p+i1; n1 = (j1+1)*nx1p+i1; - n2 = (j1+1)*nx1p+i1+1; n3 = j1*nx1p+i1+1; - x1_in[0] = x1[n0]; y1_in[0] = y1[n0]; z1_in[0] = z1[n0]; - x1_in[1] = x1[n1]; y1_in[1] = y1[n1]; z1_in[1] = z1[n1]; - x1_in[2] = x1[n2]; y1_in[2] = y1[n2]; z1_in[2] = z1[n2]; - x1_in[3] = x1[n3]; y1_in[3] = y1[n3]; z1_in[3] = z1[n3]; - - for(l2=0; l2 0) { - xarea = great_circle_area ( n_out, x_out, y_out, z_out ) * mask_in[j1*nx1+i1]; - min_area = min(area1[j1*nx1+i1], area2[l2]); - if( xarea/min_area > AREA_RATIO_THRESH ) { -#ifdef debug_test_create_xgrid - printf("(l2)=(%d,%d), (i1,j1)=(%d,%d), xarea=%g\n", l2, i1, j1, xarea); -#endif - xgrid_area[nxgrid] = xarea; - xgrid_clon[nxgrid] = 0; /*z1l: will be developed very soon */ - xgrid_clat[nxgrid] = 0; - i_in[nxgrid] = i1; - j_in[nxgrid] = j1; - l_out[nxgrid] = l2; - ++nxgrid; - if(nxgrid > MAXXGRID) error_handler("nxgrid is greater than MAXXGRID, increase MAXXGRID"); - } - } - } - } - - - free(area1); - free(area2); - - free(x1); - free(y1); - free(z1); - free(x2); - free(y2); - free(z2); - - return nxgrid; - -}/* create_xgrid_great_circle_ug */ - - -/******************************************************************************* - Revise Sutherland-Hodgeman algorithm to find the vertices of the overlapping - between any two grid boxes. It return the number of vertices for the exchange grid. - Each edge of grid box is a part of great circle. All the points are cartesian - coordinates. Here we are assuming each polygon is convex. - RANGE_CHECK_CRITERIA is used to determine if the two grid boxes are possible to be - overlap. The size should be between 0 and 0.5. The larger the range_check_criteria, - the more expensive of the computatioin. When the value is close to 0, - some small exchange grid might be lost. Suggest to use value 0.05 for C48. -*******************************************************************************/ - -int clip_2dx2d_great_circle(const double x1_in[], const double y1_in[], const double z1_in[], int n1_in, - const double x2_in[], const double y2_in[], const double z2_in [], int n2_in, - double x_out[], double y_out[], double z_out[]) -{ - struct Node *grid1List=NULL; - struct Node *grid2List=NULL; - struct Node *intersectList=NULL; - struct Node *polyList=NULL; - struct Node *curList=NULL; - struct Node *firstIntersect=NULL, *curIntersect=NULL; - struct Node *temp1=NULL, *temp2=NULL, *temp=NULL; - - int i1, i2, i1p, i2p, i2p2, npts1, npts2; - int nintersect, n_out; - int maxiter1, maxiter2, iter1, iter2; - int found1, found2, curListNum; - int has_inbound, inbound; - double pt1[MV][3], pt2[MV][3]; - double *p1_0=NULL, *p1_1=NULL; - double *p2_0=NULL, *p2_1=NULL, *p2_2=NULL; - double intersect[3]; - double u1, u2; - double min_x1, max_x1, min_y1, max_y1, min_z1, max_z1; - double min_x2, max_x2, min_y2, max_y2, min_z2, max_z2; - - - /* first check the min and max of (x1_in, y1_in, z1_in) with (x2_in, y2_in, z2_in) */ - min_x1 = minval_double(n1_in, x1_in); - max_x2 = maxval_double(n2_in, x2_in); - if(min_x1 >= max_x2+RANGE_CHECK_CRITERIA) return 0; - max_x1 = maxval_double(n1_in, x1_in); - min_x2 = minval_double(n2_in, x2_in); - if(min_x2 >= max_x1+RANGE_CHECK_CRITERIA) return 0; - - min_y1 = minval_double(n1_in, y1_in); - max_y2 = maxval_double(n2_in, y2_in); - if(min_y1 >= max_y2+RANGE_CHECK_CRITERIA) return 0; - max_y1 = maxval_double(n1_in, y1_in); - min_y2 = minval_double(n2_in, y2_in); - if(min_y2 >= max_y1+RANGE_CHECK_CRITERIA) return 0; - - min_z1 = minval_double(n1_in, z1_in); - max_z2 = maxval_double(n2_in, z2_in); - if(min_z1 >= max_z2+RANGE_CHECK_CRITERIA) return 0; - max_z1 = maxval_double(n1_in, z1_in); - min_z2 = minval_double(n2_in, z2_in); - if(min_z2 >= max_z1+RANGE_CHECK_CRITERIA) return 0; - - rewindList(); - - grid1List = getNext(); - grid2List = getNext(); - intersectList = getNext(); - polyList = getNext(); - - /* insert points into SubjList and ClipList */ - for(i1=0; i1isInside = 1; - else - temp->isInside = 0; - temp = getNextNode(temp); - } - -#ifdef debug_test_create_xgrid - printf("\nNOTE from clip_2dx2d_great_circle: begin to set inside value of grid2List\n"); -#endif - /* check if grid2List is inside grid1List */ - temp = grid2List; - - while(temp) { - if(insidePolygon(temp, grid1List)) - temp->isInside = 1; - else - temp->isInside = 0; - temp = getNextNode(temp); - } - - /* make sure the grid box is clockwise */ - - /*make sure each polygon is convex, which is equivalent that the great_circle_area is positive */ - if( gridArea(grid1List) <= 0 ) - error_handler("create_xgrid.c(clip_2dx2d_great_circle): grid box 1 is not convex"); - if( gridArea(grid2List) <= 0 ) - error_handler("create_xgrid.c(clip_2dx2d_great_circle): grid box 2 is not convex"); - -#ifdef debug_test_create_xgrid - printNode(grid1List, "grid1List"); - printNode(grid2List, "grid2List"); -#endif - - /* get the coordinates from grid1List and grid2List. - Please not npts1 might not equal n1_in, npts2 might not equal n2_in because of pole - */ - - temp = grid1List; - for(i1=0; i1Next; - } - temp = grid2List; - for(i2=0; i2Next; - } - - firstIntersect=getNext(); - curIntersect = getNext(); - -#ifdef debug_test_create_xgrid - printf("\n\n************************ Start line_intersect_2D_3D ******************************\n"); -#endif - /* first find all the intersection points */ - nintersect = 0; - for(i1=0; i1 1) { - getFirstInbound(intersectList, firstIntersect); - if(firstIntersect->initialized) { - has_inbound = 1; - } - } - - /* when has_inbound == 0, get the grid1List and grid2List */ - if( !has_inbound && nintersect > 1) { - setInbound(intersectList, grid1List); - getFirstInbound(intersectList, firstIntersect); - if(firstIntersect->initialized) has_inbound = 1; - } - - /* if has_inbound = 1, find the overlapping */ - n_out = 0; - - if(has_inbound) { - maxiter1 = nintersect; -#ifdef debug_test_create_xgrid - printf("\nNOTE from clip_2dx2d_great_circle: number of intersect is %d\n", nintersect); - printf("\n size of grid2List is %d, size of grid1List is %d\n", length(grid2List), length(grid1List)); - printNode(intersectList, "beginning intersection list"); - printNode(grid2List, "beginning clip list"); - printNode(grid1List, "beginning subj list"); - printf("\n************************ End line_intersect_2D_3D **********************************\n\n"); -#endif - temp1 = getNode(grid1List, *firstIntersect); - if( temp1 == NULL) { - double lon[10], lat[10]; - int i; - xyz2latlon(n1_in, x1_in, y1_in, z1_in, lon, lat); - for(i=0; i< n1_in; i++) printf("lon1 = %g, lat1 = %g\n", lon[i]*R2D, lat[i]*R2D); - printf("\n"); - xyz2latlon(n2_in, x2_in, y2_in, z2_in, lon, lat); - for(i=0; i< n2_in; i++) printf("lon2 = %g, lat2 = %g\n", lon[i]*R2D, lat[i]*R2D); - printf("\n"); - - error_handler("firstIntersect is not in the grid1List"); - } - addNode(polyList, *firstIntersect); - nintersect--; -#ifdef debug_test_create_xgrid - printNode(polyList, "polyList at stage 1"); -#endif - - /* Loop over the grid1List and grid2List to find again the firstIntersect */ - curList = grid1List; - curListNum = 0; - - /* Loop through curList to find the next intersection, the loop will end - when come back to firstIntersect - */ - copyNode(curIntersect, *firstIntersect); - iter1 = 0; - found1 = 0; - - while( iter1 < maxiter1 ) { -#ifdef debug_test_create_xgrid - printf("\n----------- At iteration = %d\n\n", iter1+1 ); - printNode(curIntersect, "curIntersect at the begining of iter1"); -#endif - /* find the curIntersect in curList and get the next intersection points */ - temp1 = getNode(curList, *curIntersect); - temp2 = temp1->Next; - if( temp2 == NULL ) temp2 = curList; - - maxiter2 = length(curList); - found2 = 0; - iter2 = 0; - /* Loop until find the next intersection */ - while( iter2 < maxiter2 ) { - int temp2IsIntersect; - - temp2IsIntersect = 0; - if( isIntersect( *temp2 ) ) { /* copy the point and switch to the grid2List */ - struct Node *temp3; - - /* first check if temp2 is the firstIntersect */ - if( sameNode( *temp2, *firstIntersect) ) { - found1 = 1; - break; - } - - temp3 = temp2->Next; - if( temp3 == NULL) temp3 = curList; - if( temp3 == NULL) error_handler("creat_xgrid.c: temp3 can not be NULL"); - found2 = 1; - /* if next node is inside or an intersection, - need to keep on curList - */ - temp2IsIntersect = 1; - if( isIntersect(*temp3) || (temp3->isInside == 1) ) found2 = 0; - } - if(found2) { - copyNode(curIntersect, *temp2); - break; - } - else { - addNode(polyList, *temp2); -#ifdef debug_test_create_xgrid - printNode(polyList, "polyList at stage 2"); -#endif - if(temp2IsIntersect) { - nintersect--; - } - } - temp2 = temp2->Next; - if( temp2 == NULL ) temp2 = curList; - iter2 ++; - } - if(found1) break; - - if( !found2 ) error_handler(" not found the next intersection "); - - /* if find the first intersection, the poly found */ - if( sameNode( *curIntersect, *firstIntersect) ) { - found1 = 1; - break; - } - - /* add curIntersect to polyList and remove it from intersectList and curList */ - addNode(polyList, *curIntersect); -#ifdef debug_test_create_xgrid - printNode(polyList, "polyList at stage 3"); -#endif - nintersect--; - - - /* switch curList */ - if( curListNum == 0) { - curList = grid2List; - curListNum = 1; - } - else { - curList = grid1List; - curListNum = 0; - } - iter1++; - } - if(!found1) error_handler("not return back to the first intersection"); - - /* currently we are only clipping convex polygon to convex polygon */ - if( nintersect > 0) error_handler("After clipping, nintersect should be 0"); - - /* copy the polygon to x_out, y_out, z_out */ - temp1 = polyList; - while (temp1 != NULL) { - getCoordinate(*temp1, x_out+n_out, y_out+n_out, z_out+n_out); - temp1 = temp1->Next; - n_out++; - } - - /* if(n_out < 3) error_handler(" The clipped region has < 3 vertices"); */ - if( n_out < 3) n_out = 0; -#ifdef debug_test_create_xgrid - printNode(polyList, "polyList after clipping"); -#endif - } - - /* check if grid1 is inside grid2 */ - if(n_out==0){ - /* first check number of points in grid1 is inside grid2 */ - int n, n1in2; - /* One possible is that grid1List is inside grid2List */ -#ifdef debug_test_create_xgrid - printf("\nNOTE from clip_2dx2d_great_circle: check if grid1 is inside grid2\n"); -#endif - n1in2 = 0; - temp = grid1List; - while(temp) { - if(temp->intersect != 1) { -#ifdef debug_test_create_xgrid - printf("grid1->isInside = %d\n", temp->isInside); -#endif - if( temp->isInside == 1) n1in2++; - } - temp = getNextNode(temp); - } - if(npts1==n1in2) { /* grid1 is inside grid2 */ - n_out = npts1; - n = 0; - temp = grid1List; - while( temp ) { - getCoordinate(*temp, &x_out[n], &y_out[n], &z_out[n]); - n++; - temp = getNextNode(temp); - } - } - if(n_out>0) return n_out; - } - - /* check if grid2List is inside grid1List */ - if(n_out ==0){ - int n, n2in1; -#ifdef debug_test_create_xgrid - printf("\nNOTE from clip_2dx2d_great_circle: check if grid2 is inside grid1\n"); -#endif - - temp = grid2List; - n2in1 = 0; - while(temp) { - if(temp->intersect != 1) { -#ifdef debug_test_create_xgrid - printf("grid2->isInside = %d\n", temp->isInside); -#endif - if( temp->isInside == 1) n2in1++; - } - temp = getNextNode(temp); - } - - if(npts2==n2in1) { /* grid2 is inside grid1 */ - n_out = npts2; - n = 0; - temp = grid2List; - while( temp ) { - getCoordinate(*temp, &x_out[n], &y_out[n], &z_out[n]); - n++; - temp = getNextNode(temp); - } - - } - } - - - return n_out; -} - - -/* Intersects between the line a and the seqment s - where both line and segment are great circle lines on the sphere represented by - 3D cartesian points. - [sin sout] are the ends of a line segment - returns true if the lines could be intersected, false otherwise. - inbound means the direction of (a1,a2) go inside or outside of (q1,q2,q3) -*/ - -int line_intersect_2D_3D(double *a1, double *a2, double *q1, double *q2, double *q3, - double *intersect, double *u_a, double *u_q, int *inbound){ - - /* Do this intersection by reprsenting the line a1 to a2 as a plane through the - two line points and the origin of the sphere (0,0,0). This is the - definition of a great circle arc. - */ - double plane[9]; - double plane_p[2]; - double u; - double p1[3], v1[3], v2[3]; - double c1[3], c2[3], c3[3]; - double coincident, sense, norm; - int i; - int is_inter1, is_inter2; - - *inbound = 0; - - /* first check if any vertices are the same */ - if(samePoint(a1[0], a1[1], a1[2], q1[0], q1[1], q1[2])) { - *u_a = 0; - *u_q = 0; - intersect[0] = a1[0]; - intersect[1] = a1[1]; - intersect[2] = a1[2]; -#ifdef debug_test_create_xgrid - printf("\nNOTE from line_intersect_2D_3D: u_a = %19.15f, u_q=%19.15f, inbound=%d\n", *u_a, *u_q, *inbound); -#endif - return 1; - } - else if (samePoint(a1[0], a1[1], a1[2], q2[0], q2[1], q2[2])) { - *u_a = 0; - *u_q = 1; - intersect[0] = a1[0]; - intersect[1] = a1[1]; - intersect[2] = a1[2]; -#ifdef debug_test_create_xgrid - printf("\nNOTE from line_intersect_2D_3D: u_a = %19.15f, u_q=%19.15f, inbound=%d\n", *u_a, *u_q, *inbound); -#endif - return 1; - } - else if(samePoint(a2[0], a2[1], a2[2], q1[0], q1[1], q1[2])) { -#ifdef debug_test_create_xgrid - printf("\nNOTE from line_intersect_2D_3D: u_a = %19.15f, u_q=%19.15f, inbound=%d\n", *u_a, *u_q, *inbound); -#endif - *u_a = 1; - *u_q = 0; - intersect[0] = a2[0]; - intersect[1] = a2[1]; - intersect[2] = a2[2]; - return 1; - } - else if (samePoint(a2[0], a2[1], a2[2], q2[0], q2[1], q2[2])) { -#ifdef debug_test_create_xgrid - printf("\nNOTE from line_intersect_2D_3D: u_a = %19.15f, u_q=%19.15f, inbound=%d\n", *u_a, *u_q, *inbound); -#endif - *u_a = 1; - *u_q = 1; - intersect[0] = a2[0]; - intersect[1] = a2[1]; - intersect[2] = a2[2]; - return 1; - } - - - /* Load points defining plane into variable (these are supposed to be in counterclockwise order) */ - plane[0]=q1[0]; - plane[1]=q1[1]; - plane[2]=q1[2]; - plane[3]=q2[0]; - plane[4]=q2[1]; - plane[5]=q2[2]; - plane[6]=0.0; - plane[7]=0.0; - plane[8]=0.0; - - /* Intersect the segment with the plane */ - is_inter1 = intersect_tri_with_line(plane, a1, a2, plane_p, u_a); - - if(!is_inter1) - return 0; - - if(fabs(*u_a) < EPSLN8) *u_a = 0; - if(fabs(*u_a-1) < EPSLN8) *u_a = 1; - - -#ifdef debug_test_create_xgrid - printf("\nNOTE from line_intersect_2D_3D: u_a = %19.15f\n", *u_a); -#endif - - - if( (*u_a < 0) || (*u_a > 1) ) return 0; - - /* Load points defining plane into variable (these are supposed to be in counterclockwise order) */ - plane[0]=a1[0]; - plane[1]=a1[1]; - plane[2]=a1[2]; - plane[3]=a2[0]; - plane[4]=a2[1]; - plane[5]=a2[2]; - plane[6]=0.0; - plane[7]=0.0; - plane[8]=0.0; - - /* Intersect the segment with the plane */ - is_inter2 = intersect_tri_with_line(plane, q1, q2, plane_p, u_q); - - if(!is_inter2) - return 0; - - if(fabs(*u_q) < EPSLN8) *u_q = 0; - if(fabs(*u_q-1) < EPSLN8) *u_q = 1; -#ifdef debug_test_create_xgrid - printf("\nNOTE from line_intersect_2D_3D: u_q = %19.15f\n", *u_q); -#endif - - - if( (*u_q < 0) || (*u_q > 1) ) return 0; - - u =*u_a; - - /* The two planes are coincidental */ - vect_cross(a1, a2, c1); - vect_cross(q1, q2, c2); - vect_cross(c1, c2, c3); - coincident = metric(c3); - - if(fabs(coincident) < EPSLN30) return 0; - - /* Calculate point of intersection */ - intersect[0]=a1[0] + u*(a2[0]-a1[0]); - intersect[1]=a1[1] + u*(a2[1]-a1[1]); - intersect[2]=a1[2] + u*(a2[2]-a1[2]); - - norm = metric( intersect ); - for(i = 0; i < 3; i ++) intersect[i] /= norm; - - /* when u_q =0 or u_q =1, the following could not decide the inbound value */ - if(*u_q != 0 && *u_q != 1){ - - p1[0] = a2[0]-a1[0]; - p1[1] = a2[1]-a1[1]; - p1[2] = a2[2]-a1[2]; - v1[0] = q2[0]-q1[0]; - v1[1] = q2[1]-q1[1]; - v1[2] = q2[2]-q1[2]; - v2[0] = q3[0]-q2[0]; - v2[1] = q3[1]-q2[1]; - v2[2] = q3[2]-q2[2]; - - vect_cross(v1, v2, c1); - vect_cross(v1, p1, c2); - - sense = dot(c1, c2); - *inbound = 1; - if(sense > 0) *inbound = 2; /* v1 going into v2 in CCW sense */ - } -#ifdef debug_test_create_xgrid - printf("\nNOTE from line_intersect_2D_3D: inbound=%d\n", *inbound); -#endif - - return 1; -} - - -/*------------------------------------------------------------------------------ - double poly_ctrlat(const double x[], const double y[], int n) - This routine is used to calculate the latitude of the centroid - ---------------------------------------------------------------------------*/ - -double poly_ctrlat(const double x[], const double y[], int n) -{ - double ctrlat = 0.0; - int i; - - for (i=0;i M_PI) dx = dx - 2.0*M_PI; - if(dx < -M_PI) dx = dx + 2.0*M_PI; - - if ( fabs(hdy)< SMALL_VALUE ) /* cheap area calculation along latitude */ - ctrlat -= dx*(2*cos(avg_y) + lat2*sin(avg_y) - cos(lat1) ); - else - ctrlat -= dx*( (sin(hdy)/hdy)*(2*cos(avg_y) + lat2*sin(avg_y)) - cos(lat1) ); - } - return (ctrlat*RADIUS*RADIUS); -} /* poly_ctrlat */ - -/*------------------------------------------------------------------------------ - double poly_ctrlon(const double x[], const double y[], int n, double clon) - This routine is used to calculate the lontitude of the centroid. - ---------------------------------------------------------------------------*/ -double poly_ctrlon(const double x[], const double y[], int n, double clon) -{ - double ctrlon = 0.0; - int i; - - for (i=0;i M_PI) dphi = dphi - 2.0*M_PI; - if(dphi < -M_PI) dphi = dphi + 2.0*M_PI; - dphi1 = phi1 - clon; - if( dphi1 > M_PI) dphi1 -= 2.0*M_PI; - if( dphi1 <-M_PI) dphi1 += 2.0*M_PI; - dphi2 = phi2 -clon; - if( dphi2 > M_PI) dphi2 -= 2.0*M_PI; - if( dphi2 <-M_PI) dphi2 += 2.0*M_PI; - - if(fabs(dphi2 -dphi1) < M_PI) { - ctrlon -= dphi * (dphi1*f1+dphi2*f2)/2.0; - } - else { - if(dphi1 > 0.0) - fac = M_PI; - else - fac = -M_PI; - fint = f1 + (f2-f1)*(fac-dphi1)/fabs(dphi); - ctrlon -= 0.5*dphi1*(dphi1-fac)*f1 - 0.5*dphi2*(dphi2+fac)*f2 - + 0.5*fac*(dphi1+dphi2)*fint; - } - - } - return (ctrlon*RADIUS*RADIUS); -} /* poly_ctrlon */ - -/* ----------------------------------------------------------------------------- - double box_ctrlat(double ll_lon, double ll_lat, double ur_lon, double ur_lat) - This routine is used to calculate the latitude of the centroid. - ---------------------------------------------------------------------------*/ -double box_ctrlat(double ll_lon, double ll_lat, double ur_lon, double ur_lat) -{ - double dphi = ur_lon-ll_lon; - double ctrlat; - - if(dphi > M_PI) dphi = dphi - 2.0*M_PI; - if(dphi < -M_PI) dphi = dphi + 2.0*M_PI; - ctrlat = dphi*(cos(ur_lat) + ur_lat*sin(ur_lat)-(cos(ll_lat) + ll_lat*sin(ll_lat))); - return (ctrlat*RADIUS*RADIUS); -} /* box_ctrlat */ - -/*------------------------------------------------------------------------------ - double box_ctrlon(double ll_lon, double ll_lat, double ur_lon, double ur_lat, double clon) - This routine is used to calculate the lontitude of the centroid - ----------------------------------------------------------------------------*/ -double box_ctrlon(double ll_lon, double ll_lat, double ur_lon, double ur_lat, double clon) -{ - double phi1, phi2, dphi, lat1, lat2, dphi1, dphi2; - double f1, f2, fac, fint; - double ctrlon = 0.0; - int i; - for( i =0; i<2; i++) { - if(i == 0) { - phi1 = ur_lon; - phi2 = ll_lon; - lat1 = lat2 = ll_lat; - } - else { - phi1 = ll_lon; - phi2 = ur_lon; - lat1 = lat2 = ur_lat; - } - dphi = phi1 - phi2; - f1 = 0.5*(cos(lat1)*sin(lat1)+lat1); - f2 = 0.5*(cos(lat2)*sin(lat2)+lat2); - - if(dphi > M_PI) dphi = dphi - 2.0*M_PI; - if(dphi < -M_PI) dphi = dphi + 2.0*M_PI; - /* make sure the center is in the same grid box. */ - dphi1 = phi1 - clon; - if( dphi1 > M_PI) dphi1 -= 2.0*M_PI; - if( dphi1 <-M_PI) dphi1 += 2.0*M_PI; - dphi2 = phi2 -clon; - if( dphi2 > M_PI) dphi2 -= 2.0*M_PI; - if( dphi2 <-M_PI) dphi2 += 2.0*M_PI; - - if(fabs(dphi2 -dphi1) < M_PI) { - ctrlon -= dphi * (dphi1*f1+dphi2*f2)/2.0; - } - else { - if(dphi1 > 0.0) - fac = M_PI; - else - fac = -M_PI; - fint = f1 + (f2-f1)*(fac-dphi1)/fabs(dphi); - ctrlon -= 0.5*dphi1*(dphi1-fac)*f1 - 0.5*dphi2*(dphi2+fac)*f2 - + 0.5*fac*(dphi1+dphi2)*fint; - } - } - return (ctrlon*RADIUS*RADIUS); -} /* box_ctrlon */ - -/******************************************************************************* - double grid_box_radius(double *x, double *y, double *z, int n); - Find the radius of the grid box, the radius is defined the - maximum distance between any two vertices -*******************************************************************************/ -double grid_box_radius(const double *x, const double *y, const double *z, int n) -{ - double radius; - int i, j; - - radius = 0; - for(i=0; i is - the outward edge normal from vertex to . is the vector - from to . - if Inner produce * > 0, outside, otherwise inside. - inner product value = 0 also treate as inside. -*******************************************************************************/ -int inside_edge(double x0, double y0, double x1, double y1, double x, double y) -{ - const double SMALL = 1.e-12; - double product; - - product = ( x-x0 )*(y1-y0) + (x0-x1)*(y-y0); - return (product<=SMALL) ? 1:0; - -} /* inside_edge */ - - -/* The following is a test program to test subroutines in create_xgrid.c */ - -#ifdef test_create_xgrid - -#include "create_xgrid.h" -#include - -#define D2R (M_PI/180) -#define R2D (180/M_PI) -#define MAXPOINT 1000 - -int main(int argc, char* argv[]) -{ - - double lon1_in[MAXPOINT], lat1_in[MAXPOINT]; - double lon2_in[MAXPOINT], lat2_in[MAXPOINT]; - double x1_in[MAXPOINT], y1_in[MAXPOINT], z1_in[MAXPOINT]; - double x2_in[MAXPOINT], y2_in[MAXPOINT], z2_in[MAXPOINT]; - double lon_out[20], lat_out[20]; - double x_out[20], y_out[20], z_out[20]; - int n1_in, n2_in, n_out, i, j; - int nlon1=0, nlat1=0, nlon2=0, nlat2=0; - int n; - int ntest = 11; - - - for(n=11; n<=ntest; n++) { - - switch (n) { - case 1: - /**************************************************************** - - test clip_2dx2d_great_cirle case 1: - box 1: (20,10), (20,12), (22,12), (22,10) - box 2: (21,11), (21,14), (24,14), (24,11) - out : (21, 12.0018), (22, 12), (22, 11.0033), (21, 11) - - ****************************************************************/ - n1_in = 4; n2_in = 4; - /* first a simple lat-lon grid box to clip another lat-lon grid box */ - lon1_in[0] = 20; lat1_in[0] = 10; - lon1_in[1] = 20; lat1_in[1] = 12; - lon1_in[2] = 22; lat1_in[2] = 12; - lon1_in[3] = 22; lat1_in[3] = 10; - lon2_in[0] = 21; lat2_in[0] = 11; - lon2_in[1] = 21; lat2_in[1] = 14; - lon2_in[2] = 24; lat2_in[2] = 14; - lon2_in[3] = 24; lat2_in[3] = 11; - break; - - case 2: - /**************************************************************** - - test clip_2dx2d_great_cirle case 2: two identical box - box 1: (20,10), (20,12), (22,12), (22,10) - box 2: (20,10), (20,12), (22,12), (22,10) - out : (20,10), (20,12), (22,12), (22,10) - - ****************************************************************/ - lon1_in[0] = 20; lat1_in[0] = 10; - lon1_in[1] = 20; lat1_in[1] = 12; - lon1_in[2] = 22; lat1_in[2] = 12; - lon1_in[3] = 22; lat1_in[3] = 10; - - for(i=0; i 10 ) { - int nxgrid; - int *i1, *j1, *i2, *j2; - double *xarea, *xclon, *xclat, *mask1; - - mask1 = (double *)malloc(nlon1*nlat1*sizeof(double)); - i1 = (int *)malloc(MAXXGRID*sizeof(int)); - j1 = (int *)malloc(MAXXGRID*sizeof(int)); - i2 = (int *)malloc(MAXXGRID*sizeof(int)); - j2 = (int *)malloc(MAXXGRID*sizeof(int)); - xarea = (double *)malloc(MAXXGRID*sizeof(double)); - xclon = (double *)malloc(MAXXGRID*sizeof(double)); - xclat = (double *)malloc(MAXXGRID*sizeof(double)); - - for(i=0; i. -!*********************************************************************** -!> @defgroup grid_mod grid_mod -!> @ingroup mosaic -!> @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 -use fms_io_mod, only : get_great_circle_algorithm, get_global_att_value, string, & - field_exist, field_size, read_data -use mosaic_mod, only : get_mosaic_ntiles, get_mosaic_xgrid_size, get_mosaic_grid_sizes, & - get_mosaic_xgrid, calc_mosaic_grid_area, calc_mosaic_grid_great_circle_area - -! the following two use statement are only needed for define_cube_mosaic -use mpp_domains_mod, only : domain2d, mpp_define_mosaic, mpp_get_compute_domain, & - mpp_get_global_domain, domainUG, mpp_pass_SG_to_UG -use mosaic_mod, only : get_mosaic_ncontacts, get_mosaic_contact - -implicit none;private - -! ==== public interfaces ===================================================== -! grid dimension inquiry subroutines -public :: get_grid_ntiles -public :: get_grid_size -! grid geometry inquiry subroutines -public :: get_grid_cell_centers -public :: get_grid_cell_vertices -! grid area inquiry subroutines -public :: get_grid_cell_area -public :: get_grid_comp_area -! decompose cubed sphere domains -- probably does not belong here, but it should -! be in some place available for component models -public :: define_cube_mosaic -! ==== end of public interfaces ============================================== - -!> returns horizontal sizes of the grid -!> @ingroup grid_mod -interface get_grid_size - module procedure get_grid_size_for_all_tiles - module procedure get_grid_size_for_one_tile -end interface -!> returns number of tiles -!> @ingroup grid_mod -interface get_grid_cell_vertices - module procedure get_grid_cell_vertices_1D - module procedure get_grid_cell_vertices_2D - module procedure get_grid_cell_vertices_UG -end interface - -!> @ingroup grid_mod -interface get_grid_cell_centers - module procedure get_grid_cell_centers_1D - module procedure get_grid_cell_centers_2D - module procedure get_grid_cell_centers_UG -end interface - -!> @ingroup grid_mod -interface get_grid_cell_area - module procedure get_grid_cell_area_SG - module procedure get_grid_cell_area_UG -end interface get_grid_cell_area - -!> @ingroup grid_mod -interface get_grid_comp_area - module procedure get_grid_comp_area_SG - module procedure get_grid_comp_area_UG -end interface get_grid_comp_area - -!> @addtogroup grid_mod -!> @{ - -! ==== module constants ====================================================== -character(len=*), parameter :: & - module_name = 'grid_mod' - -! Include variable "version" to be written to log file. -#include - -character(len=*), parameter :: & - grid_dir = 'INPUT/', & !< root directory for all grid files - grid_file = 'INPUT/grid_spec.nc' !< name of the grid spec file - -integer, parameter :: & - MAX_NAME = 256, & !< max length of the variable names - MAX_FILE = 1024, & !< max length of the file names - VERSION_0 = 0, & - VERSION_1 = 1, & - VERSION_2 = 2 - -integer, parameter :: BUFSIZE = 1048576 !< This is used to control memory usage in get_grid_comp_area - !! We may change this to a namelist variable is needed. - -! ==== module variables ====================================================== -integer :: grid_version = -1 -logical :: great_circle_algorithm = .FALSE. -logical :: first_call = .TRUE. - - -contains - -function get_grid_version() - integer :: get_grid_version - - if(first_call) then - great_circle_algorithm = get_great_circle_algorithm() - first_call = .FALSE. - endif - - if(grid_version<0) then - if(field_exist(grid_file, 'geolon_t')) then - grid_version = VERSION_0 - else if(field_exist(grid_file, 'x_T')) then - grid_version = VERSION_1 - else if(field_exist(grid_file, 'ocn_mosaic_file') ) then - grid_version = VERSION_2 - else - call mpp_error(FATAL, module_name//& - & '/get_grid_version: Can''t determine the version of the grid spec:'// & - & ' none of "x_T", "geolon_t", or "ocn_mosaic_file" exist in file "'//trim(grid_file)//'"') - endif - endif - get_grid_version = grid_version -end function get_grid_version - - -! ============================================================================ -! ============================================================================ -!> Returns number of tiles for a given component -subroutine get_grid_ntiles(component,ntiles) - character(len=*) :: component - integer, intent(out) :: ntiles - - ! local vars - character(len=MAX_FILE) :: component_mosaic - - select case (get_grid_version()) - case(VERSION_0,VERSION_1) - ntiles = 1 - case(VERSION_2) - call read_data(grid_file,trim(lowercase(component))//'_mosaic_file',component_mosaic) - ntiles = get_mosaic_ntiles(grid_dir//trim(component_mosaic)) - end select -end subroutine get_grid_ntiles - - -! ============================================================================ -! ============================================================================ -!> Returns size of the grid for each of the tiles -subroutine get_grid_size_for_all_tiles(component,nx,ny) - character(len=*) :: component - integer, intent(inout) :: nx(:),ny(:) - - ! local vars - integer :: siz(4) ! for the size of external fields - character(len=MAX_NAME) :: varname1, varname2 - character(len=MAX_FILE) :: component_mosaic - - varname1 = 'AREA_'//trim(uppercase(component)) - varname2 = trim(lowercase(component))//'_mosaic_file' - - select case (get_grid_version()) - case(VERSION_0,VERSION_1) - call field_size(grid_file, varname1, siz) - nx(1) = siz(1); ny(1)=siz(2) - case(VERSION_2) ! mosaic file - call read_data(grid_file,varname2, component_mosaic) - call get_mosaic_grid_sizes(grid_dir//trim(component_mosaic),nx,ny) - end select -end subroutine get_grid_size_for_all_tiles - - -! ============================================================================ -! ============================================================================ -!> Returns size of the grid for one of the tiles -subroutine get_grid_size_for_one_tile(component,tile,nx,ny) - character(len=*) :: component - integer, intent(in) :: tile - integer, intent(inout) :: nx,ny - - ! local vars - integer, allocatable :: nnx(:), nny(:) - integer :: ntiles - - call get_grid_ntiles(component, ntiles) - if(tile>0.and.tile<=ntiles) then - allocate(nnx(ntiles),nny(ntiles)) - call get_grid_size_for_all_tiles(component,nnx,nny) - nx = nnx(tile); ny = nny(tile) - deallocate(nnx,nny) - else - call mpp_error(FATAL, 'get_grid_size: requested tile index '// & - & trim(string(tile))//' is out of bounds (1:'//trim(string(ntiles))//')') - endif -end subroutine get_grid_size_for_one_tile - -! ============================================================================ -! ============================================================================ -!> Return grid cell area for the specified model component and tile -subroutine get_grid_cell_area_SG(component, tile, cellarea, domain) - character(len=*), intent(in) :: component - integer , intent(in) :: tile - real , intent(inout) :: cellarea(:,:) - type(domain2d) , intent(in), optional :: domain - - ! local vars - integer :: nlon, nlat - real, allocatable :: glonb(:,:), glatb(:,:) - - select case(get_grid_version()) - case(VERSION_0,VERSION_1) - select case(trim(component)) - case('LND') - call read_data(grid_file, 'AREA_LND_CELL', cellarea, & - no_domain=.not.present(domain), domain=domain) - case('ATM','OCN') - call read_data(grid_file, 'AREA_'//trim(uppercase(component)),cellarea,& - no_domain=.not.present(domain),domain=domain) - case default - call mpp_error(FATAL, module_name//'/get_grid_cell_area: Illegal component name "'//trim(component) & - & //'": must be one of ATM, LND, or OCN') - end select - ! convert area to m2 - cellarea = cellarea*4.*PI*radius**2 - case(VERSION_2) - if (present(domain)) then - call mpp_get_compute_domain(domain,xsize=nlon,ysize=nlat) - else - call get_grid_size(component,tile,nlon,nlat) - endif - allocate(glonb(nlon+1,nlat+1),glatb(nlon+1,nlat+1)) - call get_grid_cell_vertices(component, tile, glonb, glatb, domain) - if (great_circle_algorithm) then - call calc_mosaic_grid_great_circle_area(glonb*pi/180.0, glatb*pi/180.0, cellarea) - else - call calc_mosaic_grid_area(glonb*pi/180.0, glatb*pi/180.0, cellarea) - end if - deallocate(glonb,glatb) - end select - -end subroutine get_grid_cell_area_SG - -! ============================================================================ -! ============================================================================ -!> Get the area of the component per grid cell -subroutine get_grid_comp_area_SG(component,tile,area,domain) - character(len=*) :: component - integer, intent(in) :: tile - real, intent(inout) :: area(:,:) - type(domain2d), intent(in), optional :: domain - ! local vars - integer :: n_xgrid_files ! number of exchange grid files in the mosaic - integer :: siz(4), nxgrid - integer :: i,j,m,n - integer, allocatable :: i1(:), j1(:), i2(:), j2(:) - real, allocatable :: xgrid_area(:) - real, allocatable :: rmask(:,:) - character(len=MAX_NAME) :: & - xgrid_name, & ! name of the variable holding xgrid names - tile_name, & ! name of the tile - xgrid_file, & ! name of the current xgrid file - mosaic_name,& ! name of the mosaic - mosaic_file,& - tilefile - character(len=4096) :: attvalue - character(len=MAX_NAME), allocatable :: nest_tile_name(:) - integer :: is,ie,js,je ! boundaries of our domain - integer :: i0, j0 ! offsets for x and y, respectively - integer :: num_nest_tile, ntiles - logical :: is_nest - integer :: found_xgrid_files ! how many xgrid files we actually found in the grid spec - integer :: ibegin, iend, bsize, l - - select case (get_grid_version()) - case(VERSION_0,VERSION_1) - select case(component) - case('ATM') - call read_data(grid_file,'AREA_ATM',area, no_domain=.not.present(domain),domain=domain) - case('OCN') - allocate(rmask(size(area,1),size(area,2))) - call read_data(grid_file,'AREA_OCN',area, no_domain=.not.present(domain),domain=domain) - call read_data(grid_file,'wet', rmask,no_domain=.not.present(domain),domain=domain) - area = area*rmask - deallocate(rmask) - case('LND') - call read_data(grid_file,'AREA_LND',area,no_domain=.not.present(domain),domain=domain) - case default - call mpp_error(FATAL, module_name// & - & '/get_grid_comp_area: Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - end select - case(VERSION_2) ! mosaic gridspec - select case (component) - case ('ATM') - ! just read the grid cell area and return - call get_grid_cell_area(component,tile,area) - return - case ('LND') - xgrid_name = 'aXl_file' - call read_data(grid_file, 'lnd_mosaic', mosaic_name) - tile_name = trim(mosaic_name)//'_tile'//char(tile+ichar('0')) - case ('OCN') - xgrid_name = 'aXo_file' - call read_data(grid_file, 'ocn_mosaic', mosaic_name) - tile_name = trim(mosaic_name)//'_tile'//char(tile+ichar('0')) - case default - call mpp_error(FATAL, module_name// & - & '/get_grid_comp_area: Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') - end select - ! get the boundaries of the requested domain - if(present(domain)) then - call mpp_get_compute_domain(domain,is,ie,js,je) - i0 = 1-is ; j0=1-js - else - call get_grid_size(component,tile,ie,je) - is = 1 ; i0 = 0 - js = 1 ; j0 = 0 - endif - if (size(area,1)/=ie-is+1.or.size(area,2)/=je-js+1) & - call mpp_error(FATAL, module_name// & - & '/get_grid_comp_area: size of the output argument "area" is not consistent with the domain') - - ! find the nest tile - call read_data(grid_file, 'atm_mosaic', mosaic_name) - call read_data(grid_file,'atm_mosaic_file',mosaic_file) - mosaic_file = grid_dir//trim(mosaic_file) - ntiles = get_mosaic_ntiles(trim(mosaic_file)) - allocate(nest_tile_name(ntiles)) - num_nest_tile = 0 - do n = 1, ntiles - call read_data(mosaic_file, 'gridfiles', tilefile, level=n) - tilefile = grid_dir//trim(tilefile) - if( get_global_att_value(tilefile, "nest_grid", attvalue) ) then - if(trim(attvalue) == "TRUE") then - num_nest_tile = num_nest_tile + 1 - nest_tile_name(num_nest_tile) = trim(mosaic_name)//'_tile'//char(n+ichar('0')) - else if(trim(attvalue) .NE. "FALSE") then - call mpp_error(FATAL, module_name//'/get_grid_comp_area: value of global attribute nest_grid in file'// & - & trim(tilefile)//' should be TRUE of FALSE') - endif - end if - end do - area(:,:) = 0. - if(field_exist(grid_file,xgrid_name)) then - ! get the number of the exchange-grid files - call field_size(grid_file,xgrid_name,siz) - n_xgrid_files = siz(2) - found_xgrid_files = 0 - ! loop through all exchange grid files - do n = 1, n_xgrid_files - ! get the name of the current exchange grid file - call read_data(grid_file,xgrid_name,xgrid_file,level=n) - ! skip the rest of the loop if the name of the current tile isn't found - ! in the file name, but check this only if there is more than 1 tile - if(n_xgrid_files>1) then - if(index(xgrid_file,trim(tile_name))==0) cycle - endif - found_xgrid_files = found_xgrid_files + 1 - !---make sure the atmosphere grid is not a nested grid - is_nest = .false. - do m = 1, num_nest_tile - if(index(xgrid_file, trim(nest_tile_name(m))) .NE. 0) then - is_nest = .true. - exit - end if - end do - if(is_nest) cycle - - ! finally read the exchange grid - nxgrid = get_mosaic_xgrid_size(grid_dir//xgrid_file) - if(nxgrid < BUFSIZE) then - allocate(i1(nxgrid), j1(nxgrid), i2(nxgrid), j2(nxgrid), xgrid_area(nxgrid)) - else - allocate(i1(BUFSIZE), j1(BUFSIZE), i2(BUFSIZE), j2(BUFSIZE), xgrid_area(BUFSIZE)) - endif - ibegin = 1 - do l = 1,nxgrid,BUFSIZE - bsize = min(BUFSIZE, nxgrid-l+1) - iend = ibegin + bsize - 1 - call get_mosaic_xgrid(grid_dir//xgrid_file, i1(1:bsize), j1(1:bsize), i2(1:bsize), j2(1:bsize), & - xgrid_area(1:bsize), ibegin, iend) - ! and sum the exchange grid areas - do m = 1, bsize - i = i2(m); j = j2(m) - if (iie) cycle - if (jje) cycle - area(i+i0,j+j0) = area(i+i0,j+j0) + xgrid_area(m) - end do - ibegin = iend + 1 - enddo - deallocate(i1, j1, i2, j2, xgrid_area) - enddo - if (found_xgrid_files == 0) & - call mpp_error(FATAL, 'get_grid_comp_area: no xgrid files were found for component '// & - & trim(component)//' (mosaic name is '//trim(mosaic_name)//')') - - endif - deallocate(nest_tile_name) - end select ! version - ! convert area to m2 - area = area*4.*PI*radius**2 -end subroutine get_grid_comp_area_SG - -!====================================================================== -subroutine get_grid_cell_area_UG(component, tile, cellarea, SG_domain, UG_domain) - character(len=*), intent(in) :: component - integer , intent(in) :: tile - real , intent(inout) :: cellarea(:) - type(domain2d) , intent(in) :: SG_domain - type(domainUG) , intent(in) :: UG_domain - integer :: is, ie, js, je - real, allocatable :: SG_area(:,:) - - call mpp_get_compute_domain(SG_domain, is, ie, js, je) - allocate(SG_area(is:ie, js:je)) - call get_grid_cell_area_SG(component, tile, SG_area, SG_domain) - call mpp_pass_SG_to_UG(UG_domain, SG_area, cellarea) - deallocate(SG_area) - -end subroutine get_grid_cell_area_UG - -subroutine get_grid_comp_area_UG(component, tile, area, SG_domain, UG_domain) - character(len=*), intent(in) :: component - integer , intent(in) :: tile - real , intent(inout) :: area(:) - type(domain2d) , intent(in) :: SG_domain - type(domainUG) , intent(in) :: UG_domain - integer :: is, ie, js, je - real, allocatable :: SG_area(:,:) - - call mpp_get_compute_domain(SG_domain, is, ie, js, je) - allocate(SG_area(is:ie, js:je)) - call get_grid_comp_area_SG(component, tile, SG_area, SG_domain) - call mpp_pass_SG_to_UG(UG_domain, SG_area, area) - deallocate(SG_area) - -end subroutine get_grid_comp_area_UG - - -! ============================================================================ -! ============================================================================ -!> Returns arrays of global grid cell boundaries for given model component and -!! mosaic tile number. -!! -!> @note In the case of non-lat-lon grid the returned coordinates may have be not so -!! meaningful, by the very nature of such grids. But presumably these 1D coordinate -!! arrays are good enough for diag axis and such. -subroutine get_grid_cell_vertices_1D(component, tile, glonb, glatb) - character(len=*), intent(in) :: component - integer, intent(in) :: tile - real, intent(inout) :: glonb(:),glatb(:) - - integer :: nlon, nlat - integer :: start(4), nread(4) - real, allocatable :: tmp(:,:), x_vert_t(:,:,:), y_vert_t(:,:,:) - character(len=MAX_FILE) :: filename1, filename2 - - call get_grid_size_for_one_tile(component, tile, nlon, nlat) - if (size(glonb(:))/=nlon+1) & - call mpp_error (FATAL, module_name// & - & '/get_grid_cell_vertices_1D: Size of argument "glonb" is not consistent with the grid size') - if (size(glatb(:))/=nlat+1) & - call mpp_error (FATAL, module_name// & - & '/get_grid_cell_vertices_1D: Size of argument "glatb" is not consistent with the grid size') - if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then - call mpp_error(FATAL, module_name//'/get_grid_cell_vertices_1D: Illegal component name "'// & - & trim(component)//'": must be one of ATM, LND, or OCN') - endif - - select case(get_grid_version()) - case(VERSION_0) - select case(trim(component)) - case('ATM','LND') - call read_data(grid_file, 'xb'//lowercase(component(1:1)), glonb, no_domain=.true.) - call read_data(grid_file, 'yb'//lowercase(component(1:1)), glatb, no_domain=.true.) - case('OCN') - call read_data(grid_file, "gridlon_vert_t", glonb, no_domain=.true.) - call read_data(grid_file, "gridlat_vert_t", glatb, no_domain=.true.) - end select - case(VERSION_1) - select case(trim(component)) - case('ATM','LND') - call read_data(grid_file, 'xb'//lowercase(component(1:1)), glonb, no_domain=.true.) - call read_data(grid_file, 'yb'//lowercase(component(1:1)), glatb, no_domain=.true.) - case('OCN') - allocate (x_vert_t(nlon,1,2), y_vert_t(1,nlat,2) ) - start = 1; nread = 1 - nread(1) = nlon; nread(2) = 1; start(3) = 1 - call read_data(grid_file, "x_vert_T", x_vert_t(:,:,1), start, nread, no_domain=.TRUE.) - nread(1) = nlon; nread(2) = 1; start(3) = 2 - call read_data(grid_file, "x_vert_T", x_vert_t(:,:,2), start, nread, no_domain=.TRUE.) - - nread(1) = 1; nread(2) = nlat; start(3) = 1 - call read_data(grid_file, "y_vert_T", y_vert_t(:,:,1), start, nread, no_domain=.TRUE.) - nread(1) = 1; nread(2) = nlat; start(3) = 4 - call read_data(grid_file, "y_vert_T", y_vert_t(:,:,2), start, nread, no_domain=.TRUE.) - glonb(1:nlon) = x_vert_t(1:nlon,1,1) - glonb(nlon+1) = x_vert_t(nlon,1,2) - glatb(1:nlat) = y_vert_t(1,1:nlat,1) - glatb(nlat+1) = y_vert_t(1,nlat,2) - deallocate(x_vert_t, y_vert_t) - end select - case(VERSION_2) - ! get the name of the mosaic file for the component - call read_data(grid_file, trim(lowercase(component))//'_mosaic_file', filename1) - filename1=grid_dir//trim(filename1) - ! get the name of the grid file for the component and tile - call read_data(filename1, 'gridfiles', filename2, level=tile) - filename2 = grid_dir//trim(filename2) - - start = 1; nread = 1 - nread(1) = 2*nlon+1 - allocate( tmp(2*nlon+1,1) ) - call read_data(filename2, "x", tmp, start, nread, no_domain=.TRUE.) - glonb(1:nlon+1) = tmp(1:2*nlon+1:2,1) - deallocate(tmp) - allocate(tmp(1,2*nlat+1)) - - start = 1; nread = 1 - nread(2) = 2*nlat+1 - call read_data(filename2, "y", tmp, start, nread, no_domain=.TRUE.) - glatb(1:nlat+1) = tmp(1,1:2*nlat+1:2) - deallocate(tmp) - end select - -end subroutine get_grid_cell_vertices_1D - -! ============================================================================ -! ============================================================================ -!> Returns cell vertices for the specified model component and mosaic tile number -subroutine get_grid_cell_vertices_2D(component, tile, lonb, latb, domain) - character(len=*), intent(in) :: component - integer, intent(in) :: tile - real, intent(inout) :: lonb(:,:),latb(:,:) - type(domain2d), optional, intent(in) :: domain - - ! local vars - character(len=MAX_FILE) :: filename1, filename2 - integer :: nlon, nlat - integer :: i,j - real, allocatable :: buffer(:), tmp(:,:), x_vert_t(:,:,:), y_vert_t(:,:,:) - integer :: is,ie,js,je ! boundaries of our domain - integer :: i0,j0 ! offsets for coordinates - integer :: isg, jsg - integer :: start(4), nread(4) - - call get_grid_size_for_one_tile(component, tile, nlon, nlat) - if (present(domain)) then - call mpp_get_compute_domain(domain,is,ie,js,je) - else - is = 1 ; ie = nlon - js = 1 ; je = nlat - !--- domain normally should be present - call mpp_error (NOTE, module_name//'/get_grid_cell_vertices: domain is not present, global data will be read') - endif - i0 = -is+1; j0 = -js+1 - - ! verify that lonb and latb sizes are consistent with the size of domain - if (size(lonb,1)/=ie-is+2.or.size(lonb,2)/=je-js+2) & - call mpp_error (FATAL, module_name// & - & '/get_grid_cell_vertices: Size of argument "lonb" is not consistent with the domain size') - if (size(latb,1)/=ie-is+2.or.size(latb,2)/=je-js+2) & - call mpp_error (FATAL, module_name// & - & '/get_grid_cell_vertices: Size of argument "latb" is not consistent with the domain size') - if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then - call mpp_error(FATAL, module_name//'/get_grid_cell_vertices: Illegal component name "'// & - & trim(component)//'": must be one of ATM, LND, or OCN') - endif - - select case(get_grid_version()) - case(VERSION_0) - select case(component) - case('ATM','LND') - allocate(buffer(max(nlon,nlat)+1)) - ! read coordinates of grid cell vertices - call read_data(grid_file, 'xb'//lowercase(component(1:1)), buffer(1:nlon+1), no_domain=.true.) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = buffer(i) - enddo - enddo - call read_data(grid_file, 'yb'//lowercase(component(1:1)), buffer(1:nlat+1), no_domain=.true.) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = buffer(j) - enddo - enddo - deallocate(buffer) - case('OCN') - if (present(domain)) then - start = 1; nread = 1 - start(1) = is; start(2) = js - nread(1) = ie-is+2; nread(2) = je-js+2 - call read_data(grid_file, 'geolon_vert_t', lonb, start, nread, no_domain=.true. ) - call read_data(grid_file, 'geolat_vert_t', latb, start, nread, no_domain=.true. ) - else - call read_data(grid_file, 'geolon_vert_t', lonb, no_domain=.TRUE. ) - call read_data(grid_file, 'geolat_vert_t', latb, no_domain=.TRUE. ) - endif - end select - case(VERSION_1) - select case(component) - case('ATM','LND') - allocate(buffer(max(nlon,nlat)+1)) - ! read coordinates of grid cell vertices - call read_data(grid_file, 'xb'//lowercase(component(1:1)), buffer(1:nlon+1), no_domain=.true.) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = buffer(i) - enddo - enddo - call read_data(grid_file, 'yb'//lowercase(component(1:1)), buffer(1:nlat+1), no_domain=.true.) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = buffer(j) - enddo - enddo - deallocate(buffer) - case('OCN') - nlon=ie-is+1; nlat=je-js+1 - allocate (x_vert_t(nlon,nlat,4), y_vert_t(nlon,nlat,4) ) - call read_data(grid_file, 'x_vert_T', x_vert_t, no_domain=.not.present(domain), domain=domain ) - call read_data(grid_file, 'y_vert_T', y_vert_t, no_domain=.not.present(domain), domain=domain ) - lonb(1:nlon,1:nlat) = x_vert_t(1:nlon,1:nlat,1) - lonb(nlon+1,1:nlat) = x_vert_t(nlon,1:nlat,2) - lonb(1:nlon,nlat+1) = x_vert_t(1:nlon,nlat,4) - lonb(nlon+1,nlat+1) = x_vert_t(nlon,nlat,3) - latb(1:nlon,1:nlat) = y_vert_t(1:nlon,1:nlat,1) - latb(nlon+1,1:nlat) = y_vert_t(nlon,1:nlat,2) - latb(1:nlon,nlat+1) = y_vert_t(1:nlon,nlat,4) - latb(nlon+1,nlat+1) = y_vert_t(nlon,nlat,3) - deallocate(x_vert_t, y_vert_t) - end select - case(VERSION_2) - ! get the name of the mosaic file for the component - call read_data(grid_file, trim(lowercase(component))//'_mosaic_file', filename1) - filename1=grid_dir//trim(filename1) - ! get the name of the grid file for the component and tile - call read_data(filename1, 'gridfiles', filename2, level=tile) - filename2 = grid_dir//trim(filename2) - if(PRESENT(domain)) then - call mpp_get_global_domain(domain, xbegin=isg, ybegin=jsg) - start = 1; nread = 1 - start(1) = 2*(is-isg+1) - 1; nread(1) = 2*(ie-is)+3 - start(2) = 2*(js-jsg+1) - 1; nread(2) = 2*(je-js)+3 - allocate(tmp(nread(1), nread(2)) ) - call read_data(filename2, 'x', tmp, start, nread, no_domain=.TRUE.) - do j = 1, je-js+2 - do i = 1, ie-is+2 - lonb(i,j) = tmp(2*i-1,2*j-1) - enddo - enddo - call read_data(filename2, 'y', tmp, start, nread, no_domain=.TRUE.) - do j = 1, je-js+2 - do i = 1, ie-is+2 - latb(i,j) = tmp(2*i-1,2*j-1) - enddo - enddo - else - allocate(tmp(2*nlon+1,2*nlat+1)) - call read_data(filename2, 'x', tmp, no_domain=.TRUE.) - do j = js, je+1 - do i = is, ie+1 - lonb(i+i0,j+j0) = tmp(2*i-1,2*j-1) - end do - end do - call read_data(filename2, 'y', tmp, no_domain=.TRUE.) - do j = js, je+1 - do i = is, ie+1 - latb(i+i0,j+j0) = tmp(2*i-1,2*j-1) - end do - end do - endif - deallocate(tmp) - end select - -end subroutine get_grid_cell_vertices_2D - - -subroutine get_grid_cell_vertices_UG(component, tile, lonb, latb, SG_domain, UG_domain) - character(len=*), intent(in) :: component - integer, intent(in) :: tile - real, intent(inout) :: lonb(:,:),latb(:,:) ! The second dimension is 4 - type(domain2d) , intent(in) :: SG_domain - type(domainUG) , intent(in) :: UG_domain - integer :: is, ie, js, je, i, j - real, allocatable :: SG_lonb(:,:), SG_latb(:,:), tmp(:,:,:) - - call mpp_get_compute_domain(SG_domain, is, ie, js, je) - allocate(SG_lonb(is:ie+1, js:je+1)) - allocate(SG_latb(is:ie+1, js:je+1)) - allocate(tmp(is:ie,js:je,4)) - call get_grid_cell_vertices_2D(component, tile, SG_lonb, SG_latb, SG_domain) - do j = js, je - do i = is, ie - tmp(i,j,1) = SG_lonb(i,j) - tmp(i,j,2) = SG_lonb(i+1,j) - tmp(i,j,3) = SG_lonb(i+1,j+1) - tmp(i,j,4) = SG_lonb(i,j+1) - enddo - enddo - call mpp_pass_SG_to_UG(UG_domain, tmp, lonb) - do j = js, je - do i = is, ie - tmp(i,j,1) = SG_latb(i,j) - tmp(i,j,2) = SG_latb(i+1,j) - tmp(i,j,3) = SG_latb(i+1,j+1) - tmp(i,j,4) = SG_latb(i,j+1) - enddo - enddo - call mpp_pass_SG_to_UG(UG_domain, tmp, latb) - - - deallocate(SG_lonb, SG_latb, tmp) - -end subroutine get_grid_cell_vertices_UG - -! ============================================================================ -!> Returns global coordinate arrays fro given model component and mosaic tile number -!! @note In the case of non-lat-lon grid those coordinates may have be not so -!! meaningful, by the very nature of such grids. But presumably these 1D coordinate -!! arrays are good enough for diag axis and such. -subroutine get_grid_cell_centers_1D(component, tile, glon, glat) - character(len=*), intent(in) :: component - integer, intent(in) :: tile - real, intent(inout) :: glon(:),glat(:) - integer :: nlon, nlat - integer :: start(4), nread(4) - real, allocatable :: tmp(:,:) - character(len=MAX_FILE) :: filename1, filename2 - - call get_grid_size_for_one_tile(component, tile, nlon, nlat) - if (size(glon(:))/=nlon) & - call mpp_error (FATAL, module_name// & - & '/get_grid_cell_centers_1D: Size of argument "glon" is not consistent with the grid size') - if (size(glat(:))/=nlat) & - call mpp_error (FATAL, module_name// & - & '/get_grid_cell_centers_1D: Size of argument "glat" is not consistent with the grid size') - if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then - call mpp_error(FATAL, module_name//'/get_grid_cell_centers_1D: Illegal component name "'// & - & trim(component)//'": must be one of ATM, LND, or OCN') - endif - - select case(get_grid_version()) - case(VERSION_0) - select case(trim(component)) - case('ATM','LND') - call read_data(grid_file, 'xt'//lowercase(component(1:1)), glon, no_domain=.true.) - call read_data(grid_file, 'yt'//lowercase(component(1:1)), glat, no_domain=.true.) - case('OCN') - call read_data(grid_file, "gridlon_t", glon, no_domain=.true.) - call read_data(grid_file, "gridlat_t", glat, no_domain=.true.) - end select - case(VERSION_1) - select case(trim(component)) - case('ATM','LND') - call read_data(grid_file, 'xt'//lowercase(component(1:1)), glon, no_domain=.true.) - call read_data(grid_file, 'yt'//lowercase(component(1:1)), glat, no_domain=.true.) - case('OCN') - call read_data(grid_file, "grid_x_T", glon, no_domain=.true.) - call read_data(grid_file, "grid_y_T", glat, no_domain=.true.) - end select - case(VERSION_2) - ! get the name of the mosaic file for the component - call read_data(grid_file, trim(lowercase(component))//'_mosaic_file', filename1) - filename1=grid_dir//trim(filename1) - ! get the name of the grid file for the component and tile - call read_data(filename1, 'gridfiles', filename2, level=tile) - filename2 = grid_dir//trim(filename2) - - start = 1; nread = 1 - nread(1) = 2*nlon+1; start(2) = 2 - allocate( tmp(2*nlon+1,1) ) - call read_data(filename2, "x", tmp, start, nread, no_domain=.TRUE.) - glon(1:nlon) = tmp(2:2*nlon:2,1) - deallocate(tmp) - allocate(tmp(1, 2*nlat+1)) - - start = 1; nread = 1 - nread(2) = 2*nlat+1; start(1) = 2 - call read_data(filename2, "y", tmp, start, nread, no_domain=.TRUE.) - glat(1:nlat) = tmp(1,2:2*nlat:2) - deallocate(tmp) - end select - - -end subroutine get_grid_cell_centers_1D - -! ============================================================================ -! ============================================================================ -!> Returns grid cell centers for specified model component and mosaic tile number -subroutine get_grid_cell_centers_2D(component, tile, lon, lat, domain) - character(len=*), intent(in) :: component - integer, intent(in) :: tile - real, intent(inout) :: lon(:,:),lat(:,:) - type(domain2d), intent(in), optional :: domain - ! local vars - character(len=MAX_FILE) :: filename1, filename2 - integer :: nlon, nlat - integer :: i,j - real, allocatable :: buffer(:),tmp(:,:) - integer :: is,ie,js,je ! boundaries of our domain - integer :: i0,j0 ! offsets for coordinates - integer :: isg, jsg - integer :: start(4), nread(4) - - call get_grid_size_for_one_tile(component, tile, nlon, nlat) - if (present(domain)) then - call mpp_get_compute_domain(domain,is,ie,js,je) - else - is = 1 ; ie = nlon - js = 1 ; je = nlat - !--- domain normally should be present - call mpp_error (NOTE, module_name//'/get_grid_cell_centers: domain is not present, global data will be read') - endif - i0 = -is+1; j0 = -js+1 - - ! verify that lon and lat sizes are consistent with the size of domain - if (size(lon,1)/=ie-is+1.or.size(lon,2)/=je-js+1) & - call mpp_error (FATAL, module_name// & - & '/get_grid_cell_centers: Size of array "lon" is not consistent with the domain size') - if (size(lat,1)/=ie-is+1.or.size(lat,2)/=je-js+1) & - call mpp_error (FATAL, module_name// & - & '/get_grid_cell_centers: Size of array "lat" is not consistent with the domain size') - if(trim(component) .NE. 'ATM' .AND. component .NE. 'LND' .AND. component .NE. 'OCN') then - call mpp_error(FATAL, module_name//'/get_grid_cell_vertices: Illegal component name "'// & - & trim(component)//'": must be one of ATM, LND, or OCN') - endif - - select case(get_grid_version()) - case(VERSION_0) - select case (trim(component)) - case('ATM','LND') - allocate(buffer(max(nlon,nlat))) - ! read coordinates of grid cell vertices - call read_data(grid_file, 'xt'//lowercase(component(1:1)), buffer(1:nlon), no_domain=.true.) - do j = js,je - do i = is,ie - lon(i+i0,j+j0) = buffer(i) - enddo - enddo - call read_data(grid_file, 'yt'//lowercase(component(1:1)), buffer(1:nlat), no_domain=.true.) - do j = js,je - do i = is,ie - lat(i+i0,j+j0) = buffer(j) - enddo - enddo - deallocate(buffer) - case('OCN') - call read_data(grid_file, 'geolon_t', lon, no_domain=.not.present(domain), domain=domain ) - call read_data(grid_file, 'geolat_t', lat, no_domain=.not.present(domain), domain=domain ) - end select - case(VERSION_1) - select case(trim(component)) - case('ATM','LND') - allocate(buffer(max(nlon,nlat))) - ! read coordinates of grid cell vertices - call read_data(grid_file, 'xt'//lowercase(component(1:1)), buffer(1:nlon), no_domain=.true.) - do j = js,je - do i = is,ie - lon(i+i0,j+j0) = buffer(i) - enddo - enddo - call read_data(grid_file, 'yt'//lowercase(component(1:1)), buffer(1:nlat), no_domain=.true.) - do j = js,je - do i = is,ie - lat(i+i0,j+j0) = buffer(j) - enddo - enddo - deallocate(buffer) - case('OCN') - call read_data(grid_file, 'x_T', lon, no_domain=.not.present(domain), domain=domain ) - call read_data(grid_file, 'y_T', lat, no_domain=.not.present(domain), domain=domain ) - end select - case(VERSION_2) ! mosaic grid file - ! get the name of the mosaic file for the component - call read_data(grid_file, trim(lowercase(component))//'_mosaic_file', filename1) - filename1=grid_dir//trim(filename1) - ! get the name of the grid file for the component and tile - call read_data(filename1, 'gridfiles', filename2, level=tile) - filename2 = grid_dir//trim(filename2) - if(PRESENT(domain)) then - call mpp_get_global_domain(domain, xbegin=isg, ybegin=jsg) - start = 1; nread = 1 - start(1) = 2*(is-isg+1) - 1; nread(1) = 2*(ie-is)+3 - start(2) = 2*(js-jsg+1) - 1; nread(2) = 2*(je-js)+3 - allocate(tmp(nread(1), nread(2))) - call read_data(filename2, 'x', tmp, start, nread, no_domain=.TRUE.) - do j = 1, je-js+1 - do i = 1, ie-is+1 - lon(i,j) = tmp(2*i,2*j) - enddo - enddo - call read_data(filename2, 'y', tmp, start, nread, no_domain=.TRUE.) - do j = 1, je-js+1 - do i = 1, ie-is+1 - lat(i,j) = tmp(2*i,2*j) - enddo - enddo - else - allocate(tmp(2*nlon+1,2*nlat+1)) - call read_data(filename2, 'x', tmp, no_domain=.TRUE.) - do j = js,je - do i = is,ie - lon(i+i0,j+j0) = tmp(2*i,2*j) - end do - end do - call read_data(filename2, 'y', tmp, no_domain=.TRUE.) - do j = js,je - do i = is,ie - lat(i+i0,j+j0) = tmp(2*i,2*j) - end do - end do - deallocate(tmp) - endif - end select - -end subroutine get_grid_cell_centers_2D - -subroutine get_grid_cell_centers_UG(component, tile, lon, lat, SG_domain, UG_domain) - character(len=*), intent(in) :: component - integer, intent(in) :: tile - real, intent(inout) :: lon(:),lat(:) - type(domain2d) , intent(in) :: SG_domain - type(domainUG) , intent(in) :: UG_domain - integer :: is, ie, js, je - real, allocatable :: SG_lon(:,:), SG_lat(:,:) - - call mpp_get_compute_domain(SG_domain, is, ie, js, je) - allocate(SG_lon(is:ie, js:je)) - allocate(SG_lat(is:ie, js:je)) - call get_grid_cell_centers_2D(component, tile, SG_lon, SG_lat, SG_domain) - call mpp_pass_SG_to_UG(UG_domain, SG_lon, lon) - call mpp_pass_SG_to_UG(UG_domain, SG_lat, lat) - deallocate(SG_lon, SG_lat) - -end subroutine get_grid_cell_centers_UG - -! ============================================================================ -! ============================================================================ -! this subroutine probably does not belong in the grid_mod -!> Given a model component, a layout, and (optionally) a halo size, returns a -!! domain for current processor -subroutine define_cube_mosaic ( component, domain, layout, halo, maskmap ) - character(len=*) , intent(in) :: component - type(domain2d) , intent(inout) :: domain - integer , intent(in) :: layout(2) - integer, optional, intent(in) :: halo - logical, optional, intent(in) :: maskmap(:,:,:) - - ! ---- local constants - - ! ---- local vars - character(len=MAX_NAME) :: varname - character(len=MAX_FILE + len(grid_dir)) :: mosaic_file - integer :: ntiles ! number of tiles - integer :: ncontacts ! number of contacts between mosaic tiles - integer :: n - integer :: ng, pe_pos, npes ! halo size - integer, allocatable :: nlon(:), nlat(:), global_indices(:,:) - integer, allocatable :: pe_start(:), pe_end(:), layout_2d(:,:) - integer, allocatable :: tile1(:),tile2(:) - integer, allocatable :: is1(:),ie1(:),js1(:),je1(:) - integer, allocatable :: is2(:),ie2(:),js2(:),je2(:) - - call get_grid_ntiles(component,ntiles) - allocate(nlon(ntiles), nlat(ntiles)) - allocate(global_indices(4,ntiles)) - allocate(pe_start(ntiles),pe_end(ntiles)) - allocate(layout_2d(2,ntiles)) - call get_grid_size(component,nlon,nlat) - - pe_pos = mpp_root_pe() - do n = 1, ntiles - global_indices(:,n) = (/ 1, nlon(n), 1, nlat(n) /) - layout_2d (:,n) = layout - if(present(maskmap)) then - npes = count(maskmap(:,:,n)) - else - npes = layout(1)*layout(2) - endif - pe_start(n) = pe_pos - pe_end (n) = pe_pos + npes - 1 - pe_pos = pe_end(n) + 1 - enddo - - varname=trim(lowercase(component))//'_mosaic_file' - call read_data(grid_file,varname,mosaic_file(1:MAX_FILE)) - mosaic_file = grid_dir//mosaic_file(1:MAX_FILE) - - ! get the contact information from mosaic file - ncontacts = get_mosaic_ncontacts(mosaic_file) - allocate(tile1(ncontacts),tile2(ncontacts)) - allocate(is1(ncontacts),ie1(ncontacts),js1(ncontacts),je1(ncontacts)) - allocate(is2(ncontacts),ie2(ncontacts),js2(ncontacts),je2(ncontacts)) - call get_mosaic_contact(mosaic_file, tile1, tile2, & - is1, ie1, js1, je1, is2, ie2, js2, je2) - - ng = 0 - if(present(halo)) ng = halo - ! create the domain2d variable - call mpp_define_mosaic ( global_indices, layout_2d, domain, & - ntiles, ncontacts, tile1, tile2, & - is1, ie1, js1, je1, & - is2, ie2, js2, je2, & - pe_start=pe_start, pe_end=pe_end, symmetry=.true., & - shalo = ng, nhalo = ng, whalo = ng, ehalo = ng, & - maskmap = maskmap, & - name = trim(component)//'Cubic-Sphere Grid' ) - - deallocate(nlon,nlat,global_indices,pe_start,pe_end,layout_2d) - deallocate(tile1,tile2) - deallocate(is1,ie1,js1,je1) - deallocate(is2,ie2,js2,je2) - -end subroutine define_cube_mosaic -#endif -end module grid_mod -!> @} -! close documentation grouping diff --git a/mosaic/interp.c b/mosaic/interp.c deleted file mode 100644 index 6ead747eda..0000000000 --- a/mosaic/interp.c +++ /dev/null @@ -1,394 +0,0 @@ -/*********************************************************************** - * 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 -#include -#include -#include "mosaic_util.h" -#include "interp.h" -#include "create_xgrid.h" - -/** \file - * \ingroup mosaic - * \brief Grid interpolation functions for use in @ref mosaic_mod - */ - -/********************************************************************* - void cublic_spline_sp(size1, size2, grid1, grid2, data1, data2) - - Calculate a shape preserving cubic spline. Monotonicity is ensured over each subinterval - unlike classic cubic spline interpolation. - It will be used to interpolation data in 1-D space. - - INPUT Arguments: - grid1: grid for input data grid. - grid2: grid for output data grid. - size1: size of input grid. - size2: size of output grid. - data1: input data associated with grid1. - - OUTPUT ARGUMENTS: - data2: output data associated with grid2. (OUTPUT) - -*********************************************************************/ - -void cubic_spline_sp(int size1, int size2, const double *grid1, const double *grid2, const double *data1, - double *data2 ) -{ - double *delta=NULL, *d=NULL, *dh=NULL, *b=NULL, *c = NULL; - double s, w1, w2, p; - int i, k, n, klo, khi, kmax; - - for(i=1; i grid1[size1-1]) error_handler("cubic_spline_sp: grid2 lies outside grid1"); - } - - if(size1 < 2) error_handler("cubic_spline_sp: the size of input grid should be at least 2"); - if(size1 == 2) { /* when size1 is 2, it just reduced to a linear interpolation */ - p = (data1[1]-data1[0])/(grid1[1]-grid1[0]); - for(i=0; i< size2; i++) data2[i] = p*(grid2[i] - grid1[0]) + data1[0]; - return; - } - delta = (double *)malloc((size1-1)*sizeof(double)); - dh = (double *)malloc((size1-1)*sizeof(double)); - d = (double *)malloc(size1*sizeof(double)); - for(k=0;k 0.0 ) { - w1 = 2.0*dh[k] + dh[k-1]; - w2 = dh[k] + 2.0*dh[k-1]; - d[k] = (w1+w2)/(w1/delta[k-1]+w2/delta[k]); - } - else { - d[k] = 0.0; - } - } - /* - End slopes - */ - kmax = size1-1; - d[0] = ((2.0*dh[0] + dh[1])*delta[0] - dh[0]*delta[1])/(dh[0]+dh[1]); - - if ( d[0]*delta[0] < 0.0 ) { - d[0] = 0.0; - } - else { - if ( delta[0]*delta[1] < 0.0 && fabs(d[0]) > fabs(3.0*delta[0])) { - d[0]=3.0*delta[0]; - } - } - - d[kmax] = ((2.0*dh[kmax-1] + dh[kmax-2])*delta[kmax-1] - dh[kmax-1]*delta[kmax-2])/(dh[kmax-1]+dh[kmax-2]); - if ( d[kmax]*delta[kmax-1] < 0.0 ) { - d[kmax] = 0.0; - } - else { - if ( delta[kmax-1]*delta[kmax-2] < 0.0 && fabs(d[kmax]) > fabs(3.0*delta[kmax-1])) { - d[kmax]=3.0*delta[kmax-1]; - } - } - - /* Precalculate coefficients */ - b = (double *)malloc((size1-1)*sizeof(double)); - c = (double *)malloc((size1-1)*sizeof(double)); - for (k=0; k grid1[size1-1]) error_handler("cubic_spline: grid2 lies outside grid1"); - } - - if(size1 < 2) error_handler("cubic_spline: the size of input grid should be at least 2"); - if(size1 == 2) { /* when size1 is 2, it just reduced to a linear interpolation */ - p = (data1[1]-data1[0])/(grid1[1]-grid1[0]); - for(i=0; i< size2; i++) data2[i] = p*(grid2[i] - grid1[0]) + data1[0]; - return; - } - y2 = (double *)malloc(size1*sizeof(double)); - u = (double *)malloc(size1*sizeof(double)); - if (yp1 >.99e30) { - y2[0]=0.; - u[0]=0.; - } - else { - y2[0]=-0.5; - u[0]=(3./(grid1[1]-grid1[0]))*((data1[1]-data1[0])/(grid1[1]-grid1[0])-yp1); - } - - for(i=1; i .99e30) { - qn=0.; - un=0.; - } - else { - qn=0.5; - un=(3./(grid1[size1-1]-grid1[size1-2]))*(ypn-(data1[size1-1]-data1[size1-2])/(grid1[size1-1]-grid1[size1-2])); - } - - y2[size1-1]=(un-qn*u[size1-2])/(qn*y2[size1-2]+1.); - - for(k=size1-2; k>=0; k--) y2[k] = y2[k]*y2[k+1]+u[k]; - - /* interpolate data onto grid2 */ - for(k=0; k grid2[0] ) error_handler("interp.c: grid2 lies outside grid1"); - if (grid1[nk1-1] < grid2[nk2-1] ) error_handler("interp.c: grid2 lies outside grid1"); - - for(k=0; k. - **********************************************************************/ -#ifndef INTERP_H_ -#define INTERP_H_ -/********************************************************************* - interp.h - This header files contains defition of some interpolation routine (1-D or 2-D). - contact: Zhi.Liang@noaa.gov -*********************************************************************/ -void cubic_spline_sp(int size1, int size2, const double *grid1, const double *grid2, const double *data1, - double *data2 ); - -void cubic_spline(int size1, int size2, const double *grid1, const double *grid2, const double *data1, - double *data2, double yp1, double ypn ); - -void conserve_interp(int nx_src, int ny_src, int nx_dst, int ny_dst, const double *x_src, - const double *y_src, const double *x_dst, const double *y_dst, - const double *mask_src, const double *data_src, double *data_dst ); - -void conserve_interp_great_circle(int nx_src, int ny_src, int nx_dst, int ny_dst, const double *x_src, - const double *y_src, const double *x_dst, const double *y_dst, - const double *mask_src, const double *data_src, double *data_dst ); - -void linear_vertical_interp(int nx, int ny, int nk1, int nk2, const double *grid1, const double *grid2, - double *data1, double *data2); - -#endif diff --git a/mosaic/mosaic.F90 b/mosaic/mosaic.F90 deleted file mode 100644 index eb8a698de4..0000000000 --- a/mosaic/mosaic.F90 +++ /dev/null @@ -1,497 +0,0 @@ -!*********************************************************************** -!* 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 mosaic_mod mosaic_mod -!> @ingroup mosaic -!> @brief Implements some utility routines to read mosaic information. -!> @author Zhi Liang -!> Implements some utility routines to read mosaic information. -!! The information includes number of tiles and contacts in the mosaic, -!! mosaic grid resolution of each tile, mosaic contact information, mosaic exchange -!! grid information. Each routine will call a C-version routine to get these information. - -!> @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 -use fms_io_mod, only : dimension_size, field_exist, read_data, read_compressed -use constants_mod, only : PI, RADIUS - -implicit none -private - -character(len=*), parameter :: & - grid_dir = 'INPUT/' !< root directory for all grid files - -integer, parameter :: & - MAX_NAME = 256, & !< max length of the variable names - MAX_FILE = 1024, & !< max length of the file names - X_REFINE = 2, & !< supergrid size/model grid size in x-direction - Y_REFINE = 2 !< supergrid size/model grid size in y-direction - -! --- public interface - -public :: get_mosaic_ntiles -public :: get_mosaic_ncontacts -public :: get_mosaic_grid_sizes -public :: get_mosaic_contact -public :: get_mosaic_xgrid_size -public :: get_mosaic_xgrid -public :: calc_mosaic_grid_area -public :: calc_mosaic_grid_great_circle_area -public :: is_inside_polygon - -logical :: module_is_initialized = .true. -!--- external c routines -external get_grid_area, get_grid_great_circle_area, grad_c2l, calc_c2l_grid_info - -! Include variable "version" to be written to log file. -#include - -contains - -!####################################################################### - -!> @brief Initialize the mosaic_mod. -!! -!! Initialization routine for the mosaic module. It writes the -!! version information to the log file. -subroutine mosaic_init() - - if (module_is_initialized) return - module_is_initialized = .TRUE. - -!--------- write version number and namelist ------------------ - -end subroutine mosaic_init - -!############################################################################### - - !> @return integer for exchange grid size of mosaic xgrid file. - function get_mosaic_xgrid_size(xgrid_file) - character(len=*), intent(in) :: xgrid_file !< File that contains exchange grid information - integer :: get_mosaic_xgrid_size - - get_mosaic_xgrid_size = dimension_size(xgrid_file, "ncells", no_domain=.TRUE.) - - return - - end function get_mosaic_xgrid_size - -!############################################################################### - !> Get exchange grid information from mosaic xgrid file. - !! - !>
Example usage: - !! @code{.F90} - !! call get_mosaic_xgrid(xgrid_file, nxgrid, i1, j1, i2, j2, area) - !! @endcode - subroutine get_mosaic_xgrid(xgrid_file, i1, j1, i2, j2, area, ibegin, iend) - character(len=*), intent(in) :: xgrid_file !< The file that contains exchange grid information. - integer, intent(inout) :: i1(:), j1(:) !< i and j-index in grid 1 of exchange field - integer, intent(inout) :: i2(:), j2(:) !< i and j-index in grid 2 of exchange field - real, intent(inout) :: area(:) !< area of the exchange grid. The area is sclaed to - !! represent unit earth area. - integer, optional, intent(in) :: ibegin, iend - - integer :: start(4), nread(4), istart - real, dimension(2, size(i1(:))) :: tile1_cell, tile2_cell - integer :: nxgrid, n - real :: garea - real :: get_global_area; - - garea = get_global_area(); - - ! When start and nread present, make sure nread(1) is the same as the size of the data - if(present(ibegin) .and. present(iend)) then - istart = ibegin - nxgrid = iend - ibegin + 1 - if(nxgrid .NE. size(i1(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(i1(:))") - if(nxgrid .NE. size(j1(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(j1(:))") - if(nxgrid .NE. size(i2(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(i2(:))") - if(nxgrid .NE. size(j2(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(j2(:))") - if(nxgrid .NE. size(area(:))) call mpp_error(FATAL, "get_mosaic_xgrid: nxgrid .NE. size(area(:))") - else - istart = 1 - nxgrid = size(i1(:)) - endif - - start = 1; nread = 1 - start(1) = istart; nread(1) = nxgrid - call read_compressed(xgrid_file, 'xgrid_area', area, start=start, nread=nread, threading=MPP_MULTI) - start = 1; nread = 1 - nread(1) = 2 - start(2) = istart; nread(2) = nxgrid - call read_compressed(xgrid_file, 'tile1_cell', tile1_cell, start=start, nread=nread, threading=MPP_MULTI) - call read_compressed(xgrid_file, 'tile2_cell', tile2_cell, start=start, nread=nread, threading=MPP_MULTI) - - do n = 1, nxgrid - i1(n) = int(tile1_cell(1,n)) - j1(n) = int(tile1_cell(2,n)) - i2(n) = int(tile2_cell(1,n)) - j2(n) = int(tile2_cell(2,n)) - area(n) = area(n)/garea - end do - - return - - end subroutine get_mosaic_xgrid - - !############################################################################### - - !> Get number of tiles in the mosaic_file. - !! - !! - !!
Example usage: - !! @code{.F90} - !! ntiles = get_mosaic_ntiles( mosaic_file) - !! @endcode - function get_mosaic_ntiles(mosaic_file) - character(len=*), intent(in) :: mosaic_file !< The file that contains mosaic information. - integer :: get_mosaic_ntiles - - get_mosaic_ntiles = dimension_size(mosaic_file, "ntiles") - - return - - end function get_mosaic_ntiles - - !############################################################################### - - !> Get number of contacts in the mosaic_file. - !! - !>
Example usage: - !! @code{.F90} - !! ntiles = get_mosaic_ncontacts( mosaic_file) - !! @endcode - function get_mosaic_ncontacts( mosaic_file) - character(len=*), intent(in) :: mosaic_file !< The file that contains mosaic information. - integer :: get_mosaic_ncontacts - - if(field_exist(mosaic_file, "contacts") ) then - get_mosaic_ncontacts = dimension_size(mosaic_file, "ncontact", no_domain=.TRUE.) - else - get_mosaic_ncontacts = 0 - endif - - return - - end function get_mosaic_ncontacts - - !############################################################################### - - !> Get grid size of each tile from mosaic_file - subroutine get_mosaic_grid_sizes( mosaic_file, nx, ny) - character(len=*), intent(in) :: mosaic_file !< The file that contains mosaic information. - integer, dimension(:), intent(inout) :: nx !< List of grid size in x-direction of each tile. - integer, dimension(:), intent(inout) :: ny !< List of grid size in y-direction of each tile. - - character(len=MAX_FILE) :: gridfile - integer :: ntiles, n - - ntiles = get_mosaic_ntiles(mosaic_file) - if(ntiles .NE. size(nx(:)) .OR. ntiles .NE. size(ny(:)) ) then - call mpp_error(FATAL, "get_mosaic_grid_sizes: size of nx/ny does not equal to ntiles") - endif - do n = 1, ntiles - call read_data(mosaic_file, 'gridfiles', gridfile, level=n) - gridfile = grid_dir//trim(gridfile) - nx(n) = dimension_size(gridfile, "nx") - ny(n) = dimension_size(gridfile, "ny") - if(mod(nx(n),x_refine) .NE. 0) call mpp_error(FATAL, "get_mosaic_grid_sizes: nx is not divided by x_refine"); - if(mod(ny(n),y_refine) .NE. 0) call mpp_error(FATAL, "get_mosaic_grid_sizes: ny is not divided by y_refine"); - nx(n) = nx(n)/x_refine; - ny(n) = ny(n)/y_refine; - enddo - - return - - end subroutine get_mosaic_grid_sizes - - !############################################################################### - - !> Get contact information from mosaic_file - subroutine get_mosaic_contact( mosaic_file, tile1, tile2, istart1, iend1, jstart1, jend1, & - istart2, iend2, jstart2, jend2) - character(len=*), intent(in) :: mosaic_file !< File that contains mosaic information - integer, dimension(:), intent(inout) :: tile1 !< list tile number in tile 1 of each contact - integer, dimension(:), intent(inout) :: tile2 !< list tile number in tile 2 of each contact - integer, dimension(:), intent(inout) :: istart1!< list starting i-index in tile 1 of each contact - integer, dimension(:), intent(inout) :: iend1 !< list ending i-index in tile 1 of each contact - integer, dimension(:), intent(inout) :: jstart1!< list starting j-index in tile 1 of each contact - integer, dimension(:), intent(inout) :: jend1 !< list ending j-index in tile 1 of each contact - integer, dimension(:), intent(inout) :: istart2!< list starting i-index in tile 2 of each contact - integer, dimension(:), intent(inout) :: iend2 !< list ending i-index in tile 2 of each contact - integer, dimension(:), intent(inout) :: jstart2!< list starting j-index in tile 2 of each contact - integer, dimension(:), intent(inout) :: jend2 !< list ending j-index in tile 2 of each contact - character(len=MAX_NAME), allocatable :: gridtiles(:) - character(len=MAX_NAME) :: contacts - character(len=MAX_NAME) :: strlist(8) - integer :: ntiles, n, m, ncontacts, nstr, ios - integer :: i1_type, j1_type, i2_type, j2_type - logical :: found - - ntiles = get_mosaic_ntiles(mosaic_file) - allocate(gridtiles(ntiles)) - do n = 1, ntiles - call read_data(mosaic_file, 'gridtiles', gridtiles(n), level=n) - enddo - - ncontacts = get_mosaic_ncontacts(mosaic_file) - - do n = 1, ncontacts - call read_data(mosaic_file, "contacts", contacts, level=n) - nstr = parse_string(contacts, ":", strlist) - if(nstr .NE. 4) call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact): number of elements in contact seperated by :/:: should be 4") - found = .false. - do m = 1, ntiles - if(trim(gridtiles(m)) == trim(strlist(2)) ) then !found the tile name - found = .true. - tile1(n) = m - exit - endif - enddo - - if(.not.found) call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact):the first tile name specified in contact is not found in tile list") - - found = .false. - do m = 1, ntiles - if(trim(gridtiles(m)) == trim(strlist(4)) ) then !found the tile name - found = .true. - tile2(n) = m - exit - endif - enddo - - if(.not.found) call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact):the second tile name specified in contact is not found in tile list") - - call read_data(mosaic_file, "contact_index", contacts, level=n) - nstr = parse_string(contacts, ":,", strlist) - if(nstr .NE. 8) then - if(mpp_pe()==mpp_root_pe()) then - print*, "nstr is ", nstr - print*, "contacts is ", contacts - do m = 1, nstr - print*, "strlist is ", trim(strlist(m)) - enddo - endif - call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact): number of elements in contact_index seperated by :/, should be 8") - endif - read(strlist(1), *, iostat=ios) istart1(n) - if(ios .NE. 0) call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact): Error in reading istart1") - read(strlist(2), *, iostat=ios) iend1(n) - if(ios .NE. 0) call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact): Error in reading iend1") - read(strlist(3), *, iostat=ios) jstart1(n) - if(ios .NE. 0) call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact): Error in reading jstart1") - read(strlist(4), *, iostat=ios) jend1(n) - if(ios .NE. 0) call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact): Error in reading jend1") - read(strlist(5), *, iostat=ios) istart2(n) - if(ios .NE. 0) call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact): Error in reading istart2") - read(strlist(6), *, iostat=ios) iend2(n) - if(ios .NE. 0) call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact): Error in reading iend2") - read(strlist(7), *, iostat=ios) jstart2(n) - if(ios .NE. 0) call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact): Error in reading jstart2") - read(strlist(8), *, iostat=ios) jend2(n) - if(ios .NE. 0) call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact): Error in reading jend2") - - i1_type = transfer_to_model_index(istart1(n), iend1(n), x_refine) - j1_type = transfer_to_model_index(jstart1(n), jend1(n), y_refine) - i2_type = transfer_to_model_index(istart2(n), iend2(n), x_refine) - j2_type = transfer_to_model_index(jstart2(n), jend2(n), y_refine) - - if( i1_type == 0 .AND. j1_type == 0 ) call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact): istart1==iend1 and jstart1==jend1") - if( i2_type == 0 .AND. j2_type == 0 ) call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact): istart2==iend2 and jstart2==jend2") - if( i1_type + j1_type .NE. i2_type + j2_type ) call mpp_error(FATAL, & - "mosaic_mod(get_mosaic_contact): It is not a line or overlap contact") - - enddo - - deallocate(gridtiles) - - end subroutine get_mosaic_contact - -function transfer_to_model_index(istart, iend, refine_ratio) - integer, intent(inout) :: istart, iend - integer :: refine_ratio - integer :: transfer_to_model_index - integer :: istart_in, iend_in - - istart_in = istart - iend_in = iend - - if( istart_in == iend_in ) then - transfer_to_model_index = 0 - istart = (istart_in + 1)/refine_ratio - iend = istart - else - transfer_to_model_index = 1 - if( iend_in > istart_in ) then - istart = istart_in + 1 - iend = iend_in - else - istart = istart_in - iend = iend_in + 1 - endif - if( mod(istart, refine_ratio) .NE. 0 .OR. mod(iend,refine_ratio) .NE. 0) call mpp_error(FATAL, & - "mosaic_mod(transfer_to_model_index): mismatch between refine_ratio and istart/iend") - istart = istart/refine_ratio - iend = iend/refine_ratio - - endif - - return - -end function transfer_to_model_index - - !############################################################################### - - !> @brief Calculate grid cell area. - !! - !> Calculate the grid cell area. The purpose of this routine is to make - !! sure the consistency between model grid area and exchange grid area. - subroutine calc_mosaic_grid_area(lon, lat, area) - real, dimension(:,:), intent(in) :: lon !< geographical longitude of grid cell vertices - real, dimension(:,:), intent(in) :: lat !< geographical latitude of grid cell vertices - real, dimension(:,:), intent(inout) :: area !< grid cell area - integer :: nlon, nlat - - nlon = size(area,1) - nlat = size(area,2) - ! make sure size of lon, lat and area are consitency - if( size(lon,1) .NE. nlon+1 .OR. size(lat,1) .NE. nlon+1 ) & - call mpp_error(FATAL, "mosaic_mod: size(lon,1) and size(lat,1) should equal to size(area,1)+1") - if( size(lon,2) .NE. nlat+1 .OR. size(lat,2) .NE. nlat+1 ) & - call mpp_error(FATAL, "mosaic_mod: size(lon,2) and size(lat,2) should equal to size(area,2)+1") - - call get_grid_area( nlon, nlat, lon, lat, area) - - end subroutine calc_mosaic_grid_area - - !############################################################################### - - !> Calculate grid cell area using great circle algorithm. - !! - !> Calculate the grid cell area. The purpose of this routine is to make - !! sure the consistency between model grid area and exchange grid area. - subroutine calc_mosaic_grid_great_circle_area(lon, lat, area) - real, dimension(:,:), intent(in) :: lon !< Geographical longitude of grid cell vertices. - real, dimension(:,:), intent(in) :: lat !< Geographical latitude of grid cell vertices. - real, dimension(:,:), intent(inout) :: area !< grid cell area - integer :: nlon, nlat - - - nlon = size(area,1) - nlat = size(area,2) - ! make sure size of lon, lat and area are consitency - if( size(lon,1) .NE. nlon+1 .OR. size(lat,1) .NE. nlon+1 ) & - call mpp_error(FATAL, "mosaic_mod: size(lon,1) and size(lat,1) should equal to size(area,1)+1") - if( size(lon,2) .NE. nlat+1 .OR. size(lat,2) .NE. nlat+1 ) & - call mpp_error(FATAL, "mosaic_mod: size(lon,2) and size(lat,2) should equal to size(area,2)+1") - - call get_grid_great_circle_area( nlon, nlat, lon, lat, area) - - end subroutine calc_mosaic_grid_great_circle_area - - !##################################################################### - !> This function check if a point (lon1,lat1) is inside a polygon (lon2(:), lat2(:)) - !! lon1, lat1, lon2, lat2 are in radians. - function is_inside_polygon(lon1, lat1, lon2, lat2 ) - real, intent(in) :: lon1, lat1 - real, intent(in) :: lon2(:), lat2(:) - logical :: is_inside_polygon - integer :: npts, isinside - integer :: inside_a_polygon - - npts = size(lon2(:)) - - isinside = inside_a_polygon(lon1, lat1, npts, lon2, lat2) - if(isinside == 1) then - is_inside_polygon = .TRUE. - else - is_inside_polygon = .FALSE. - endif - - return - - end function is_inside_polygon - - function parse_string(string, set, value) - character(len=*), intent(in) :: string - character(len=*), intent(in) :: set - character(len=*), intent(out) :: value(:) - integer :: parse_string - integer :: nelem, length, first, last - - nelem = size(value(:)) - length = len_trim(string) - - first = 1; last = 0 - parse_string = 0 - - do while(first .LE. length) - parse_string = parse_string + 1 - if(parse_string>nelem) then - call mpp_error(FATAL, "mosaic_mod(parse_string) : number of element is greater than size(value(:))") - endif - last = first - 1 + scan(string(first:length), set) - if(last == first-1 ) then ! not found, end of string - value(parse_string) = string(first:length) - exit - else - if(last <= first) then - call mpp_error(FATAL, "mosaic_mod(parse_string) : last <= first") - endif - value(parse_string) = string(first:(last-1)) - first = last + 1 - ! scan to make sure the next is not the character in the set - do while (first == last+1) - last = first - 1 + scan(string(first:length), set) - if(last == first) then - first = first+1 - else - exit - endif - end do - endif - enddo - - return - - end function parse_string -#endif -end module mosaic_mod - - -!> @} -! close documentation grouping diff --git a/mosaic/mosaic_util.c b/mosaic/mosaic_util.c deleted file mode 100644 index c37f799f18..0000000000 --- a/mosaic/mosaic_util.c +++ /dev/null @@ -1,1368 +0,0 @@ -/*********************************************************************** - * 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 -#include -#include -#include -#ifdef use_libMPI -#include -#endif -#include "mosaic_util.h" -#include "constant.h" - -#define HPI (0.5*M_PI) -#define TPI (2.0*M_PI) -#define TOLORENCE (1.e-6) -#define EPSLN8 (1.e-8) -#define EPSLN10 (1.e-10) -#define EPSLN15 (1.e-15) -#define EPSLN30 (1.e-30) - -/** \file - * \ingroup mosaic - * \brief Error handling and other general utilities for @ref mosaic_mod - */ - -/*********************************************************** - void error_handler(char *str) - error handler: will print out error message and then abort -***********************************************************/ - -void error_handler(const char *msg) -{ - fprintf(stderr, "FATAL Error: %s\n", msg ); -#ifdef use_libMPI - MPI_Abort(MPI_COMM_WORLD, -1); -#else - exit(1); -#endif -} /* error_handler */ - -/********************************************************************* - - int nearest_index(double value, const double *array, int ia) - - return index of nearest data point within "array" corresponding to "value". - if "value" is outside the domain of "array" then nearest_index = 0 - or = size(array)-1 depending on whether array(0) or array(ia-1) is - closest to "value" - - Arguments: - value: arbitrary data...same units as elements in "array" - array: array of data points (must be monotonically increasing) - ia : size of array. - -********************************************************************/ -int nearest_index(double value, const double *array, int ia) -{ - int index, i; - int keep_going; - - for(i=1; i array[ia-1]) - index = ia-1; - else - { - i=0; - keep_going = 1; - while (i < ia && keep_going) { - i = i+1; - if (value <= array[i]) { - index = i; - if (array[i]-value > value-array[i-1]) index = i-1; - keep_going = 0; - } - } - } - return index; - -} - -/******************************************************************/ - -void tokenize(const char * const string, const char *tokens, unsigned int varlen, - unsigned int maxvar, char * pstring, unsigned int * const nstr) -{ - size_t i, j, nvar, len, ntoken; - int found, n; - - nvar = 0; j = 0; - len = strlen(string); - ntoken = strlen(tokens); - /* here we use the fact that C array [][] is contiguous in memory */ - if(string[0] == 0)error_handler("Error from tokenize: to-be-parsed string is empty"); - - for(i = 0; i < len; i ++){ - if(string[i] != ' ' && string[i] != '\t'){ - found = 0; - for(n=0; n= maxvar) error_handler("Error from tokenize: number of variables exceeds limit"); - } - } - else { - *(pstring + nvar*varlen + j++) = string[i]; - if(j >= varlen ) error_handler("error from tokenize: variable name length exceeds limit during tokenization"); - } - } - } - *(pstring + nvar*varlen + j) = 0; - - *nstr = ++nvar; - -} - -/******************************************************************************* - double maxval_double(int size, double *data) - get the maximum value of double array -*******************************************************************************/ -double maxval_double(int size, const double *data) -{ - int n; - double maxval; - - maxval = data[0]; - for(n=1; n maxval ) maxval = data[n]; - } - - return maxval; - -} /* maxval_double */ - - -/******************************************************************************* - double minval_double(int size, double *data) - get the minimum value of double array -*******************************************************************************/ -double minval_double(int size, const double *data) -{ - int n; - double minval; - - minval = data[0]; - for(n=1; n M_PI) dx = dx - 2.0*M_PI; - if(dx < -M_PI) dx = dx + 2.0*M_PI; - - return (dx*(sin(ur_lat)-sin(ll_lat))*RADIUS*RADIUS ) ; - -} /* box_area */ - - -/*------------------------------------------------------------------------------ - double poly_area(const x[], const y[], int n) - obtains area of input polygon by line integrating -sin(lat)d(lon) - Vertex coordinates must be in degrees. - Vertices must be listed counter-clockwise around polygon. - grid is in radians. - ----------------------------------------------------------------------------*/ -double poly_area_dimensionless(const double x[], const double y[], int n) -{ - double area = 0.0; - int i; - - for (i=0;i M_PI) dx = dx - 2.0*M_PI; - if(dx < -M_PI) dx = dx + 2.0*M_PI; - if (dx==0.0) continue; - - if ( fabs(lat1-lat2) < SMALL_VALUE) /* cheap area calculation along latitude */ - area -= dx*sin(0.5*(lat1+lat2)); - else { - dy = 0.5*(lat1-lat2); - dat = sin(dy)/dy; - area -= dx*sin(0.5*(lat1+lat2))*dat; - } - } - if(area < 0) - return (-area/(4*M_PI)); - else - return (area/(4*M_PI)); - -} /* poly_area */ - -double poly_area(const double x[], const double y[], int n) -{ - double area = 0.0; - int i; - - for (i=0;i M_PI) dx = dx - 2.0*M_PI; - if(dx < -M_PI) dx = dx + 2.0*M_PI; - if (dx==0.0) continue; - - if ( fabs(lat1-lat2) < SMALL_VALUE) /* cheap area calculation along latitude */ - area -= dx*sin(0.5*(lat1+lat2)); - else { - dy = 0.5*(lat1-lat2); - dat = sin(dy)/dy; - area -= dx*sin(0.5*(lat1+lat2))*dat; - } - } - if(area < 0) - return -area*RADIUS*RADIUS; - else - return area*RADIUS*RADIUS; - -} /* poly_area */ - -double poly_area_no_adjust(const double x[], const double y[], int n) -{ - double area = 0.0; - int i; - - for (i=0;i=n_ins;i--) { - x[i+1] = x[i]; - y[i+1] = y[i]; - } - - x[n_ins] = lon_in; - y[n_ins] = lat_in; - return (n+1); -} /* insert_vtx */ - -void v_print(double x[], double y[], int n) -{ - int i; - - for (i=0;i=HPI-TOLORENCE) pole = 1; - if (0&&pole) { - printf("fixing pole cell\n"); - v_print(x, y, nn); - printf("---------"); - } - - /* all pole points must be paired */ - for (i=0;i=HPI-TOLORENCE) { - int im=(i+nn-1)%nn, ip=(i+1)%nn; - - if (y[im]==y[i] && y[ip]==y[i]) { - nn = delete_vtx(x, y, nn, i); - i--; - } else if (y[im]!=y[i] && y[ip]!=y[i]) { - nn = insert_vtx(x, y, nn, i, x[i], y[i]); - i++; - } - } - /* first of pole pair has longitude of previous vertex */ - /* second of pole pair has longitude of subsequent vertex */ - for (i=0;i=HPI-TOLORENCE) { - int im=(i+nn-1)%nn, ip=(i+1)%nn; - - if (y[im]!=y[i]){ - x[i] = x[im]; - } - if (y[ip]!=y[i]){ - x[i] = x[ip]; - } - } - - if (nn){ - x_sum = x[0]; - } - else{ - return(0); - } - for (i=1;i M_PI) dx_ = dx_ - TPI; - x_sum += (x[i] = x[i-1] + dx_); - } - - dx = (x_sum/nn)-tlon; - if (dx < -M_PI){ - for (i=0;i M_PI){ - for (i=0;i angle - \ - \ - p2 - -----------------------------------------------------------------------------*/ -double spherical_angle(const double *v1, const double *v2, const double *v3) -{ - double angle; - long double px, py, pz, qx, qy, qz, ddd; - - /* vector product between v1 and v2 */ - px = v1[1]*v2[2] - v1[2]*v2[1]; - py = v1[2]*v2[0] - v1[0]*v2[2]; - pz = v1[0]*v2[1] - v1[1]*v2[0]; - /* vector product between v1 and v3 */ - qx = v1[1]*v3[2] - v1[2]*v3[1]; - qy = v1[2]*v3[0] - v1[0]*v3[2]; - qz = v1[0]*v3[1] - v1[1]*v3[0]; - - ddd = (px*px+py*py+pz*pz)*(qx*qx+qy*qy+qz*qz); - if ( ddd <= 0.0 ) - angle = 0. ; - else { - ddd = (px*qx+py*qy+pz*qz) / sqrtl(ddd); - if( fabsl(ddd-1) < EPSLN30 ) ddd = 1; - if( fabsl(ddd+1) < EPSLN30 ) ddd = -1; - if ( ddd>1. || ddd<-1. ) { - /*FIX (lmh) to correctly handle co-linear points (angle near pi or 0) */ - if (ddd < 0.) - angle = M_PI; - else - angle = 0.; - } - else - angle = ((double)acosl( ddd )); - } - - return angle; -} /* spherical_angle */ - -/*------------------------------------------------------------------------------ - double spherical_excess_area(p_lL, p_uL, p_lR, p_uR) - get the surface area of a cell defined as a quadrilateral - on the sphere. Area is computed as the spherical excess - [area units are m^2] - ----------------------------------------------------------------------------*/ -double spherical_excess_area(const double* p_ll, const double* p_ul, - const double* p_lr, const double* p_ur, double radius) -{ - double area, ang1, ang2, ang3, ang4; - double v1[3], v2[3], v3[3]; - - /* S-W: 1 */ - latlon2xyz(1, p_ll, p_ll+1, v1, v1+1, v1+2); - latlon2xyz(1, p_lr, p_lr+1, v2, v2+1, v2+2); - latlon2xyz(1, p_ul, p_ul+1, v3, v3+1, v3+2); - ang1 = spherical_angle(v1, v2, v3); - - /* S-E: 2 */ - latlon2xyz(1, p_lr, p_lr+1, v1, v1+1, v1+2); - latlon2xyz(1, p_ur, p_ur+1, v2, v2+1, v2+2); - latlon2xyz(1, p_ll, p_ll+1, v3, v3+1, v3+2); - ang2 = spherical_angle(v1, v2, v3); - - /* N-E: 3 */ - latlon2xyz(1, p_ur, p_ur+1, v1, v1+1, v1+2); - latlon2xyz(1, p_ul, p_ul+1, v2, v2+1, v2+2); - latlon2xyz(1, p_lr, p_lr+1, v3, v3+1, v3+2); - ang3 = spherical_angle(v1, v2, v3); - - /* N-W: 4 */ - latlon2xyz(1, p_ul, p_ul+1, v1, v1+1, v1+2); - latlon2xyz(1, p_ur, p_ur+1, v2, v2+1, v2+2); - latlon2xyz(1, p_ll, p_ll+1, v3, v3+1, v3+2); - ang4 = spherical_angle(v1, v2, v3); - - area = (ang1 + ang2 + ang3 + ang4 - 2.*M_PI) * radius* radius; - - return area; - -} /* spherical_excess_area */ - - -/*---------------------------------------------------------------------- - void vect_cross(e, p1, p2) - Perform cross products of 3D vectors: e = P1 X P2 - -------------------------------------------------------------------*/ - -void vect_cross(const double *p1, const double *p2, double *e ) -{ - - e[0] = p1[1]*p2[2] - p1[2]*p2[1]; - e[1] = p1[2]*p2[0] - p1[0]*p2[2]; - e[2] = p1[0]*p2[1] - p1[1]*p2[0]; - -} /* vect_cross */ - - -/*---------------------------------------------------------------------- - double* vect_cross(p1, p2) - return cross products of 3D vectors: = P1 X P2 - -------------------------------------------------------------------*/ - -double dot(const double *p1, const double *p2) -{ - - return( p1[0]*p2[0] + p1[1]*p2[1] + p1[2]*p2[2] ); - -} - - -double metric(const double *p) { - return (sqrt(p[0]*p[0] + p[1]*p[1]+p[2]*p[2]) ); -} - - -/* ---------------------------------------------------------------- - make a unit vector - --------------------------------------------------------------*/ -void normalize_vect(double *e) -{ - double pdot; - int k; - - pdot = e[0]*e[0] + e[1] * e[1] + e[2] * e[2]; - pdot = sqrt( pdot ); - - for(k=0; k<3; k++) e[k] /= pdot; -} - - -/*------------------------------------------------------------------ - void unit_vect_latlon(int size, lon, lat, vlon, vlat) - - calculate unit vector for latlon in cartesian coordinates - - ---------------------------------------------------------------------*/ -void unit_vect_latlon(int size, const double *lon, const double *lat, double *vlon, double *vlat) -{ - double sin_lon, cos_lon, sin_lat, cos_lat; - int n; - - for(n=0; n MAXNODELIST) error_handler("getNext: curListPos >= MAXNODELIST"); - - return (temp); -} - - -void initNode(struct Node *node) -{ - node->x = 0; - node->y = 0; - node->z = 0; - node->u = 0; - node->intersect = 0; - node->inbound = 0; - node->isInside = 0; - node->Next = NULL; - node->initialized=0; - -} - -void addEnd(struct Node *list, double x, double y, double z, int intersect, double u, int inbound, int inside) -{ - - struct Node *temp=NULL; - - if(list == NULL) error_handler("addEnd: list is NULL"); - - if(list->initialized) { - - /* (x,y,z) might already in the list when intersect is true and u=0 or 1 */ - temp = list; - while (temp) { - if(samePoint(temp->x, temp->y, temp->z, x, y, z)) return; - temp=temp->Next; - } - temp = list; - while(temp->Next) - temp=temp->Next; - - /* Append at the end of the list. */ - temp->Next = getNext(); - temp = temp->Next; - } - else { - temp = list; - } - - temp->x = x; - temp->y = y; - temp->z = z; - temp->u = u; - temp->intersect = intersect; - temp->inbound = inbound; - temp->initialized=1; - temp->isInside = inside; -} - -/* return 1 if the point (x,y,z) is added in the list, return 0 if it is already in the list */ - -int addIntersect(struct Node *list, double x, double y, double z, int intersect, double u1, double u2, int inbound, - int is1, int ie1, int is2, int ie2) -{ - - double u1_cur, u2_cur; - int i1_cur, i2_cur; - struct Node *temp=NULL; - - if(list == NULL) error_handler("addEnd: list is NULL"); - - /* first check to make sure this point is not in the list */ - u1_cur = u1; - i1_cur = is1; - u2_cur = u2; - i2_cur = is2; - if(u1_cur == 1) { - u1_cur = 0; - i1_cur = ie1; - } - if(u2_cur == 1) { - u2_cur = 0; - i2_cur = ie2; - } - - if(list->initialized) { - temp = list; - while(temp) { - if( temp->u == u1_cur && temp->subj_index == i1_cur) return 0; - if( temp->u_clip == u2_cur && temp->clip_index == i2_cur) return 0; - if( !temp->Next ) break; - temp=temp->Next; - } - - /* Append at the end of the list. */ - temp->Next = getNext(); - temp = temp->Next; - } - else { - temp = list; - } - - temp->x = x; - temp->y = y; - temp->z = z; - temp->intersect = intersect; - temp->inbound = inbound; - temp->initialized=1; - temp->isInside = 0; - temp->u = u1_cur; - temp->subj_index = i1_cur; - temp->u_clip = u2_cur; - temp->clip_index = i2_cur; - - return 1; -} - - -int length(struct Node *list) -{ - struct Node *cur_ptr=NULL; - int count=0; - - cur_ptr=list; - - while(cur_ptr) - { - if(cur_ptr->initialized ==0) break; - cur_ptr=cur_ptr->Next; - count++; - } - return(count); -} - -/* two points are the same if there are close enough */ -int samePoint(double x1, double y1, double z1, double x2, double y2, double z2) -{ - if( fabs(x1-x2) > EPSLN10 || fabs(y1-y2) > EPSLN10 || fabs(z1-z2) > EPSLN10 ) - return 0; - else - return 1; -} - - - -int sameNode(struct Node node1, struct Node node2) -{ - if( node1.x == node2.x && node1.y == node2.y && node1.z==node2.z ) - return 1; - else - return 0; -} - - -void addNode(struct Node *list, struct Node inNode) -{ - - addEnd(list, inNode.x, inNode.y, inNode.z, inNode.intersect, inNode.u, inNode.inbound, inNode.isInside); - -} - -struct Node *getNode(struct Node *list, struct Node inNode) -{ - struct Node *thisNode=NULL; - struct Node *temp=NULL; - - temp = list; - while( temp ) { - if( sameNode( *temp, inNode ) ) { - thisNode = temp; - temp = NULL; - break; - } - temp = temp->Next; - } - - return thisNode; -} - -struct Node *getNextNode(struct Node *list) -{ - return list->Next; -} - -void copyNode(struct Node *node_out, struct Node node_in) -{ - - node_out->x = node_in.x; - node_out->y = node_in.y; - node_out->z = node_in.z; - node_out->u = node_in.u; - node_out->intersect = node_in.intersect; - node_out->inbound = node_in.inbound; - node_out->Next = NULL; - node_out->initialized = node_in.initialized; - node_out->isInside = node_in.isInside; -} - -void printNode(struct Node *list, char *str) -{ - struct Node *temp; - - if(list == NULL) error_handler("printNode: list is NULL"); - if(str) printf(" %s \n", str); - temp = list; - while(temp) { - if(temp->initialized ==0) break; - printf(" (x, y, z, interset, inbound, isInside) = (%19.15f,%19.15f,%19.15f,%d,%d,%d)\n", - temp->x, temp->y, temp->z, temp->intersect, temp->inbound, temp->isInside); - temp = temp->Next; - } - printf("\n"); -} - -int intersectInList(struct Node *list, double x, double y, double z) -{ - struct Node *temp; - int found=0; - - temp = list; - found = 0; - while ( temp ) { - if( temp->x == x && temp->y == y && temp->z == z ) { - found = 1; - break; - } - temp=temp->Next; - } - if (!found) error_handler("intersectInList: point (x,y,z) is not found in the list"); - if( temp->intersect == 2 ) - return 1; - else - return 0; - -} - - -/* The following insert a intersection after non-intersect point (x2,y2,z2), if the point - after (x2,y2,z2) is an intersection, if u is greater than the u value of the intersection, - insert after, otherwise insert before -*/ -void insertIntersect(struct Node *list, double x, double y, double z, double u1, double u2, int inbound, - double x2, double y2, double z2) -{ - struct Node *temp1=NULL, *temp2=NULL; - struct Node *temp; - double u_cur; - int found=0; - - temp1 = list; - found = 0; - while ( temp1 ) { - if( temp1->x == x2 && temp1->y == y2 && temp1->z == z2 ) { - found = 1; - break; - } - temp1=temp1->Next; - } - if (!found) error_handler("inserAfter: point (x,y,z) is not found in the list"); - - /* when u = 0 or u = 1, set the grid point to be the intersection point to solve truncation error isuse */ - u_cur = u1; - if(u1 == 1) { - u_cur = 0; - temp1 = temp1->Next; - if(!temp1) temp1 = list; - } - if(u_cur==0) { - temp1->intersect = 2; - temp1->isInside = 1; - temp1->u = u_cur; - temp1->x = x; - temp1->y = y; - temp1->z = z; - return; - } - - /* when u2 != 0 and u2 !=1, can decide if one end of the point is outside depending on inbound value */ - if(u2 != 0 && u2 != 1) { - if(inbound == 1) { /* goes outside, then temp1->Next is an outside point */ - /* find the next non-intersect point */ - temp2 = temp1->Next; - if(!temp2) temp2 = list; - while(temp2->intersect) { - temp2=temp2->Next; - if(!temp2) temp2 = list; - } - - temp2->isInside = 0; - } - else if(inbound ==2) { /* goes inside, then temp1 is an outside point */ - temp1->isInside = 0; - } - } - - temp2 = temp1->Next; - while ( temp2 ) { - if( temp2->intersect == 1 ) { - if( temp2->u > u_cur ) { - break; - } - } - else - break; - temp1 = temp2; - temp2 = temp2->Next; - } - - /* assign value */ - temp = getNext(); - temp->x = x; - temp->y = y; - temp->z = z; - temp->u = u_cur; - temp->intersect = 1; - temp->inbound = inbound; - temp->isInside = 1; - temp->initialized = 1; - temp1->Next = temp; - temp->Next = temp2; - -} - -double gridArea(struct Node *grid) { - double x[20], y[20], z[20]; - struct Node *temp=NULL; - double area; - int n; - - temp = grid; - n = 0; - while( temp ) { - x[n] = temp->x; - y[n] = temp->y; - z[n] = temp->z; - n++; - temp = temp->Next; - } - - area = great_circle_area(n, x, y, z); - - return area; - -} - -int isIntersect(struct Node node) { - - return node.intersect; - -} - - -int getInbound( struct Node node ) -{ - return node.inbound; -} - -struct Node *getLast(struct Node *list) -{ - struct Node *temp1; - - temp1 = list; - if( temp1 ) { - while( temp1->Next ) { - temp1 = temp1->Next; - } - } - - return temp1; -} - - -int getFirstInbound( struct Node *list, struct Node *nodeOut) -{ - struct Node *temp=NULL; - - temp=list; - - while(temp) { - if( temp->inbound == 2 ) { - copyNode(nodeOut, *temp); - return 1; - } - temp=temp->Next; - } - - return 0; -} - -void getCoordinate(struct Node node, double *x, double *y, double *z) -{ - - - *x = node.x; - *y = node.y; - *z = node.z; - -} - -void getCoordinates(struct Node *node, double *p) -{ - - - p[0] = node->x; - p[1] = node->y; - p[2] = node->z; - -} - -void setCoordinate(struct Node *node, double x, double y, double z) -{ - - - node->x = x; - node->y = y; - node->z = z; - -} - -/* set inbound value for the points in interList that has inbound =0, - this will also set some inbound value of the points in list1 -*/ - -void setInbound(struct Node *interList, struct Node *list) -{ - - struct Node *temp1=NULL, *temp=NULL; - struct Node *temp1_prev=NULL, *temp1_next=NULL; - int prev_is_inside, next_is_inside; - - /* for each point in interList, search through list to decide the inbound value the interList point */ - /* For each inbound point, the prev node should be outside and the next is inside. */ - if(length(interList) == 0) return; - - temp = interList; - - while(temp) { - if( !temp->inbound) { - /* search in grid1 to find the prev and next point of temp, when prev point is outside and next point is inside - inbound = 2, else inbound = 1*/ - temp1 = list; - temp1_prev = NULL; - temp1_next = NULL; - while(temp1) { - if(sameNode(*temp1, *temp)) { - if(!temp1_prev) temp1_prev = getLast(list); - temp1_next = temp1->Next; - if(!temp1_next) temp1_next = list; - break; - } - temp1_prev = temp1; - temp1 = temp1->Next; - } - if(!temp1_next) error_handler("Error from create_xgrid.c: temp is not in list1"); - if( temp1_prev->isInside == 0 && temp1_next->isInside == 1) - temp->inbound = 2; /* go inside */ - else - temp->inbound = 1; - } - temp=temp->Next; - } -} - -int isInside(struct Node *node) { - - if(node->isInside == -1) error_handler("Error from mosaic_util.c: node->isInside is not set"); - return(node->isInside); - -} - -/* #define debug_test_create_xgrid */ - -/* check if node is inside polygon list or not */ -int insidePolygon( struct Node *node, struct Node *list) -{ - int is_inside; - double pnt0[3], pnt1[3], pnt2[3]; - double anglesum; - struct Node *p1=NULL, *p2=NULL; - - anglesum = 0; - - pnt0[0] = node->x; - pnt0[1] = node->y; - pnt0[2] = node->z; - - p1 = list; - p2 = list->Next; - is_inside = 0; - - - while(p1) { - pnt1[0] = p1->x; - pnt1[1] = p1->y; - pnt1[2] = p1->z; - pnt2[0] = p2->x; - pnt2[1] = p2->y; - pnt2[2] = p2->z; - if( samePoint(pnt0[0], pnt0[1], pnt0[2], pnt1[0], pnt1[1], pnt1[2]) ){ - return 1; - } - anglesum += spherical_angle(pnt0, pnt2, pnt1); - p1 = p1->Next; - p2 = p2->Next; - if(p2==NULL){ - p2 = list; - } - } - - if( fabs(anglesum - 2*M_PI) < EPSLN8 ){ - is_inside = 1; - } - else{ - is_inside = 0; - } - -#ifdef debug_test_create_xgrid - printf("anglesum-2PI is %19.15f, is_inside = %d\n", anglesum- 2*M_PI, is_inside); -#endif - - return is_inside; - -} - -int inside_a_polygon(double *lon1, double *lat1, int *npts, double *lon2, double *lat2) -{ - - double x2[20], y2[20], z2[20]; - double x1, y1, z1; - double min_x2, max_x2, min_y2, max_y2, min_z2, max_z2; - int isinside, i; - - struct Node *grid1=NULL, *grid2=NULL; - - /* first convert to cartesian grid */ - latlon2xyz(*npts, lon2, lat2, x2, y2, z2); - latlon2xyz(1, lon1, lat1, &x1, &y1, &z1); - - max_x2 = maxval_double(*npts, x2); - if(x1 >= max_x2+RANGE_CHECK_CRITERIA) return 0; - min_x2 = minval_double(*npts, x2); - if(min_x2 >= x1+RANGE_CHECK_CRITERIA) return 0; - - max_y2 = maxval_double(*npts, y2); - if(y1 >= max_y2+RANGE_CHECK_CRITERIA) return 0; - min_y2 = minval_double(*npts, y2); - if(min_y2 >= y1+RANGE_CHECK_CRITERIA) return 0; - - max_z2 = maxval_double(*npts, z2); - if(z1 >= max_z2+RANGE_CHECK_CRITERIA) return 0; - min_z2 = minval_double(*npts, z2); - if(min_z2 >= z1+RANGE_CHECK_CRITERIA) return 0; - - - /* add x2,y2,z2 to a Node */ - rewindList(); - grid1 = getNext(); - grid2 = getNext(); - - addEnd(grid1, x1, y1, z1, 0, 0, 0, -1); - for(i=0; i<*npts; i++) addEnd(grid2, x2[i], y2[i], z2[i], 0, 0, 0, -1); - - isinside = insidePolygon(grid1, grid2); - - return isinside; - -} - -int inside_a_polygon_(double *lon1, double *lat1, int *npts, double *lon2, double *lat2) -{ - - int isinside; - - isinside = inside_a_polygon(lon1, lat1, npts, lon2, lat2); - - return isinside; - -} diff --git a/mosaic/read_mosaic.c b/mosaic/read_mosaic.c deleted file mode 100644 index 9fafad1f2b..0000000000 --- a/mosaic/read_mosaic.c +++ /dev/null @@ -1,779 +0,0 @@ -/*********************************************************************** - * 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 -#include -#include -#include -#include "read_mosaic.h" -#include "constant.h" -#include "mosaic_util.h" -#include - -/** \file - * \ingroup mosaic - * \brief Support for reading mosaic netcdf grid files. - */ - -/********************************************************************* - void netcdf_error( int status ) - status is the returning value of netcdf call. this routine will - handle the error when status is not NC_NOERR. -********************************************************************/ -void handle_netcdf_error(const char *msg, int status ) -{ - char errmsg[512]; - - sprintf( errmsg, "%s: %s", msg, (char *)nc_strerror(status) ); - error_handler(errmsg); - -} /* handle_netcdf_error */ - -/*************************************************************************** - void get_file_dir(const char *file, char *dir) - get the directory where file is located. The dir will be the complate path - before the last "/". If no "/" exist in file, the path will be current ".". -***************************************************************************/ -void get_file_dir(const char *file, char *dir) -{ - int len; - const char *strptr = NULL; - - /* get the diretory */ - - strptr = strrchr(file, '/'); - if(strptr) { - len = strptr - file; - strncpy(dir, file, len); - } - else { - len = 1; - strcpy(dir, "."); - } - dir[len] = 0; - -} /* get_file_dir */ - - -int field_exist(const char* file, const char *name) -{ - int ncid, varid, status; - char msg[512]; - int existed=0; - -#ifdef use_netCDF - - status = nc_open(file, NC_NOWRITE, &ncid); - if(status != NC_NOERR) { - sprintf(msg, "field_exist: in opening file %s", file); - handle_netcdf_error(msg, status); - } - - status = nc_inq_varid(ncid, name, &varid); - if(status == NC_NOERR){ - existed = 1; - } - - status = nc_close(ncid); - if(status != NC_NOERR) { - sprintf(msg, "field_exist: in closing file %s.", file); - handle_netcdf_error(msg, status); - } - -#else /* ndef use_netCDF */ - error_handler("read_mosaic: Add flag -Duse_netCDF when compiling"); -#endif /* use_netcdf */ - - return existed; - -} /* field_exist */ - -int get_dimlen(const char* file, const char *name) -{ - int ncid, dimid, status, len; - size_t size; - char msg[512]; - - len = 0; -#ifdef use_netCDF - status = nc_open(file, NC_NOWRITE, &ncid); - if(status != NC_NOERR) { - sprintf(msg, "in opening file %s", file); - handle_netcdf_error(msg, status); - } - - status = nc_inq_dimid(ncid, name, &dimid); - if(status != NC_NOERR) { - sprintf(msg, "in getting dimid of %s from file %s.", name, file); - handle_netcdf_error(msg, status); - } - - status = nc_inq_dimlen(ncid, dimid, &size); - if(status != NC_NOERR) { - sprintf(msg, "in getting dimension size of %s from file %s.", name, file); - handle_netcdf_error(msg, status); - } - status = nc_close(ncid); - if(status != NC_NOERR) { - sprintf(msg, "in closing file %s.", file); - handle_netcdf_error(msg, status); - } - - len = size; - if(status != NC_NOERR) { - sprintf(msg, "in closing file %s", file); - handle_netcdf_error(msg, status); - } -#else - error_handler("read_mosaic: Add flag -Duse_netCDF when compiling"); -#endif - - return len; - -} /* get_dimlen */ - -/******************************************************************************* - void get_string_data(const char *file, const char *name, char *data) - get string data of field with "name" from "file". -******************************************************************************/ -void get_string_data(const char *file, const char *name, char *data) -{ - int ncid, varid, status; - char msg[512]; - -#ifdef use_netCDF - status = nc_open(file, NC_NOWRITE, &ncid); - if(status != NC_NOERR) { - sprintf(msg, "in opening file %s", file); - handle_netcdf_error(msg, status); - } - status = nc_inq_varid(ncid, name, &varid); - if(status != NC_NOERR) { - sprintf(msg, "in getting varid of %s from file %s.", name, file); - handle_netcdf_error(msg, status); - } - status = nc_get_var_text(ncid, varid, data); - if(status != NC_NOERR) { - sprintf(msg, "in getting data of %s from file %s.", name, file); - handle_netcdf_error(msg, status); - } - status = nc_close(ncid); - if(status != NC_NOERR) { - sprintf(msg, "in closing file %s.", file); - handle_netcdf_error(msg, status); - } -#else - error_handler("read_mosaic: Add flag -Duse_netCDF when compiling"); -#endif - -} /* get_string_data */ - -/******************************************************************************* - void get_string_data_level(const char *file, const char *name, const size_t *start, const size_t *nread, char *data) - get string data of field with "name" from "file". -******************************************************************************/ -void get_string_data_level(const char *file, const char *name, char *data, const unsigned int *level) -{ - int ncid, varid, status, i; - size_t start[4], nread[4]; - char msg[512]; - -#ifdef use_netCDF - status = nc_open(file, NC_NOWRITE, &ncid); - if(status != NC_NOERR) { - sprintf(msg, "in opening file %s", file); - handle_netcdf_error(msg, status); - } - status = nc_inq_varid(ncid, name, &varid); - if(status != NC_NOERR) { - sprintf(msg, "in getting varid of %s from file %s.", name, file); - handle_netcdf_error(msg, status); - } - for(i=0; i<4; i++) { - start[i] = 0; nread[i] = 1; - } - start[0] = *level; nread[1] = STRING; - status = nc_get_vara_text(ncid, varid, start, nread, data); - if(status != NC_NOERR) { - sprintf(msg, "in getting data of %s from file %s.", name, file); - handle_netcdf_error(msg, status); - } - status = nc_close(ncid); - if(status != NC_NOERR) { - sprintf(msg, "in closing file %s.", file); - handle_netcdf_error(msg, status); - } -#else - error_handler("read_mosaic: Add flag -Duse_netCDF when compiling"); -#endif - -} /* get_string_data_level */ - - -/******************************************************************************* - void get_var_data(const char *file, const char *name, double *data) - get var data of field with "name" from "file". -******************************************************************************/ -void get_var_data(const char *file, const char *name, void *data) -{ - - int ncid, varid, status; - nc_type vartype; - char msg[512]; - -#ifdef use_netCDF - status = nc_open(file, NC_NOWRITE, &ncid); - if(status != NC_NOERR) { - sprintf(msg, "in opening file %s", file); - handle_netcdf_error(msg, status); - } - status = nc_inq_varid(ncid, name, &varid); - if(status != NC_NOERR) { - sprintf(msg, "in getting varid of %s from file %s.", name, file); - handle_netcdf_error(msg, status); - } - - status = nc_inq_vartype(ncid, varid, &vartype); - if(status != NC_NOERR) { - sprintf(msg, "get_var_data: in getting vartype of of %s in file %s ", name, file); - handle_netcdf_error(msg, status); - } - - switch (vartype) { - case NC_DOUBLE:case NC_FLOAT: - status = nc_get_var_double(ncid, varid, (double *)data); - break; - case NC_INT: - status = nc_get_var_int(ncid, varid, (int *)data); - break; - default: - sprintf(msg, "get_var_data: field %s in file %s has an invalid type, " - "the type should be NC_DOUBLE, NC_FLOAT or NC_INT", name, file); - error_handler(msg); - } - if(status != NC_NOERR) { - sprintf(msg, "in getting data of %s from file %s.", name, file); - handle_netcdf_error(msg, status); - } - status = nc_close(ncid); - if(status != NC_NOERR) { - sprintf(msg, "in closing file %s.", file); - handle_netcdf_error(msg, status); - } -#else - error_handler("read_mosaic: Add flag -Duse_netCDF when compiling"); -#endif - -} /* get_var_data */ - -/******************************************************************************* - void get_var_data(const char *file, const char *name, double *data) - get var data of field with "name" from "file". -******************************************************************************/ -void get_var_data_region(const char *file, const char *name, const size_t *start, const size_t *nread, void *data) -{ - - int ncid, varid, status; - nc_type vartype; - char msg[512]; - -#ifdef use_netCDF - status = nc_open(file, NC_NOWRITE, &ncid); - if(status != NC_NOERR) { - sprintf(msg, "get_var_data_region: in opening file %s", file); - handle_netcdf_error(msg, status); - } - status = nc_inq_varid(ncid, name, &varid); - if(status != NC_NOERR) { - sprintf(msg, "in getting varid of %s from file %s.", name, file); - handle_netcdf_error(msg, status); - } - - status = nc_inq_vartype(ncid, varid, &vartype); - if(status != NC_NOERR) { - sprintf(msg, "get_var_data_region: in getting vartype of of %s in file %s ", name, file); - handle_netcdf_error(msg, status); - } - - switch (vartype) { - case NC_DOUBLE:case NC_FLOAT: - status = nc_get_vara_double(ncid, varid, start, nread, (double *)data); - break; - case NC_INT: - status = nc_get_vara_int(ncid, varid, start, nread, (int *)data); - break; - default: - sprintf(msg, "get_var_data_region: field %s in file %s has an invalid type, " - "the type should be NC_DOUBLE, NC_FLOAT or NC_INT", name, file); - error_handler(msg); - } - - if(status != NC_NOERR) { - sprintf(msg, "get_var_data_region: in getting data of %s from file %s.", name, file); - handle_netcdf_error(msg, status); - } - status = nc_close(ncid); - if(status != NC_NOERR) { - sprintf(msg, "get_var_data_region: in closing file %s.", file); - handle_netcdf_error(msg, status); - } -#else - error_handler("read_mosaic: Add flag -Duse_netCDF when compiling"); -#endif - -} /* get_var_data_region */ - -/****************************************************************************** - void get_var_text_att(const char *file, const char *name, const char *attname, char *att) - get text attribute of field 'name' from 'file -******************************************************************************/ -void get_var_text_att(const char *file, const char *name, const char *attname, char *att) -{ - int ncid, varid, status; - char msg[512]; - -#ifdef use_netCDF - status = nc_open(file, NC_NOWRITE, &ncid); - if(status != NC_NOERR) { - sprintf(msg, "in opening file %s", file); - handle_netcdf_error(msg, status); - } - status = nc_inq_varid(ncid, name, &varid); - if(status != NC_NOERR) { - sprintf(msg, "in getting varid of %s from file %s.", name, file); - handle_netcdf_error(msg, status); - } - status = nc_get_att_text(ncid, varid, attname, att); - if(status != NC_NOERR) { - sprintf(msg, "in getting attribute %s of %s from file %s.", attname, name, file); - handle_netcdf_error(msg, status); - } - status = nc_close(ncid); - if(status != NC_NOERR) { - sprintf(msg, "in closing file %s.", file); - handle_netcdf_error(msg, status); - } -#else - error_handler("read_mosaic: Add flag -Duse_netCDF when compiling"); -#endif - -} /* get_var_text_att */ - -/*********************************************************************** - return number of overlapping cells. -***********************************************************************/ -int read_mosaic_xgrid_size_( const char *xgrid_file ) -{ - return read_mosaic_xgrid_size(xgrid_file); -} - -int read_mosaic_xgrid_size( const char *xgrid_file ) -{ - int ncells; - - ncells = get_dimlen(xgrid_file, "ncells"); - return ncells; -} - - double get_global_area(void) - { - double garea; - garea = 4*M_PI*RADIUS*RADIUS; - - return garea; - } - - double get_global_area_(void) - { - double garea; - garea = 4*M_PI*RADIUS*RADIUS; - - return garea; - } - - - /****************************************************************************/ - void read_mosaic_xgrid_order1_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area ) - { - read_mosaic_xgrid_order1(xgrid_file, i1, j1, i2, j2, area); - - } - - void read_mosaic_xgrid_order1(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area ) - { - int ncells, n; - int *tile1_cell, *tile2_cell; - double garea; - - ncells = get_dimlen(xgrid_file, "ncells"); - - tile1_cell = (int *)malloc(ncells*2*sizeof(int)); - tile2_cell = (int *)malloc(ncells*2*sizeof(int)); - get_var_data(xgrid_file, "tile1_cell", tile1_cell); - get_var_data(xgrid_file, "tile2_cell", tile2_cell); - - get_var_data(xgrid_file, "xgrid_area", area); - - garea = 4*M_PI*RADIUS*RADIUS; - - for(n=0; n istart_in ) { - istart_out[0] = istart_in - 1; - iend_out[0] = iend_in - refine_ratio; - } - else { - istart_out[0] = istart_in - refine_ratio; - iend_out[0] = iend_in - 1; - } - - if( istart_out[0]%refine_ratio || iend_out[0]%refine_ratio) - error_handler("Error from read_mosaic: mismatch between refine_ratio and istart_in/iend_in"); - istart_out[0] /= refine_ratio; - iend_out[0] /= refine_ratio; - } - - return type; - - } - - - void read_mosaic_contact(const char *mosaic_file, int *tile1, int *tile2, int *istart1, int *iend1, - int *jstart1, int *jend1, int *istart2, int *iend2, int *jstart2, int *jend2) - { - char contacts[STRING]; - char **gridtiles; -#define MAXVAR 40 - char pstring[MAXVAR][STRING]; - unsigned int nstr, ntiles, ncontacts, n, m, l, found; - const int x_refine = 2, y_refine = 2; - int i1_type, j1_type, i2_type, j2_type; - - ntiles = get_dimlen(mosaic_file, "ntiles"); - gridtiles = (char **)malloc(ntiles*sizeof(char *)); - for(n=0; n '9' || pstring[m][l] < '0' ) { - error_handler("Error from read_mosaic: some of the character in " - "contact_indices except token is not digit number"); - } - } - } - istart1[n] = atoi(pstring[0]); - iend1[n] = atoi(pstring[1]); - jstart1[n] = atoi(pstring[2]); - jend1[n] = atoi(pstring[3]); - istart2[n] = atoi(pstring[4]); - iend2[n] = atoi(pstring[5]); - jstart2[n] = atoi(pstring[6]); - jend2[n] = atoi(pstring[7]); - i1_type = transfer_to_model_index(istart1[n], iend1[n], istart1+n, iend1+n, x_refine); - j1_type = transfer_to_model_index(jstart1[n], jend1[n], jstart1+n, jend1+n, y_refine); - i2_type = transfer_to_model_index(istart2[n], iend2[n], istart2+n, iend2+n, x_refine); - j2_type = transfer_to_model_index(jstart2[n], jend2[n], jstart2+n, jend2+n, y_refine); - if( i1_type == 0 && j1_type == 0 ) - error_handler("Error from read_mosaic_contact:istart1==iend1 and jstart1==jend1"); - if( i2_type == 0 && j2_type == 0 ) - error_handler("Error from read_mosaic_contact:istart2==iend2 and jstart2==jend2"); - if( i1_type + j1_type != i2_type + j2_type ) - error_handler("Error from read_mosaic_contact: It is not a line or overlap contact"); - - } - - for(m=0; m. - **********************************************************************/ -#ifndef READ_MOSAIC_H_ -#define READ_MOSAIC_H_ - -/* netcdf helpers */ -/* perhaps should consider making static, or breaking out into seperate file, - some of these names (field_exist) could pollute namespace... */ - -void handle_netcdf_error(const char *msg, int status ); - -void get_file_dir(const char *file, char *dir); - -int field_exist(const char* file, const char *name); - -int get_dimlen(const char* file, const char *name); - -void get_string_data_level(const char *file, const char *name, char *data, const unsigned int* level); - -void get_var_data(const char *file, const char *name, void *data); - -void get_var_data_region(const char *file, const char *name, const size_t *start, const size_t *nread, void *data); - -void get_string_data(const char *file, const char *name, char *data); - -void get_var_text_att(const char *file, const char *name, const char *attname, char *att); -/* end netcdf helpers */ - -int read_mosaic_xgrid_size( const char *xgrid_file ); - -void read_mosaic_xgrid_order1(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area ); - -void read_mosaic_xgrid_order1_region(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, int *isc, int *iec ); - -void read_mosaic_xgrid_order2(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, - double *area, double *di, double *dj ); - -double get_global_area(void); - - -int read_mosaic_ntiles(const char *mosaic_file); - -int read_mosaic_ncontacts(const char *mosaic_file); - -void read_mosaic_grid_sizes(const char *mosaic_file, int *nx, int *ny); - -void read_mosaic_contact(const char *mosaic_file, int *tile1, int *tile2, int *istart1, int *iend1, - int *jstart1, int *jend1, int *istart2, int *iend2, int *jstart2, int *jend2); - -int transfer_to_model_index(int istart_in, int iend_in, int *istart_out, int *iend_out, int refine_ratio); - -void read_mosaic_grid_data(const char *mosaic_file, const char *name, int nx, int ny, - double *data, unsigned int level, int ioff, int joff); - - -void read_mosaic_contact_(const char *mosaic_file, int *tile1, int *tile2, int *istart1, int *iend1, - int *jstart1, int *jend1, int *istart2, int *iend2, int *jstart2, int *jend2); - -int read_mosaic_xgrid_size_( const char *xgrid_file ); - -int read_mosaic_ntiles_(const char *mosaic_file); - -int read_mosaic_ncontacts_(const char *mosaic_file); - -void read_mosaic_grid_sizes_(const char *mosaic_file, int *nx, int *ny); - - -double get_global_area_(void); - -void read_mosaic_xgrid_order1_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area ); - -void read_mosaic_xgrid_order1_region_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, int *isc, int *iec ); - -void read_mosaic_xgrid_order2_(const char *xgrid_file, int *i1, int *j1, int *i2, int *j2, double *area, double *di, double *dj ); - -#endif diff --git a/mosaic2/include/mosaic2.inc b/mosaic2/include/mosaic2.inc index 2da3d136db..c87481e700 100644 --- a/mosaic2/include/mosaic2.inc +++ b/mosaic2/include/mosaic2.inc @@ -86,15 +86,13 @@ !>
Example usage: !! call calc_mosaic_grid_area(lon, lat, area) subroutine CALC_MOSAIC_GRID_AREA_(lon, lat, area) - real(kind=FMS_MOS_KIND_), dimension(:,:), intent(in) :: lon - real(kind=FMS_MOS_KIND_), dimension(:,:), intent(in) :: lat - real(kind=FMS_MOS_KIND_), dimension(:,:), intent(inout) :: area + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(in) :: lon + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(in) :: lat + real(kind=FMS_MOS_KIND_), dimension(:,:), intent(out) :: area integer :: nlon, nlat real(r8_kind) :: area_r8(size(area,1),size(area,2)) - area_r8=real(area,r8_kind) - nlon = size(area,1) nlat = size(area,2) ! make sure size of lon, lat and area are consitency diff --git a/parser/yaml_parser.F90 b/parser/yaml_parser.F90 index 3a3c7f0051..a34c5d4e22 100644 --- a/parser/yaml_parser.F90 +++ b/parser/yaml_parser.F90 @@ -76,7 +76,7 @@ function open_and_parse_file_wrap(filename, file_id) bind(c) & 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_int) :: error_code !< Flag indicating the error message (1 if sucessful) + integer(kind=c_int) :: error_code !< Flag indicating the error message (1 if sucessful) end function open_and_parse_file_wrap !> @brief Private c function that checks if a file_id is valid (see yaml_parser_binding.c) diff --git a/test_fms/Makefile.am b/test_fms/Makefile.am index 230ad1b164..409cde9765 100644 --- a/test_fms/Makefile.am +++ b/test_fms/Makefile.am @@ -27,7 +27,7 @@ ACLOCAL_AMFLAGS = -I m4 SUBDIRS = astronomy coupler diag_manager data_override exchange monin_obukhov drifters \ mosaic2 interpolator fms mpp mpp_io time_interp time_manager horiz_interp topography \ field_manager axis_utils affinity fms2_io parser string_utils sat_vapor_pres tracer_manager \ -random_numbers diag_integral column_diagnostics tridiagonal +random_numbers diag_integral column_diagnostics tridiagonal block_control # testing utility scripts to distribute EXTRA_DIST = test-lib.sh.in intel_coverage.sh.in tap-driver.sh diff --git a/test_fms/block_control/Makefile.am b/test_fms/block_control/Makefile.am new file mode 100644 index 0000000000..4fc64f93b0 --- /dev/null +++ b/test_fms/block_control/Makefile.am @@ -0,0 +1,47 @@ +#*********************************************************************** +#* 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/block_control directory of the +# FMS package. + +# Find the fms and mpp mod files. +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_block_control + +# This is the source code for the test. +test_block_control_SOURCES = test_block_control.F90 + +# Run the test program. +TESTS = test_block_control.sh + +# Copy over other needed files to the srcdir +EXTRA_DIST = test_block_control.sh + +TEST_EXTENSIONS = .sh +SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ + $(abs_top_srcdir)/test_fms/tap-driver.sh + +# Clean up +CLEANFILES = input.nml *.out* *.dpi *.spi *.dyn *.spl diff --git a/test_fms/block_control/test_block_control.F90 b/test_fms/block_control/test_block_control.F90 new file mode 100644 index 0000000000..97ff4aa7f6 --- /dev/null +++ b/test_fms/block_control/test_block_control.F90 @@ -0,0 +1,69 @@ +!*********************************************************************** +!* 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_block_control + use fms_mod, only: fms_init, fms_end + use mpp_domains_mod, only: domain2d, mpp_define_domains, mpp_get_compute_domain + use block_control_mod, only: block_control_type, define_blocks + use mpp_mod, only: mpp_pe, mpp_root_pe, mpp_error, FATAL + use fms_string_utils_mod, only: string + + implicit none + + integer, parameter :: nx=96 !< Size of the x grid + integer, parameter :: ny=96 !< Size of the y grid + type(domain2d) :: Domain !< 2D domain + integer :: layout(2) = (/2, 3/) !< Layout of the domain + type(block_control_type) :: my_block !< Block control type + integer :: isc, iec, jsc, jec !< Starting and ending index for the commute domain + integer :: expected_startingy !< Expected starting y index for the current block + integer :: expected_endingy !< Expected ending y index for the current block + integer :: ncy(3) !< Size of the y for each block + logical :: message !< Set to .True., to output the warning message + integer :: i !< For do loops + + call fms_init() + message = .True. !< Needs to be .true. so that the error message can be printed + call mpp_define_domains( (/1,nx,1,ny/), layout, Domain) + call mpp_get_compute_domain(Domain, isc, iec, jsc, jec) + call define_blocks ('testing_model', my_block, isc, iec, jsc, jec, kpts=0, & + nx_block=1, ny_block=3, message=message) + + !< Message will be set to .false. if the blocks are not uniform + if (message) & + call mpp_error(FATAL, "test_block_control::define_blocks did not output the warning message"//& + " about uneven blocks") + + !Expected size of each block for every PE + ncy = (/11, 10, 11/) + expected_endingy = jsc-1 + do i = 1, 3 + ! Check the starting and ending "x" indices for each block + if (my_block%ibs(i) .ne. isc .or. my_block%ibe(i) .ne. iec) & + call mpp_error(FATAL, "The starting and ending 'x' index for the "//string(i)//" block is not expected value!") + + ! Check the starting and ending "y" indices for each block + expected_startingy = expected_endingy + 1 + expected_endingy = expected_startingy + ncy(i) - 1 + if (my_block%jbs(i) .ne. expected_startingy .or. my_block%jbe(i) .ne. expected_endingy) & + call mpp_error(FATAL, "The starting and ending 'y' index for the "//string(i)//" block is not expected value!") + enddo + + call fms_end() +end program diff --git a/test_fms/block_control/test_block_control.sh b/test_fms/block_control/test_block_control.sh new file mode 100755 index 0000000000..a5e76f68c3 --- /dev/null +++ b/test_fms/block_control/test_block_control.sh @@ -0,0 +1,38 @@ +#!/bin/sh + +#*********************************************************************** +#* 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 part of the GFDL FMS package. This is a shell script to +# execute tests in the test_fms/block_control directory. + +# Set common test settings. +. ../test-lib.sh + +# Prepare the directory to run the tests. +cat < input.nml +EOF + +# Run the test. + +test_expect_success "Test block_control" ' + mpirun -n 6 ./test_block_control +' + +test_done diff --git a/test_fms/column_diagnostics/Makefile.am b/test_fms/column_diagnostics/Makefile.am index 8c9f9b6d5a..d8fb204ff5 100644 --- a/test_fms/column_diagnostics/Makefile.am +++ b/test_fms/column_diagnostics/Makefile.am @@ -34,8 +34,8 @@ check_PROGRAMS = test_column_diagnostics_r4 test_column_diagnostics_r8 test_column_diagnostics_r4_SOURCES = test_column_diagnostics.F90 test_column_diagnostics_r8_SOURCES = test_column_diagnostics.F90 -test_column_diagnostics_r4_CPPFLAGS=-DTEST_CD_KIND_=4 -I$(AM_CPPFLAGS) -test_column_diagnostics_r8_CPPFLAGS=-DTEST_CD_KIND_=8 -I$(AM_CPPFLAGS) +test_column_diagnostics_r4_CPPFLAGS=$(AM_CPPFLAGS) -DTEST_CD_KIND_=4 +test_column_diagnostics_r8_CPPFLAGS=$(AM_CPPFLAGS) -DTEST_CD_KIND_=8 TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) $(abs_top_srcdir)/test_fms/tap-driver.sh diff --git a/test_fms/coupler/test_atmos_ocean_fluxes.F90 b/test_fms/coupler/test_atmos_ocean_fluxes.F90 index 742ac4c50f..7eb50880df 100644 --- a/test_fms/coupler/test_atmos_ocean_fluxes.F90 +++ b/test_fms/coupler/test_atmos_ocean_fluxes.F90 @@ -106,7 +106,8 @@ subroutine test_aof_set_coupler_flux character(100) :: cresults, thelist real(FMS_CP_TEST_KIND_) :: rresults, rresults2(num_bcs) - integer :: i, success, n + integer :: i, n + logical :: success write(*,*) "*** TEST_AOF_SET_COUPLER_FLUX ***" diff --git a/test_fms/data_override/Makefile.am b/test_fms/data_override/Makefile.am index 087bd91ea3..0de57700f9 100644 --- a/test_fms/data_override/Makefile.am +++ b/test_fms/data_override/Makefile.am @@ -73,11 +73,11 @@ TESTS_ENVIRONMENT= test_input_path="@TEST_INPUT_PATH@" \ # Run the test program. TESTS = test_data_override2.sh test_data_override_init.sh test_data_override2_mono.sh test_data_override2_ongrid.sh \ - test_data_override2_scalar.sh test_data_override_weights.sh + test_data_override2_scalar.sh test_data_override_weights.sh test_data_override_ensembles.sh # Include these files with the distribution. EXTRA_DIST = test_data_override2.sh test_data_override_init.sh test_data_override2_mono.sh test_data_override2_ongrid.sh \ - test_data_override2_scalar.sh test_data_override_weights.sh + test_data_override2_scalar.sh test_data_override_weights.sh test_data_override_ensembles.sh # Clean up CLEANFILES = input.nml *.nc* *.out diag_table data_table data_table.yaml INPUT/* *.dpi *.spi *.dyn *.spl *-files/* diff --git a/test_fms/data_override/test_data_override2_mono.sh b/test_fms/data_override/test_data_override2_mono.sh index df7f1dc66b..5e5addcf36 100755 --- a/test_fms/data_override/test_data_override2_mono.sh +++ b/test_fms/data_override/test_data_override2_mono.sh @@ -27,9 +27,10 @@ output_dir [ ! -d "INPUT" ] && mkdir -p "INPUT" -cat <<_EOF > input.nml +cat <<_EOF > input_base.nml &test_data_override_ongrid_nml test_case = 2 + write_only = .False. / _EOF @@ -40,6 +41,13 @@ _EOF for KIND in r4 r8 do + rm -rf INPUT/* + sed 's/write_only = .False./write_only = .True./g' input_base.nml > input.nml + test_expect_success "Creating input files (${KIND})" ' + mpirun -n 6 ../test_data_override_ongrid_${KIND} + ' + + cp input_base.nml input.nml test_expect_success "test_data_override with monotonically increasing and decreasing data sets (${KIND})" ' mpirun -n 6 ../test_data_override_ongrid_${KIND} ' @@ -49,9 +57,10 @@ done rm -rf data_table -cat <<_EOF > input.nml +cat <<_EOF > input_base.nml &test_data_override_ongrid_nml test_case = 2 + write_only = .False. / &data_override_nml use_data_table_yaml = .True. @@ -81,6 +90,12 @@ if [ -z $parser_skip ]; then for KIND in r4 r8 do rm -rf INPUT/* + sed 's/write_only = .False./write_only = .True./g' input_base.nml > input.nml + test_expect_success "Creating input files (${KIND})" ' + mpirun -n 6 ../test_data_override_ongrid_${KIND} + ' + + cp input_base.nml input.nml test_expect_success "test_data_override with monotonically increasing and decreasing data sets -yaml (${KIND})" ' mpirun -n 6 ../test_data_override_ongrid_${KIND} ' diff --git a/test_fms/data_override/test_data_override2_ongrid.sh b/test_fms/data_override/test_data_override2_ongrid.sh index e9f36712ce..4d4616734c 100755 --- a/test_fms/data_override/test_data_override2_ongrid.sh +++ b/test_fms/data_override/test_data_override2_ongrid.sh @@ -36,6 +36,7 @@ use_data_table_yaml=.False. &test_data_override_ongrid_nml nhalox=halo_size nhaloy=halo_size + write_only = .False. / _EOF printf '"OCN", "runoff", "runoff", "./INPUT/runoff.daitren.clim.1440x1080.v20180328.nc", "none" , 1.0' | cat > data_table @@ -48,6 +49,7 @@ use_data_table_yaml=.True. &test_data_override_ongrid_nml nhalox=halo_size nhaloy=halo_size + write_only = .False. / _EOF cat <<_EOF > data_table.yaml @@ -65,13 +67,17 @@ fi [ ! -d "INPUT" ] && mkdir -p "INPUT" for KIND in r4 r8 do -rm -rf INPUT/* +sed -e 's/halo_size/2/g ; s/write_only = .False./write_only = .True./g' input_base.nml > input.nml + +test_expect_success "Creating input files (${KIND})" ' + mpirun -n 6 ../test_data_override_ongrid_${KIND} +' + sed 's/halo_size/2/g' input_base.nml > input.nml test_expect_success "data_override on grid with 2 halos in x and y (${KIND})" ' mpirun -n 6 ../test_data_override_ongrid_${KIND} ' -rm -rf INPUT/* sed 's/halo_size/0/g' input_base.nml > input.nml test_expect_success "data_override on grid with 0 halos in x and y (${KIND})" ' mpirun -n 6 ../test_data_override_ongrid_${KIND} diff --git a/test_fms/data_override/test_data_override2_scalar.sh b/test_fms/data_override/test_data_override2_scalar.sh index ac19b2b0a6..6b6c096b7a 100755 --- a/test_fms/data_override/test_data_override2_scalar.sh +++ b/test_fms/data_override/test_data_override2_scalar.sh @@ -28,22 +28,24 @@ output_dir rm -rf data_table data_table.yaml input.nml input_base.nml if [ ! -z $parser_skip ]; then - cat <<_EOF > input.nml + cat <<_EOF > input_base.nml &data_override_nml use_data_table_yaml=.False. / &test_data_override_ongrid_nml test_case = 3 + write_only = .False. / _EOF printf '"OCN", "co2", "co2", "./INPUT/scalar.nc", "none" , 1.0' | cat > data_table else -cat <<_EOF > input.nml +cat <<_EOF > input_base.nml &data_override_nml use_data_table_yaml=.True. / &test_data_override_ongrid_nml test_case = 3 + write_only = .False. / _EOF cat <<_EOF > data_table.yaml @@ -62,6 +64,12 @@ fi for KIND in r4 r8 do rm -rf INPUT/* +sed 's/write_only = .False./write_only = .True./g' input_base.nml > input.nml +test_expect_success "Creating input files (${KIND})" ' + mpirun -n 6 ../test_data_override_ongrid_${KIND} +' + +cp input_base.nml input.nml test_expect_success "data_override scalar field (${KIND})" ' mpirun -n 6 ../test_data_override_ongrid_${KIND} ' diff --git a/test_fms/data_override/test_data_override_ensembles.sh b/test_fms/data_override/test_data_override_ensembles.sh new file mode 100755 index 0000000000..afcdcd458f --- /dev/null +++ b/test_fms/data_override/test_data_override_ensembles.sh @@ -0,0 +1,99 @@ +#!/bin/sh + +#*********************************************************************** +#* 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 . +#*********************************************************************** +# +# Copyright (c) 2019-2021 Ed Hartnett, Uriel Ramirez, Seth Underwood + +# Set common test settings. +. ../test-lib.sh + +output_dir +[ ! -d "INPUT" ] && mkdir -p "INPUT" + +cat <<_EOF > data_table.ens_01.yaml +data_table: + - grid_name: OCN + fieldname_in_model: runoff + override_file: + - fieldname_in_file: runoff + file_name: INPUT/runoff.daitren.clim.1440x1080.v20180328_ens_01.nc + interp_method: none + factor: 1.0 +_EOF + +cat <<_EOF > data_table.ens_02.yaml +data_table: + - grid_name: OCN + fieldname_in_model: runoff + override_file: + - fieldname_in_file: runoff + file_name: INPUT/runoff.daitren.clim.1440x1080.v20180328_ens_02.nc + interp_method: none + factor: 1.0 +_EOF + +cat <<_EOF > input_base.nml +&data_override_nml + use_data_table_yaml = .True. +/ + +&test_data_override_ongrid_nml + test_case = 5 + write_only = .False. +/ + +&ensemble_nml + ensemble_size = 2 +/ +_EOF + +#The test only runs with yaml +if [ -z $parser_skip ]; then + for KIND in r4 r8 + do + rm -rf INPUT/. + sed 's/write_only = .False./write_only = .True./g' input_base.nml > input.nml + test_expect_success "Creating input files (${KIND})" ' + mpirun -n 12 ../test_data_override_ongrid_${KIND} + ' + + cp input_base.nml input.nml + test_expect_success "test_data_override with two ensembles -yaml (${KIND})" ' + mpirun -n 12 ../test_data_override_ongrid_${KIND} + ' + done + +cat <<_EOF > data_table.yaml +data_table: + - grid_name: OCN + fieldname_in_model: runoff + override_file: + - fieldname_in_file: runoff + file_name: INPUT/runoff.daitren.clim.1440x1080.v20180328_ens_02.nc + interp_method: none + factor: 1.0 +_EOF + + test_expect_failure "test_data_override with both data_table.yaml and data_table.ens_xx.yaml files" ' + mpirun -n 12 ../test_data_override_ongrid_${KIND} + ' +rm -rf INPUT +fi +test_done diff --git a/test_fms/data_override/test_data_override_ongrid.F90 b/test_fms/data_override/test_data_override_ongrid.F90 index a05eb9d6c8..d8e3864ba2 100644 --- a/test_fms/data_override/test_data_override_ongrid.F90 +++ b/test_fms/data_override/test_data_override_ongrid.F90 @@ -26,14 +26,16 @@ program test_data_override_ongrid use mpp_domains_mod, only: mpp_define_domains, mpp_define_io_domain, mpp_get_data_domain, & mpp_domains_set_stack_size, mpp_get_compute_domain, domain2d use mpp_mod, only: mpp_init, mpp_exit, mpp_pe, mpp_root_pe, mpp_error, FATAL, & - input_nml_file, mpp_sync, NOTE + input_nml_file, mpp_sync, NOTE, mpp_npes, mpp_get_current_pelist, & + mpp_set_current_pelist use data_override_mod, only: data_override_init, data_override use fms2_io_mod use time_manager_mod, only: set_calendar_type, time_type, set_date, NOLEAP use netcdf, only: nf90_create, nf90_def_dim, nf90_def_var, nf90_enddef, nf90_put_var, & nf90_close, nf90_put_att, nf90_clobber, nf90_64bit_offset, nf90_char, & nf90_double, nf90_unlimited -use fms_mod, only: string +use ensemble_manager_mod, only: get_ensemble_size, ensemble_manager_init +use fms_mod, only: string, fms_init, fms_end implicit none @@ -52,11 +54,17 @@ program test_data_override_ongrid integer, parameter :: bilinear = 2 integer, parameter :: scalar = 3 integer, parameter :: weight_file = 4 +integer, parameter :: ensemble_case = 5 integer :: test_case = ongrid +integer :: npes +integer, allocatable :: pelist(:) +integer, allocatable :: pelist_ens(:) +integer :: ensemble_id +logical :: write_only=.false. !< True if creating the input files only -namelist / test_data_override_ongrid_nml / nhalox, nhaloy, test_case, nlon, nlat, layout +namelist / test_data_override_ongrid_nml / nhalox, nhaloy, test_case, nlon, nlat, layout, write_only -call mpp_init +call fms_init call fms2_io_init read (input_nml_file, test_data_override_ongrid_nml, iostat=io_status) @@ -69,6 +77,15 @@ program test_data_override_ongrid call set_calendar_type(NOLEAP) +npes = mpp_npes() +allocate(pelist(npes)) +call mpp_get_current_pelist(pelist) + +select case (test_case) +case (ensemble_case) + call set_up_ensemble_case() +end select + !< Create a domain nlonXnlat with mask call mpp_domains_set_stack_size(17280000) call mpp_define_domains( (/1,nlon,1,nlat/), layout, Domain, xhalo=nhalox, yhalo=nhaloy, name='test_data_override_emc') @@ -76,34 +93,54 @@ program test_data_override_ongrid call mpp_get_data_domain(Domain, is, ie, js, je) select case (test_case) -case (ongrid) - call generate_ongrid_input_file () -case (bilinear) - call generate_bilinear_input_file () -case (scalar) - call generate_scalar_input_file () -case (weight_file) - call generate_weight_input_file () +case (ensemble_case) + ! Go back to the full pelist + call mpp_set_current_pelist(pelist) end select -call mpp_sync() -call mpp_error(NOTE, "Finished creating INPUT Files") - -!< Initiliaze data_override -call data_override_init(Ocean_domain_in=Domain, mode=lkind) - -select case (test_case) -case (ongrid) - call ongrid_test() -case (bilinear) - call bilinear_test() -case (scalar) - call scalar_test() -case (weight_file) - call weight_file_test() -end select +if (write_only) then + select case (test_case) + case (ongrid) + call generate_ongrid_input_file () + case (bilinear) + call generate_bilinear_input_file () + case (scalar) + call generate_scalar_input_file () + case (weight_file) + call generate_weight_input_file () + case (ensemble_case) + call generate_ensemble_input_file() + end select -call mpp_exit + call mpp_sync() + call mpp_error(NOTE, "Finished creating INPUT Files") + +else + select case (test_case) + case (ensemble_case) + !< Go back to the ensemble pelist + call mpp_set_current_pelist(pelist_ens) + end select + + !< Initiliaze data_override + call data_override_init(Ocean_domain_in=Domain, mode=lkind) + + select case (test_case) + case (ongrid) + call ongrid_test() + case (bilinear) + call bilinear_test() + case (scalar) + call scalar_test() + case (weight_file) + call weight_file_test() + case (ensemble_case) + call ensemble_test() + call mpp_set_current_pelist(pelist) + end select +endif + +call fms_end contains @@ -214,17 +251,29 @@ subroutine create_ocean_hgrid_file() endif end subroutine create_ocean_hgrid_file -subroutine create_ongrid_data_file() +subroutine create_ongrid_data_file(is_ensemble) + logical, intent(in), optional :: is_ensemble type(FmsNetcdfFile_t) :: fileobj character(len=10) :: dimnames(3) real(lkind), allocatable, dimension(:,:,:) :: runoff_in real(lkind), allocatable, dimension(:) :: time_data + integer :: offset + character(len=256), allocatable :: appendix + integer :: i + offset = 0 + appendix = "" + if (present(is_ensemble)) then + offset = ensemble_id + call get_filename_appendix(appendix) + appendix = "_"//trim(appendix) + endif + allocate(runoff_in(nlon, nlat, 10)) allocate(time_data(10)) do i = 1, 10 - runoff_in(:,:,i) = real(i, lkind) + runoff_in(:,:,i) = real(i+offset, lkind) enddo time_data = (/1., 2., 3., 5., 6., 7., 8., 9., 10., 11./) @@ -232,7 +281,7 @@ subroutine create_ongrid_data_file() dimnames(2) = 'j' dimnames(3) = 'time' - if (open_file(fileobj, 'INPUT/runoff.daitren.clim.1440x1080.v20180328.nc', 'overwrite')) then + if (open_file(fileobj, 'INPUT/runoff.daitren.clim.1440x1080.v20180328'//trim(appendix)//'.nc', 'overwrite')) then call register_axis(fileobj, "i", nlon) call register_axis(fileobj, "j", nlat) call register_axis(fileobj, "time", unlimited) @@ -605,4 +654,84 @@ subroutine scalar_test() end subroutine scalar_test +subroutine set_up_ensemble_case() + integer :: ens_siz(6) + character(len=10) :: text + + if (npes .ne. 12) & + call mpp_error(FATAL, "This test requires 12 pes to run") + + if (layout(1)*layout(2) .ne. 6) & + call mpp_error(FATAL, "The two members of the layout do not equal 6") + + call ensemble_manager_init + ens_siz = get_ensemble_size() + if (ens_siz(1) .ne. 2) & + call mpp_error(FATAL, "This test requires 2 ensembles") + + if (mpp_pe() < 6) then + !PEs 0-5 are the first ensemble + ensemble_id = 1 + allocate(pelist_ens(npes/ens_siz(1))) + pelist_ens = pelist(1:6) + call mpp_set_current_pelist(pelist_ens) + else + !PEs 6-11 are the second ensemble + ensemble_id = 2 + allocate(pelist_ens(npes/ens_siz(1))) + pelist_ens = pelist(7:) + call mpp_set_current_pelist(pelist_ens) + endif + + write( text,'(a,i2.2)' ) 'ens_', ensemble_id + call set_filename_appendix(trim(text)) + + if (mpp_pe() .eq. mpp_root_pe()) & + print *, "ensemble_id:", ensemble_id, ":: ", pelist_ens +end subroutine + +subroutine generate_ensemble_input_file() + if (mpp_pe() .eq. mpp_root_pe()) then + call create_grid_spec_file () + call create_ocean_mosaic_file() + call create_ocean_hgrid_file() + endif + + !< Go back to the ensemble pelist so that each root pe can write its own input file + call mpp_set_current_pelist(pelist_ens) + if (mpp_pe() .eq. mpp_root_pe()) then + call create_ongrid_data_file(is_ensemble=.true.) + endif + call mpp_set_current_pelist(pelist) +end subroutine + +subroutine ensemble_test() + real(lkind) :: expected_result !< Expected result from data_override + type(time_type) :: Time !< Time + real(lkind), allocatable, dimension(:,:) :: runoff !< Data to be written + + allocate(runoff(is:ie,js:je)) + + runoff = 999._lkind + !< Run it when time=3 + Time = set_date(1,1,4,0,0,0) + call data_override('OCN','runoff',runoff, Time) + !< Because you are getting the data when time=3, and this is an "ongrid" case, the expected result is just + !! equal to the data at time=3, which is 3+ensemble_id. + expected_result = 3._lkind + real(ensemble_id,kind=lkind) + call compare_data(Domain, runoff, expected_result) + + !< Run it when time=4 + runoff = 999._lkind + Time = set_date(1,1,5,0,0,0) + call data_override('OCN','runoff',runoff, Time) + !< You are getting the data when time=4, the data at time=3 is 3+ensemble_id. and at time=5 is 4+ensemble_id., + !! so the expected result is the average of the 2 (because this is is an "ongrid" case and there + !! is no horizontal interpolation). + expected_result = (3._lkind + real(ensemble_id,kind=lkind) + 4._lkind + real(ensemble_id,kind=lkind)) / 2._lkind + call compare_data(Domain, runoff, expected_result) + + deallocate(runoff) +end subroutine ensemble_test + end program test_data_override_ongrid diff --git a/test_fms/data_override/test_data_override_weights.sh b/test_fms/data_override/test_data_override_weights.sh index a3bc8902e4..2bb1e2c3f1 100755 --- a/test_fms/data_override/test_data_override_weights.sh +++ b/test_fms/data_override/test_data_override_weights.sh @@ -48,7 +48,7 @@ data_table: factor: 1.0 _EOF -cat <<_EOF > input.nml +cat <<_EOF > input_base.nml &data_override_nml use_data_table_yaml = .True. / @@ -58,6 +58,7 @@ cat <<_EOF > input.nml nlon = 5 nlat = 6 layout = 1, 2 + write_only = .False. / _EOF @@ -66,6 +67,13 @@ if [ -z $parser_skip ]; then for KIND in r4 r8 do rm -rf INPUT/. + + sed 's/write_only = .False./write_only = .True./g' input_base.nml > input.nml + test_expect_success "Creating input files (${KIND})" ' + mpirun -n 2 ../test_data_override_ongrid_${KIND} + ' + + cp input_base.nml input.nml test_expect_success "test_data_override with and without weight files -yaml (${KIND})" ' mpirun -n 2 ../test_data_override_ongrid_${KIND} ' diff --git a/test_fms/diag_integral/test_diag_integral.F90 b/test_fms/diag_integral/test_diag_integral.F90 index af21fac6c2..e8b25413c6 100644 --- a/test_fms/diag_integral/test_diag_integral.F90 +++ b/test_fms/diag_integral/test_diag_integral.F90 @@ -57,12 +57,11 @@ program test_diag_integral real(TEST_DI_KIND_) :: weight(nxy,nxy,nxy) !> weights required to test sum_field_wght_3d real(TEST_DI_KIND_) :: immadeuph(nxy,nxy) !> array to test sum_field_2d_hemi - real(r8_kind) :: lat(nxyp,nxyp), lon(nxyp,nxyp) - real(r8_kind) :: area(nxy,nxy) + real(r8_kind) :: lat(nxyp,nxyp), lon(nxyp,nxyp) + real(r8_kind) :: area(nxy,nxy) type(time_type) :: Time_init, Time !testing and generating answers - integer :: i, j, k !> counters for do loop real(r8_kind) :: area_sum !> global area. sum of the grid cell areas. real(r8_kind) :: itime !> made up time !> The field_avg* values are only declared as r8_kind because they correspond to the values @@ -96,6 +95,24 @@ program test_diag_integral call test_sum_diag_integral_field !< compare read in values to the expected values. contains + !------------------------------------- + !------------------------------------- + subroutine initialize_arrays + + !> made up numbers + + implicit none + + lon=1.0_lkind + lat=1.0_lkind + area=1.0_lkind + immadeup2=1.0_lkind + immadeup3=1.0_lkind + immadeupw=1.0_lkind + immadeuph=1.0_lkind + weight=1.0_lkind + + end subroutine initialize_arrays !------------------------------------- !------------------------------------- subroutine test_diag_integral_init @@ -175,13 +192,13 @@ end subroutine test_sum_diag_integral_field !------------------------------------- subroutine read_diag_integral_file - character(17), parameter :: di_file='diag_integral.out' - integer, parameter :: iunit=100 + character(*), parameter :: di_file='diag_integral.out' + integer :: iunit character(100) :: cline1, cline2, cline3, cline4, cline5, clin6 !> read in computed values - open(unit=iunit,file=trim(di_file)) + open(newunit=iunit, file=di_file) read(iunit,*) cline1, cline2, cline3, cline4, cline5, clin6 read(iunit,*) itime, field_avg2, field_avg3, field_avgw, field_avgh close(iunit) @@ -204,22 +221,4 @@ subroutine check_answers(answer, outresult, whoami) end subroutine check_answers !------------------------------------- !------------------------------------- - subroutine initialize_arrays - - !> made up numbers - - implicit none - - lon=1.0_lkind - lat=1.0_lkind - area=1.0_lkind - immadeup2=1.0_lkind - immadeup3=1.0_lkind - immadeupw=1.0_lkind - immadeuph=1.0_lkind - weight=1.0_lkind - - end subroutine initialize_arrays - !------------------------------------- - !------------------------------------- end program test_diag_integral diff --git a/test_fms/diag_integral/test_diag_integral2.sh b/test_fms/diag_integral/test_diag_integral2.sh index 8a50c4c014..53df2327fc 100755 --- a/test_fms/diag_integral/test_diag_integral2.sh +++ b/test_fms/diag_integral/test_diag_integral2.sh @@ -30,11 +30,8 @@ EOF mkdir -p INPUT test_expect_success "test_diag_integral r4" 'mpirun -n 1 ./test_diag_integral_r4' -rm diag_integral.out test_expect_success "test_diag_integral r8" 'mpirun -n 1 ./test_diag_integral_r8' -rm diag_integral.out -rm input.nml rm -rf INPUT test_done diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index a224eb2451..2d7d6440a5 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -34,7 +34,7 @@ check_PROGRAMS = test_diag_manager test_diag_manager_time \ check_time_min check_time_max check_time_sum check_time_avg test_diag_diurnal check_time_diurnal \ check_time_pow check_time_rms check_subregional test_cell_measures test_var_masks \ check_var_masks test_multiple_send_data test_diag_out_yaml test_output_every_freq \ - test_dm_weights test_prepend_date + test_dm_weights test_prepend_date test_ens_runs # This is the source code for the test. test_output_every_freq_SOURCES = test_output_every_freq.F90 @@ -65,6 +65,7 @@ test_var_masks_SOURCES = test_var_masks.F90 check_var_masks_SOURCES = check_var_masks.F90 test_multiple_send_data_SOURCES = test_multiple_send_data.F90 test_prepend_date_SOURCES = test_prepend_date.F90 +test_ens_runs_SOURCES = test_ens_runs.F90 TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ @@ -74,7 +75,7 @@ SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ TESTS = test_diag_manager2.sh test_time_none.sh test_time_min.sh test_time_max.sh test_time_sum.sh \ test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh test_cell_measures.sh \ test_subregional.sh test_var_masks.sh test_multiple_send_data.sh test_output_every_freq.sh \ - test_dm_weights.sh test_flush_nc_file.sh test_prepend_date.sh + test_dm_weights.sh test_flush_nc_file.sh test_prepend_date.sh test_ens_runs.sh testing_utils.mod: testing_utils.$(OBJEXT) @@ -82,7 +83,8 @@ testing_utils.mod: testing_utils.$(OBJEXT) EXTRA_DIST = test_diag_manager2.sh check_crashes.sh test_time_none.sh test_time_min.sh test_time_max.sh \ test_time_sum.sh test_time_avg.sh test_time_pow.sh test_time_rms.sh test_time_diurnal.sh \ test_cell_measures.sh test_subregional.sh test_var_masks.sh test_multiple_send_data.sh \ - test_flush_nc_file.sh test_dm_weights.sh test_output_every_freq.sh test_prepend_date.sh + test_flush_nc_file.sh test_dm_weights.sh test_output_every_freq.sh test_prepend_date.sh \ + test_ens_runs.sh if USING_YAML skipflag="" diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index 7b280c8855..3b4092108a 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -786,7 +786,7 @@ diag_files: kind: r4 - module: atm_mod var_name: var7 - reduction: average + reduction: none kind: r4 - file_name: file4 freq: 6 hours @@ -1050,7 +1050,7 @@ diag_files: dimensions: time grid_index - module: atm_mod var_name: var7 - reduction: average + reduction: none kind: r4 output_name: long_name: diff --git a/test_fms/diag_manager/test_ens_runs.F90 b/test_fms/diag_manager/test_ens_runs.F90 new file mode 100644 index 0000000000..621016430f --- /dev/null +++ b/test_fms/diag_manager/test_ens_runs.F90 @@ -0,0 +1,128 @@ +!*********************************************************************** +!* 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 diag manager when the file frequency is set to 0 days +program test_ens_runs + + use fms_mod, only: fms_init, fms_end, string + use diag_manager_mod, only: diag_axis_init, send_data, diag_send_complete, diag_manager_set_time_end, & + register_diag_field, diag_manager_init, diag_manager_end, register_static_field, & + diag_axis_init + use time_manager_mod, only: time_type, operator(+), JULIAN, set_time, set_calendar_type, set_date + use mpp_mod, only: FATAL, mpp_error, mpp_npes, mpp_pe, mpp_get_current_pelist, mpp_set_current_pelist + use fms2_io_mod, only: FmsNetcdfFile_t, open_file, close_file, read_data, get_dimension_size, & + set_filename_appendix, get_instance_filename + use ensemble_manager_mod, only: get_ensemble_size, ensemble_manager_init + + implicit none + + integer :: id_var0 !< diag field ids + integer :: id_axis1 !< Id for axis + logical :: used !< for send_data calls + integer :: ntimes = 48 !< Number of time steps + real :: vdata !< Buffer to store the data + type(time_type) :: Time !< "Model" time + type(time_type) :: Time_step !< Time step for the "simulation" + integer :: i !< For do loops + integer :: npes !< Number of pes in the current pelist + integer, allocatable :: pelist(:) !< Full pelist + integer :: ensemble_id !< The ensemble id + integer :: ens_siz(6) !< The size of the ensemble + character(len=10) :: text !< The filename appendix + integer :: expected_ntimes + + call fms_init + call ensemble_manager_init + npes = mpp_npes() + if (npes .ne. 2) & + call mpp_error(FATAL, "This test requires two pes to run") + + allocate(pelist(npes)) + call mpp_get_current_pelist(pelist) + + ens_siz = get_ensemble_size() + if (ens_siz(1) .ne. 2) & + call mpp_error(FATAL, "This test requires 2 ensembles") + + if (mpp_pe() < 1) then + !< PE 0 is the first ensemble + ensemble_id = 1 + call mpp_set_current_pelist((/0/)) + expected_ntimes = 48 + else + ensemble_id = 2 + call mpp_set_current_pelist((/1/)) + expected_ntimes = 24 + endif + + write( text,'(a,i2.2)' ) 'ens_', ensemble_id + call set_filename_appendix(trim(text)) + + call set_calendar_type(JULIAN) + call diag_manager_init + + Time = set_date(2,1,1,0,0,0) + Time_step = set_time (3600,0) !< 1 hour + call diag_manager_set_time_end(set_date(2,1,3,0,0,0)) + + id_var0 = register_diag_field ('ocn_mod', 'var0', Time) + + do i = 1, ntimes + Time = Time + Time_step + vdata = real(i) + + used = send_data(id_var0, vdata, Time) + call diag_send_complete(Time_step) + enddo + + call diag_manager_end(Time) + + call check_output() + call fms_end + + contains + + !< @brief Check the diag manager output + subroutine check_output() + type(FmsNetcdfFile_t) :: fileobj !< Fms2io fileobj + integer :: var_size !< Size of the variable reading + real, allocatable :: var_data(:) !< Buffer to read variable data to + integer :: j !< For looping + character(len=255) :: filename !< Name of the diag file + + call get_instance_filename("test_ens.nc", filename) + if (.not. open_file(fileobj, filename, "read")) & + call mpp_error(FATAL, "Error opening file:"//trim(filename)//" to read") + + call get_dimension_size(fileobj, "time", var_size) + if (var_size .ne. expected_ntimes) call mpp_error(FATAL, "The dimension of time in the file:"//& + "test_ens is not the correct size!") + allocate(var_data(var_size)) + var_data = -999.99 + + call read_data(fileobj, "var0", var_data) + do j = 1, var_size + if (var_data(j) .ne. real(j * ensemble_id))& + call mpp_error(FATAL, "The variable data for var1 at time level:"//& + string(j)//" is not the correct value!") + enddo + + call close_file(fileobj) + end subroutine check_output +end program test_ens_runs diff --git a/test_fms/diag_manager/test_ens_runs.sh b/test_fms/diag_manager/test_ens_runs.sh new file mode 100755 index 0000000000..b2e262b69c --- /dev/null +++ b/test_fms/diag_manager/test_ens_runs.sh @@ -0,0 +1,97 @@ +#!/bin/sh + +#*********************************************************************** +#* 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 . +#*********************************************************************** + +# Copyright (c) 2019-2020 Ed Hartnett, Seth Underwood + +# Set common test settings. +. ../test-lib.sh + +if [ -z "${skipflag}" ]; then +# create and enter directory for in/output files +output_dir + +cat <<_EOF > diag_table.ens_01.yaml +title: test_diag_manager_01 +base_date: 2 1 1 0 0 0 +diag_files: +- file_name: test_ens + time_units: days + unlimdim: time + freq: 1 hours + varlist: + - module: ocn_mod + var_name: var0 + reduction: none + kind: r8 +_EOF + +cat <<_EOF > diag_table.ens_02.yaml +title: test_diag_manager_01 +base_date: 2 1 1 0 0 0 +diag_files: +- file_name: test_ens + time_units: days + unlimdim: time + freq: 2 hours + varlist: + - module: ocn_mod + var_name: var0 + reduction: none + kind: r8 +_EOF + +cat <<_EOF > input.nml +&diag_manager_nml + use_modern_diag = .True. +/ + +&ensemble_nml + ensemble_size = 2 +/ +_EOF + +my_test_count=1 +test_expect_success "Running diag_manager with 2 ensembles (test $my_test_count)" ' + mpirun -n 2 ../test_ens_runs +' + +cat <<_EOF > diag_table.yaml +title: test_diag_manager_01 +base_date: 2 1 1 0 0 0 +diag_files: +- file_name: test_0days + time_units: days + unlimdim: time + freq: 0 days + varlist: + - module: ocn_mod + var_name: var0 + reduction: none + kind: r8 +_EOF + +my_test_count=`expr $my_test_count + 1` +test_expect_failure "Running diag_manager with both diag_table.yaml and diag_table.ens_xx.yaml files present (test $my_test_count)" ' + mpirun -n 2 ../test_ens_runs +' + +fi +test_done diff --git a/test_fms/diag_manager/test_modern_diag.F90 b/test_fms/diag_manager/test_modern_diag.F90 index f32b5c5dad..fe03645ce2 100644 --- a/test_fms/diag_manager/test_modern_diag.F90 +++ b/test_fms/diag_manager/test_modern_diag.F90 @@ -199,6 +199,8 @@ program test_modern_diag call allocate_dummy_data(var_data, domain, Domain_cube_sph, land_domain, nz) Time_step = set_time (3600,0) !< 1 hour +call set_dummy_data(var_data, 666) +used = send_data(id_var8, var_data%var6, Time) do i=1,23 Time = Time + Time_step call set_dummy_data(var_data, i) @@ -210,9 +212,6 @@ program test_modern_diag used = send_data(id_var6, var_data%var6, Time) used = send_data(id_var7, var_data%var6, Time) - !TODO I don't know about this (scalar field) or how this is suppose to work #WUT - used = send_data(id_var8, var_data%var6, Time) - call diag_send_complete(Time_step) enddo call deallocate_dummy_data(var_data) diff --git a/test_fms/diag_manager/test_reduction_methods.F90 b/test_fms/diag_manager/test_reduction_methods.F90 index 0b09fc69ca..7a0bb8efc6 100644 --- a/test_fms/diag_manager/test_reduction_methods.F90 +++ b/test_fms/diag_manager/test_reduction_methods.F90 @@ -135,6 +135,7 @@ program test_reduction_methods ddata = allocate_buffer(isd, ied, jsd, jed, nz, nw) call init_buffer(ddata, isc, iec, jsc, jec, 2) !< The halos never get set case (test_openmp) + message = .true. if (mpp_pe() .eq. mpp_root_pe()) print *, "Testing the send_data calls with openmp blocks" call define_blocks ('testing_model', my_block, isc, iec, jsc, jec, kpts=0, & nx_block=1, ny_block=4, message=message) diff --git a/test_fms/field_manager/test_field_manager2.sh b/test_fms/field_manager/test_field_manager2.sh index 2485701598..313c830a75 100755 --- a/test_fms/field_manager/test_field_manager2.sh +++ b/test_fms/field_manager/test_field_manager2.sh @@ -106,6 +106,48 @@ else test_expect_success "field table read with use_field_table.yaml = .true." 'mpirun -n 1 ./test_field_table_read' test_expect_success "field manager functional r4 with yaml table" 'mpirun -n 2 ./test_field_manager_r4' test_expect_success "field manager functional r8 with yaml table" 'mpirun -n 2 ./test_field_manager_r8' + + cat <<_EOF > field_table.ens_01.yaml +field_table: +- field_type: tracer + modlist: + - model_type: atmos_mod + varlist: + - variable: radon + - variable: radon2 + - variable: radon3 + longname: bad radon! +_EOF + + cat <<_EOF > field_table.ens_02.yaml +field_table: +- field_type: tracer + modlist: + - model_type: atmos_mod + varlist: + - variable: radon + - variable: radon2 + - variable: radon3 + longname: bad radon! + - variable: radon4 + longname: REALLY bad radon! +_EOF +cat <<_EOF > input.nml +&field_manager_nml + use_field_table_yaml = .true. +/ +&test_field_table_read_nml + test_case = 1 +/ +&ensemble_nml + ensemble_size = 2 +/ +_EOF + test_expect_failure "field manager test with both field_table.yaml and field_table.ens_XX.yaml files present" 'mpirun -n 2 ./test_field_table_read' + + rm -rf field_table.yaml + + test_expect_success "field manager test with 2 ensembles" 'mpirun -n 2 ./test_field_table_read' fi test_done diff --git a/test_fms/field_manager/test_field_table_read.F90 b/test_fms/field_manager/test_field_table_read.F90 index ba9b125a46..bb46256cb1 100644 --- a/test_fms/field_manager/test_field_table_read.F90 +++ b/test_fms/field_manager/test_field_table_read.F90 @@ -36,15 +36,74 @@ program test_field_table_read use field_manager_mod, only: field_manager_init use fms_mod, only: fms_init, fms_end -use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_error, NOTE, FATAL +use fms2_io_mod, only: set_filename_appendix +use ensemble_manager_mod, only: get_ensemble_size, ensemble_manager_init +use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_error, NOTE, FATAL, input_nml_file, mpp_npes, & + mpp_set_current_pelist, mpp_get_current_pelist implicit none integer :: nfields +integer :: nfields_expected +integer :: io_status +integer :: npes +integer, allocatable :: pelist(:) +integer :: ens_siz(6) +integer :: ensemble_id +character(len=10) :: text +integer, parameter :: default_test = 0 +integer, parameter :: ensemble_test = 1 + +! namelist parameters +integer :: test_case = default_test + +namelist / test_field_table_read_nml / test_case call fms_init +read (input_nml_file, test_field_table_read_nml, iostat=io_status) +if (io_status > 0) call mpp_error(FATAL,'=>test_field_table_read: Error reading input.nml') + +npes = mpp_npes() +allocate(pelist(npes)) +call mpp_get_current_pelist(pelist) + +nfields_expected = 4 +select case (test_case) +case (ensemble_test) + if (npes .ne. 2) & + call mpp_error(FATAL, "test_field_table_read:: this test requires 2 PEs!") + + call ensemble_manager_init + ens_siz = get_ensemble_size() + if (ens_siz(1) .ne. 2) & + call mpp_error(FATAL, "This test requires 2 ensembles") + + if (mpp_pe() .eq. 0) then + !PEs 0 is the first ensemble + ensemble_id = 1 + call mpp_set_current_pelist((/0/)) + nfields_expected = 3 + else + !PEs 1 is the second ensemble + ensemble_id = 2 + call mpp_set_current_pelist((/1/)) + nfields_expected = 4 + endif + + write( text,'(a,i2.2)' ) 'ens_', ensemble_id + call set_filename_appendix(trim(text)) + +end select + call field_manager_init(nfields) -if (nfields .ne. 4) & +print *, nfields +if (nfields .ne. nfields_expected) & call mpp_error(FATAL, "test_field_table_read:: The number fields returned is not the expected result") + +select case (test_case) +case (ensemble_test) + call mpp_set_current_pelist(pelist) +end select + call fms_end end program test_field_table_read diff --git a/test_fms/fms2_io/test_domain_io.F90 b/test_fms/fms2_io/test_domain_io.F90 index 5b00d8c9fe..90d399bf3d 100644 --- a/test_fms/fms2_io/test_domain_io.F90 +++ b/test_fms/fms2_io/test_domain_io.F90 @@ -131,6 +131,9 @@ program test_domain_read 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 read_data_wrapper(fileobj, "var3", 6, var_data_out, var_data_in) + call read_data_wrapper(fileobj, "var4", 7, var_data_out, var_data_in) + call read_data_wrapper(fileobj, "var5", 8, var_data_out, var_data_in) call close_file(fileobj) endif @@ -295,6 +298,72 @@ subroutine read_data_wrapper(fileob, var_name, dim, var_data, ref_data) 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") + case(6) + !Only read the second third dimension (3d case) + call var_data_init(var_data) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,1:1,1,1), & + corner=(/1, 1, 2/), edge_lengths=(/ nx, ny, 1/)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,1:1,1,1)), mpp_chksum(ref_data%var_r4(:,:,2:2,1,1)), & + "var3_r4-slice") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,1:1,1,1), & + corner=(/1, 1, 2/), edge_lengths=(/ nx, ny, 1/)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,1:1,1,1)), mpp_chksum(ref_data%var_r8(:,:,2:2,1,1)), & + "var3_r8-slice") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,1:1,1,1), & + corner=(/1, 1, 2/), edge_lengths=(/ nx, ny, 1/)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,1:1,1,1)), mpp_chksum(ref_data%var_i4(:,:,2:2,1,1)), & + "var3_i4-slice") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,1:1,1,1), & + corner=(/1, 1, 2/), edge_lengths=(/ nx, ny, 1/)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,1:1,1,1)), mpp_chksum(ref_data%var_i8(:,:,2:2,1,1)), & + "var3_i8-slice") + case(7) + !Only read the second third dimension (4d case) + call var_data_init(var_data) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,1:1,:,1), & + corner=(/1, 1, 2, 1/), edge_lengths=(/ nx, ny, 1, ndim4/)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,1:1,:,1)), mpp_chksum(ref_data%var_r4(:,:,2:2,:,1)), & + "var4_r4-slice") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,1:1,:,1), & + corner=(/1, 1, 2, 1/), edge_lengths=(/ nx, ny, 1, ndim4/)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,1:1,:,1)), mpp_chksum(ref_data%var_r8(:,:,2:2,:,1)), & + "var4_r8-slice") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,1:1,:,1), & + corner=(/1, 1, 2, 1/), edge_lengths=(/ nx, ny, 1, ndim4/)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,1:1,:,1)), mpp_chksum(ref_data%var_i4(:,:,2:2,:,1)), & + "var4_i4-slice") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,1:1,:,1), & + corner=(/1, 1, 2, 1/), edge_lengths=(/ nx, ny, 1, ndim4/)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,1:1,:,1)), mpp_chksum(ref_data%var_i8(:,:,2:2,:,1)), & + "var4_i8-slice") + case(8) + !Only read the second third dimension (5d case) + call var_data_init(var_data) + call read_data(fileob, trim(var_name)//"_r4", var_data%var_r4(:,:,1:1,:,:), & + corner=(/1, 1, 2, 1, 1/), edge_lengths=(/ nx, ny, 1, ndim4, ndim5/)) + call compare_var_data(mpp_chksum(var_data%var_r4(:,:,1:1,:,:)), mpp_chksum(ref_data%var_r4(:,:,2:2,:,:)), & + "var5_r4-slice") + + call read_data(fileob, trim(var_name)//"_r8", var_data%var_r8(:,:,1:1,:,:), & + corner=(/1, 1, 2, 1, 1/), edge_lengths=(/ nx, ny, 1, ndim4, ndim5/)) + call compare_var_data(mpp_chksum(var_data%var_r8(:,:,1:1,:,:)), mpp_chksum(ref_data%var_r8(:,:,2:2,:,:)), & + "var5_r8-slice") + + call read_data(fileob, trim(var_name)//"_i4", var_data%var_i4(:,:,1:1,:,:), & + corner=(/1, 1, 2, 1, 1/), edge_lengths=(/ nx, ny, 1, ndim4, ndim5/)) + call compare_var_data(mpp_chksum(var_data%var_i4(:,:,1:1,:,:)), mpp_chksum(ref_data%var_i4(:,:,2:2,:,:)), & + "var5_i4-slice") + + call read_data(fileob, trim(var_name)//"_i8", var_data%var_i8(:,:,1:1,:,:), & + corner=(/1, 1, 2, 1, 1/), edge_lengths=(/ nx, ny, 1, ndim4, ndim5/)) + call compare_var_data(mpp_chksum(var_data%var_i8(:,:,1:1,:,:)), mpp_chksum(ref_data%var_i8(:,:,2:2,:,:)), & + "var5_i8-slice") end select end subroutine read_data_wrapper diff --git a/test_fms/horiz_interp/Makefile.am b/test_fms/horiz_interp/Makefile.am index 812ab6cccb..27de50a932 100644 --- a/test_fms/horiz_interp/Makefile.am +++ b/test_fms/horiz_interp/Makefile.am @@ -29,14 +29,16 @@ AM_CPPFLAGS = -I$(MODDIR) LDADD = $(top_builddir)/libFMS/libFMS.la # Build these test programs. -check_PROGRAMS = test_horiz_interp_r4 test_horiz_interp_r8 +check_PROGRAMS = test_horiz_interp_r4 test_horiz_interp_r8 test_create_xgrid_order2_r8 # These are the sources for the tests. test_horiz_interp_r4_SOURCES = test_horiz_interp.F90 test_horiz_interp_r8_SOURCES = test_horiz_interp.F90 +test_create_xgrid_order2_r8_SOURCES = test_create_xgrid_order2.F90 test_horiz_interp_r4_CPPFLAGS=-DHI_TEST_KIND=4 -I$(MODDIR) test_horiz_interp_r8_CPPFLAGS=-DHI_TEST_KIND=8 -I$(MODDIR) +test_create_xgrid_order2_r8_CPPFLAGS=-DHI_TEST_KIND_=8 -I$(MODDIR) TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ @@ -44,10 +46,10 @@ SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ TESTS_ENVIRONMENT= test_input_path="@TEST_INPUT_PATH@" # Run the test programs. -TESTS = test_horiz_interp2.sh +TESTS = test_horiz_interp2.sh test_create_xgrid_order2.sh # These files will also be included in the distribution. -EXTRA_DIST = test_horiz_interp2.sh +EXTRA_DIST = test_horiz_interp2.sh test_create_xgrid_order2.sh # Clean up CLEANFILES = input.nml *.out* *.dpi *.spi *.dyn *.spl diff --git a/test_fms/horiz_interp/test_create_xgrid_order2.F90 b/test_fms/horiz_interp/test_create_xgrid_order2.F90 new file mode 100644 index 0000000000..5a3252c303 --- /dev/null +++ b/test_fms/horiz_interp/test_create_xgrid_order2.F90 @@ -0,0 +1,118 @@ +!*********************************************************************** +! 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 program ensures all necessary functions exist in grid_utils for +!! creating the exchange grid for second order remapping. +!! The first order exchange grid creation is tested in test_horiz_interp. +!! This test is rudimentary and only checks that create_xgrid_order2 returns +!! without failure. + +program test_create_xgrid_order2 + + use horiz_interp_mod + use constants_mod, only: DEG_TO_RAD + implicit none + + integer, parameter :: lkind = HI_TEST_KIND_ + + integer, parameter :: nlon_in = 10 !< number of input grid cells in lon direction + integer, parameter :: nlat_in = 10 !< number of input grid cells in the lat direction + integer, parameter :: nlon_out = nlon_in * 2 !< number of output grid cells in lon direction + integer, parameter :: nlat_out = nlat_in * 2 !< number of output grid cells in lat direction + integer, parameter :: ngridpts_in = (nlon_in+1)*(nlat_in+1) !< number of input gridpoints + integer, parameter :: ngridpts_out = (nlon_out+1)*(nlat_out+1) !< number of output gridpoints + integer, parameter :: nxgrid = nlon_out *nlat_out !< expected number of exchange grid cells + + real(HI_TEST_KIND_) :: lon_in(ngridpts_in) !< longitudinal values of input grid cell vertices + real(HI_TEST_KIND_) :: lat_in(ngridpts_in) !< latitudinal values of input grid cell vertices + real(HI_TEST_KIND_) :: lon_out(ngridpts_out) !< longitudinal values of output grid cell vertices + real(HI_TEST_KIND_) :: lat_out(ngridpts_out) !< latitudinal values of output grid cell vertices + real(HI_TEST_KIND_) :: mask(nlon_in*nlat_in) !< mask to skip input grid cell + + integer :: i_in(nxgrid) !< input parent cell indices + integer :: j_in(nxgrid) !< input parent cell indices + integer :: i_out(nxgrid) !< output parent cell indices + integer :: j_out(nxgrid) !< output parent cell indices + real(HI_TEST_KIND_) :: xgrid_area(nxgrid) !< exchange grid cell areas + real(HI_TEST_KIND_) :: xgrid_clon(nxgrid) !< longitudinal values of exchange grid cell centroid point + real(HI_TEST_KIND_) :: xgrid_clat(nxgrid) !< latitudinal values of exchange grid cell centroid point + + mask = 1.0_lkind + + call get_grid(nlon_in, nlat_in, lon_in, lat_in) + call get_grid(nlon_out, nlat_out, lon_out, lat_out) + + call test_create_xgrid_2dx2d_order2(nlon_in, nlat_in, nlon_out, nlat_out, nxgrid, & + mask, lon_in, lat_in, lon_out, lat_out, & + i_in, j_in, i_out, j_out, xgrid_area, xgrid_clon, xgrid_clat) + +contains + + !> Returns lon and lat arrays holding grid point values + subroutine get_grid(nlon, nlat, lon, lat) + + implicit none + integer, intent(in) :: nlon, nlat !< number of cell in lon and lat direction + real(HI_TEST_KIND_), intent(out) :: lon(:), lat(:) !< lon and lat values at cell vertices + + integer :: ilon, ilat, igridpt + real :: dlat=0.0_lkind, dlon=0.0_lkind + real :: lon_start=0.0_lkind, lat_start=-90.0_lkind*DEG_TO_RAD + + dlat = 180._lkind/real(nlat, HI_TEST_KIND_) * DEG_TO_RAD + dlon = 360._lkind/real(nlon, HI_TEST_KIND_) * DEG_TO_RAD + + igridpt = 1 + do ilat=1, nlat+1 + do ilon=1, nlon+1 + lon(igridpt) = lon_start + real(ilon-1, HI_TEST_KIND_)*dlon + lat(igridpt) = lat_start + real(ilat-1, HI_TEST_KIND_)*dlat + igridpt = igridpt + 1 + end do + end do + + end subroutine get_grid + + + !> Calls create_xgrid_2dx2d_order2. This subroutine also checks the returned value of nxgrid + subroutine test_create_xgrid_2dx2d_order2(nlon_inl, nlat_inl, nlon_outl, nlat_outl, nxgridl, & + maskl, lon_inl, lat_inl, lon_outl, lat_outl, & + i_inl, j_inl, i_outl, j_outl, xgrid_areal, xgrid_clonl, xgrid_clatl) + + implicit none + integer, intent(in) :: nlon_inl, nlat_inl, nlon_outl, nlat_outl, nxgridl !< number of grid cells + integer, intent(inout) :: i_inl(:), j_inl(:), i_outl(:), j_outl(:) !< parent cell indices + real(HI_TEST_KIND_), intent(in) :: lon_inl(:), lat_inl(:), lon_outl(:), lat_outl(:) !< lon and lat + real(HI_TEST_KIND_), intent(in) :: maskl(:) !< input grid cell mask + real(HI_TEST_KIND_), intent(out) :: xgrid_areal(:), xgrid_clonl(:), xgrid_clatl(:) !< returned xgrid info + + integer :: create_xgrid_2dx2d_order2 + integer :: nxgrid_out + + nxgrid_out = create_xgrid_2dx2d_order2(nlon_inl, nlat_inl, nlon_outl, nlat_outl, lon_inl, lat_inl, & + lon_outl, lat_outl, maskl, i_inl, j_inl, i_outl, j_outl, xgrid_areal, & + xgrid_clonl, xgrid_clatl) + + if(nxgrid_out /= nxgridl) then + write(*,*) 'Expected', nxgrid, 'but got', nxgrid_out + error stop + end if + + end subroutine test_create_xgrid_2dx2d_order2 + +end program test_create_xgrid_order2 diff --git a/test_fms/horiz_interp/test_create_xgrid_order2.sh b/test_fms/horiz_interp/test_create_xgrid_order2.sh new file mode 100755 index 0000000000..6076ee3eba --- /dev/null +++ b/test_fms/horiz_interp/test_create_xgrid_order2.sh @@ -0,0 +1,33 @@ +#!/bin/sh + +#*********************************************************************** +#* 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 part of the GFDL FMS package. This is a shell script to +# 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 + + +test_expect_success "create_xgrid order2" 'mpirun -n 1 ./test_create_xgrid_order2_r8' +test_done diff --git a/test_fms/horiz_interp/test_horiz_interp.F90 b/test_fms/horiz_interp/test_horiz_interp.F90 index eb8afba071..59ccdbb230 100644 --- a/test_fms/horiz_interp/test_horiz_interp.F90 +++ b/test_fms/horiz_interp/test_horiz_interp.F90 @@ -37,7 +37,7 @@ program horiz_interp_test 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_mod, only : horiz_interp, horiz_interp_type, assignment(=) use horiz_interp_type_mod, only: SPHERICAL use constants_mod, only : constants_init, PI use horiz_interp_bilinear_mod, only: horiz_interp_bilinear_new @@ -111,7 +111,7 @@ program horiz_interp_test 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 + type(horiz_interp_type) :: interp_t, interp_copy !! input data real(HI_TEST_KIND_), allocatable, dimension(:,:) :: data_src, data_dst !! output data @@ -125,7 +125,6 @@ subroutine test_horiz_interp_spherical 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. @@ -170,6 +169,7 @@ subroutine test_horiz_interp_spherical 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) + interp_copy = interp_t else call horiz_interp(data_src, lon_in_2D, lat_in_2D, lon_out_2D, lat_out_2D, data_dst, interp_method="spherical") endif @@ -185,7 +185,9 @@ subroutine test_horiz_interp_spherical enddo if(.not. test_solo) then call horiz_interp_del(interp_t) + call horiz_interp_del(interp_copy) call check_dealloc(interp_t) + call check_dealloc(interp_copy) endif deallocate(data_src, data_dst) deallocate(lat_in_2D, lon_in_2D) @@ -203,9 +205,8 @@ subroutine test_horiz_interp_bilinear real(HI_TEST_KIND_) :: lon_src_beg = 0._lkind, lon_src_end = 360.0_lkind real(HI_TEST_KIND_) :: lat_src_beg = -90._lkind, lat_src_end = 90._lkind real(HI_TEST_KIND_), parameter :: D2R = real(PI,lkind)/180._lkind - real(HI_TEST_KIND_), parameter :: R2D = 180._lkind/real(PI,lkind) - type(horiz_interp_type) :: interp + type(horiz_interp_type) :: interp, interp_copy if (decreasing_lat) then lon_src_beg = 360.0_lkind @@ -256,6 +257,7 @@ subroutine test_horiz_interp_bilinear 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) + interp_copy = interp else call horiz_interp(data_src, lon1D_src, lat1D_src, lon1D_dst, lat1D_dst, data_dst, interp_method = "bilinear") endif @@ -313,7 +315,9 @@ subroutine test_horiz_interp_bilinear end do if(.not. test_solo) then call horiz_interp_del(interp) + call horiz_interp_del(interp_copy) call check_dealloc(interp) + call check_dealloc(interp_copy) endif ! --- 1dx2d version bilinear interpolation @@ -329,6 +333,7 @@ subroutine test_horiz_interp_bilinear 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) + interp_copy = interp else call horiz_interp(data_src, lon1D_src, lat1D_src, lon2D_dst, lat2D_dst, data_dst,interp_method="bilinear") endif @@ -386,7 +391,9 @@ subroutine test_horiz_interp_bilinear end do if(.not. test_solo) then call horiz_interp_del(interp) + call horiz_interp_del(interp_copy) call check_dealloc(interp) + call check_dealloc(interp_copy) endif if (decreasing_lat) return @@ -405,6 +412,7 @@ subroutine test_horiz_interp_bilinear 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) + interp_copy = interp 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") @@ -502,7 +510,9 @@ subroutine test_horiz_interp_bilinear end do if(.not. test_solo) then call horiz_interp_del(interp) + call horiz_interp_del(interp_copy) call check_dealloc(interp) + call check_dealloc(interp_copy) endif ! --- 2dx2d version bilinear interpolation @@ -514,6 +524,7 @@ subroutine test_horiz_interp_bilinear 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) + interp_copy = interp else call horiz_interp(data_src, lon2D_src, lat2d_src, lon2D_dst, lat2D_dst, data_dst, interp_method="bilinear") endif @@ -601,7 +612,9 @@ subroutine test_horiz_interp_bilinear endif if(.not. test_solo) then call horiz_interp_del(interp) + call horiz_interp_del(interp_copy) call check_dealloc(interp) + call check_dealloc(interp_copy) endif !check that data are equal do j=1, nj_src @@ -620,8 +633,7 @@ end subroutine test_horiz_interp_bilinear 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 + type(horiz_interp_type) :: interp_t, interp_copy !! input data real(HI_TEST_KIND_), allocatable, dimension(:,:) :: data_src, data_dst !! output data @@ -637,7 +649,6 @@ subroutine test_horiz_interp_bicubic 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. @@ -691,6 +702,7 @@ subroutine test_horiz_interp_bicubic 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) + interp_copy = interp_t else call horiz_interp(data_src, lon_in_1D, lat_in_1D, lon_out_1D, lat_out_1D, data_dst, interp_method="bicubic") endif @@ -719,7 +731,9 @@ subroutine test_horiz_interp_bicubic enddo enddo call horiz_interp_del(interp_t) + call horiz_interp_del(interp_copy) call check_dealloc(interp_t) + call check_dealloc(interp_copy) endif do i=isc, iec do j=jsc, jec @@ -737,6 +751,7 @@ subroutine test_horiz_interp_bicubic 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) + interp_copy = interp_t else call horiz_interp(data_src, lon_in_1D, lat_in_1D, lon_out_2D, lat_out_2D, data_dst, interp_method="bicubic") endif @@ -762,7 +777,9 @@ subroutine test_horiz_interp_bicubic enddo enddo call horiz_interp_del(interp_t) + call horiz_interp_del(interp_copy) call check_dealloc(interp_t) + call check_dealloc(interp_copy) endif do i=isc, iec do j=jsc, jec @@ -782,14 +799,13 @@ subroutine test_horiz_interp_conserve 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 + type(horiz_interp_type) :: interp_conserve, interp_copy 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) ) @@ -861,22 +877,29 @@ subroutine test_horiz_interp_conserve 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) + interp_copy = interp_conserve call horiz_interp_del(interp_conserve) + call horiz_interp_del(interp_copy) call check_dealloc(interp_conserve) + call check_dealloc(interp_copy) 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) + interp_copy = interp_conserve call horiz_interp_del(interp_conserve) + call horiz_interp_del(interp_copy) call check_dealloc(interp_conserve) + call check_dealloc(interp_copy) else call horiz_interp(data_src, lon1D_src, lat1D_src, lon2D_dst, lat2D_dst, data2_dst, & interp_method="conservative") @@ -889,8 +912,11 @@ subroutine test_horiz_interp_conserve 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) + interp_copy = interp_conserve call horiz_interp_del(interp_conserve) + call horiz_interp_del(interp_copy) call check_dealloc(interp_conserve) + call check_dealloc(interp_copy) else call horiz_interp(data_src, lon2D_src, lat2D_src, lon1D_dst, lat1D_dst, data3_dst, & interp_method="conservative") @@ -903,8 +929,11 @@ subroutine test_horiz_interp_conserve 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) + interp_copy = interp_conserve call horiz_interp_del(interp_conserve) + call horiz_interp_del(interp_copy) call check_dealloc(interp_conserve) + call check_dealloc(interp_copy) else call horiz_interp(data_src, lon2D_src, lat2D_src, lon2D_dst, lat2D_dst, data4_dst, & interp_method="conservative") @@ -963,7 +992,7 @@ subroutine test_horiz_interp_conserve !! Also tests creating the types via the method-specific *_new routines to ensure !! they can be created/deleted without allocation errors. subroutine test_assignment() - type(horiz_interp_type) :: Interp_new1, Interp_new2, Interp_cp, intp_3 + type(horiz_interp_type) :: Interp_new1, Interp_new2, Interp_cp real(HI_TEST_KIND_), allocatable, dimension(:) :: lat_in_1D, lon_in_1D !< 1D grid data points real(HI_TEST_KIND_), allocatable, dimension(:,:) :: lat_in_2D, lon_in_2D !< 2D grid data points real(HI_TEST_KIND_), allocatable, dimension(:) :: lat_out_1D, lon_out_1D !< 1D grid output points @@ -980,7 +1009,6 @@ subroutine test_assignment() real(HI_TEST_KIND_) :: lat_dst_beg = -90._lkind, lat_dst_end = 90._lkind !< destination grid !! starting/ending latitudes real(HI_TEST_KIND_) :: D2R = real(PI,HI_TEST_KIND_)/180._lkind !< radians per degree - real(HI_TEST_KIND_) :: R2D = 180._lkind/real(PI,HI_TEST_KIND_) !< degrees per radian real(HI_TEST_KIND_), allocatable :: lon_src_1d(:), lat_src_1d(:) !< src data used for bicubic test real(HI_TEST_KIND_), allocatable :: lon_dst_1d(:), lat_dst_1d(:) !< destination data used for bicubic test integer :: icount !< index for setting the output array when taking midpoints for bilinear @@ -1103,7 +1131,7 @@ subroutine test_assignment() ! this set up is usually done within horiz_interp_new nlon_in = size(lon_in_1d(:))-1; nlat_in = size(lat_in_1d(:))-1 nlon_out = size(lon_out_1d(:))-1; nlat_out = size(lat_out_1d(:))-1 - allocate(lon_src_1d(nlon_in), lat_src_1d(nlat_in)) + allocate(lon_src_1d(nlon_in-1), lat_src_1d(nlat_in-1)) allocate(lon_dst_1d(nlon_out), lat_dst_1d(nlat_out)) do i = 1, nlon_in-1 lon_src_1d(i) = (lon_in_1d(i) + lon_in_1d(i+1)) * 0.5_lkind @@ -1185,7 +1213,7 @@ subroutine test_assignment() 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)) + allocate(lon_out_1D(ni_dst), lat_out_1D(nj_dst)) do i=1, ni_dst lon_out_1d(i) = real(i-1, HI_TEST_KIND_) * dlon_dst + lon_dst_beg enddo diff --git a/test_fms/monin_obukhov/test_monin_obukhov.F90 b/test_fms/monin_obukhov/test_monin_obukhov.F90 index 36da4b7947..27b386a250 100644 --- a/test_fms/monin_obukhov/test_monin_obukhov.F90 +++ b/test_fms/monin_obukhov/test_monin_obukhov.F90 @@ -125,17 +125,10 @@ program test_monin_obukhov integer(ki), dimension(n_1d) :: del_m, del_t, del_q end type - type(drag_input_t), parameter :: drag_input = drag_input_t() & - & !< Input arguments for mo_drag - - type(stable_mix_input_t), parameter :: stable_mix_input = stable_mix_input_t() & - & !< Input arguments for stable_mix - - type(diff_input_t), parameter :: diff_input = diff_input_t() & - & !< Input arguments for mo_diff - - type(profile_input_t), parameter :: profile_input = profile_input_t() & - & !< Input arguments for mo_profile + type(drag_input_t), parameter :: drag_input = drag_input_t() !< Input arguments for mo_drag + type(stable_mix_input_t), parameter :: stable_mix_input = stable_mix_input_t() !< Input arguments for stable_mix + type(diff_input_t), parameter :: diff_input = diff_input_t() !< Input arguments for mo_diff + type(profile_input_t), parameter :: profile_input = profile_input_t() !< Input arguments for mo_profile ! Entries 1:n of the arrays below contain known answer keys. Entry n+1 contains ! the answers that we calculate. Represent answer data using integral arrays, diff --git a/test_fms/mosaic2/test_mosaic2.F90 b/test_fms/mosaic2/test_mosaic2.F90 index 10da8a2820..95cf1abe78 100644 --- a/test_fms/mosaic2/test_mosaic2.F90 +++ b/test_fms/mosaic2/test_mosaic2.F90 @@ -96,6 +96,7 @@ subroutine test_get_mosaic_grid_sizes allocate( nx_out(c1_ntiles), ny_out(c1_ntiles) ) call get_mosaic_grid_sizes(fileobj, nx_out, ny_out) + ntiles = get_mosaic_ntiles(fileobj) do n=1, ntiles call check_answer(c1_nx/2, nx_out(n), 'atm TEST_GET_MOSAIC_GRID_SIZES') call check_answer(c1_nx/2, ny_out(n), 'atm TEST_GET_MOSAIC_GRID_SIZES') @@ -254,7 +255,7 @@ subroutine test_is_inside_polygon z2(1)=2.0_lkind ; z2(2)=4.0_lkind ; z2(3)=4.0_lkind ; z2(4)=2.0_lkind ; z2(5)=2.0_lkind do i=1, n r = sqrt( x2(i)**2 + y2(i)**2 + z2(i)**2 ) - lon2(i)=atan(y2(i)/x2(i)) + lon2(i)=atan2(y2(i), x2(i)) lat2(i)=asin(z2(i)/r) end do @@ -263,7 +264,7 @@ subroutine test_is_inside_polygon y1=5.0_lkind z1=4.2_lkind r = sqrt(x1**2+y1**2+z1**2) - lon1=atan(y1/x1) + lon1=atan2(y1, x1) lat1=asin(z1/r) answer=.false. @@ -275,7 +276,7 @@ subroutine test_is_inside_polygon y1=3.0_lkind z1=2.5_lkind r = sqrt(x1**2+y1**2+z1**2) - lon1=atan(y1/x1) + lon1=atan2(y1, x1) lat1=asin(z1/r) answer=.true. diff --git a/test_fms/mpp/test_domains_simple.F90 b/test_fms/mpp/test_domains_simple.F90 index 9308d089bf..abc36adc24 100644 --- a/test_fms/mpp/test_domains_simple.F90 +++ b/test_fms/mpp/test_domains_simple.F90 @@ -24,11 +24,12 @@ !> @author Ed Hartnett 6/22/20 program test_domains_simple + use mpp_mod use mpp_domains_mod - + use platform_mod implicit none -#include "../../include/fms_platform.h" + integer :: pe, npes !> This pe and the total number of pes. integer :: nx=40, ny=40 !> Size of our 2D domain. integer :: layout(2) !> Layout of our 2D domain. diff --git a/test_fms/mpp/test_mpp_mem_dump.F90 b/test_fms/mpp/test_mpp_mem_dump.F90 index 19c3ce3934..c0f0d1ec4b 100644 --- a/test_fms/mpp/test_mpp_mem_dump.F90 +++ b/test_fms/mpp/test_mpp_mem_dump.F90 @@ -27,8 +27,9 @@ !! Test that the call to mpp_mem_dump is functional. On a supported OS, the return value !! of mpp_mem_dump should be a positive integer. program test_mpp_mem_dump + use mpp_memutils_mod, only: mpp_mem_dump -#include "../../include/fms_platform.h" + use platform_mod implicit none real :: memuse diff --git a/test_fms/mpp/test_mpp_memutils_begin_2x.F90 b/test_fms/mpp/test_mpp_memutils_begin_2x.F90 index c032ee6323..f687bbab3a 100644 --- a/test_fms/mpp/test_mpp_memutils_begin_2x.F90 +++ b/test_fms/mpp/test_mpp_memutils_begin_2x.F90 @@ -28,10 +28,10 @@ !! code this is an error, which should be caught. This program should exit !! non-zero. program test_mpp_memutils_init_end -#include "../../include/fms_platform.h" use mpp_mod, only : mpp_init, mpp_exit use mpp_memutils_mod, only: mpp_memuse_begin, mpp_memuse_end + use platform_mod implicit none real, dimension(:), allocatable :: ralloc_mem diff --git a/test_fms/mpp/test_mpp_memutils_begin_end.F90 b/test_fms/mpp/test_mpp_memutils_begin_end.F90 index d07a5e6ec0..f017fda331 100644 --- a/test_fms/mpp/test_mpp_memutils_begin_end.F90 +++ b/test_fms/mpp/test_mpp_memutils_begin_end.F90 @@ -28,10 +28,10 @@ !! This test will exit with status zero if successful. The script launching this test !! program may, if desired, check if the memory output numbers are sane. program test_mpp_memutils_init_end -#include "../../include/fms_platform.h" use mpp_mod, only : mpp_init, mpp_exit use mpp_memutils_mod, only: mpp_memuse_begin, mpp_memuse_end + use platform_mod implicit none real, dimension(:), allocatable :: ralloc_mem diff --git a/test_fms/mpp/test_mpp_memutils_end_before_begin.F90 b/test_fms/mpp/test_mpp_memutils_end_before_begin.F90 index 71a3e5460e..fd69c409e5 100644 --- a/test_fms/mpp/test_mpp_memutils_end_before_begin.F90 +++ b/test_fms/mpp/test_mpp_memutils_end_before_begin.F90 @@ -27,10 +27,10 @@ !! Test the error case when mpp_memuse_end() is called before mpp_memuse_begin(). !! This test program should exit non-zero if successful. program test_mpp_memutils_init_end -#include "../../include/fms_platform.h" use mpp_mod, only : mpp_init, mpp_exit use mpp_memutils_mod, only: mpp_memuse_begin, mpp_memuse_end + use platform_mod implicit none real, dimension(:), allocatable :: ralloc_mem diff --git a/test_fms/mpp/test_mpp_print_memuse_stats_file.F90 b/test_fms/mpp/test_mpp_print_memuse_stats_file.F90 index c6d5ca1230..389fae4c95 100644 --- a/test_fms/mpp/test_mpp_print_memuse_stats_file.F90 +++ b/test_fms/mpp/test_mpp_print_memuse_stats_file.F90 @@ -32,11 +32,11 @@ !! successful. The script calling the program can check if the numbers are sane, if !! desired. program test_mpp_mem_print_stats_file -#include "../../include/fms_platform.h" use mpp_mod, only : mpp_init, mpp_exit, stdout use mpp_memutils_mod, only: mpp_memuse_begin, mpp_memuse_end use mpp_memutils_mod, only: mpp_print_memuse_stats + use platform_mod implicit none real, dimension(:), allocatable :: ralloc_mem1, ralloc_mem2 diff --git a/test_fms/mpp/test_mpp_print_memuse_stats_stderr.F90 b/test_fms/mpp/test_mpp_print_memuse_stats_stderr.F90 index 57eddc53bf..dd507cd089 100644 --- a/test_fms/mpp/test_mpp_print_memuse_stats_stderr.F90 +++ b/test_fms/mpp/test_mpp_print_memuse_stats_stderr.F90 @@ -30,11 +30,11 @@ !! successful. The script calling the program can check if the numbers are sane, if !! desired. program test_mpp_mem_print_stats_stderr -#include "../../include/fms_platform.h" use mpp_mod, only : mpp_init, mpp_exit use mpp_memutils_mod, only: mpp_memuse_begin, mpp_memuse_end use mpp_memutils_mod, only: mpp_print_memuse_stats + use platform_mod implicit none real, dimension(:), allocatable :: ralloc_mem1, ralloc_mem2 diff --git a/test_fms/mpp/test_stdlog.F90 b/test_fms/mpp/test_stdlog.F90 index 61ee8d81c8..92b4079157 100644 --- a/test_fms/mpp/test_stdlog.F90 +++ b/test_fms/mpp/test_stdlog.F90 @@ -85,6 +85,7 @@ subroutine check_write() if (trim(line) == '') cycle !! if we're testing with the old io enabled, we'll have some additional output we can skip if (trim(line) == 'NOTE from PE 0: MPP_IO_SET_STACK_SIZE: stack size set to 131072.') cycle + if (index(trim(line), "fms_io") .ne. 0) cycle if(trim(line) .ne. trim(ref_line(ref_num))) call mpp_error(FATAL, "warnfile output does not match reference data"& //"reference line:"//ref_line(ref_num) & //"output line:"//line) diff --git a/test_fms/parser/test_output_yaml.F90 b/test_fms/parser/test_output_yaml.F90 index 6122ff7ab3..e5a144caba 100644 --- a/test_fms/parser/test_output_yaml.F90 +++ b/test_fms/parser/test_output_yaml.F90 @@ -203,11 +203,12 @@ program test_output_yaml call yaml_out_add_level2key( "order 4",k1(1)) call yaml_out_add_level2key( "sides", k2(1)) call yaml_out_add_level2key( "specials", k2(2)) - call write_yaml_from_struct_3 (trim(filename), 1, k1, v1, a2, k2, v2, a3, (/1, 1, 1, 1, 2, 1/), k3, v3, & - & (/ 1, 1, 1 , 1, 0 ,0 ,0 ,0/)) + call write_yaml_from_struct_3 (trim(filename) // c_null_char, 1, k1, v1, a2, k2, v2, a3, & + & (/1, 1, 1, 1, 2, 1/), k3, v3, (/ 1, 1, 1 , 1, 0 ,0 ,0 ,0/)) else !> Write the yaml - call write_yaml_from_struct_3 (trim(filename), 1, k1, v1, a2, k2, v2, a3, a3each, k3, v3,(/3, 0, 0, 0, 0, 0, 0, 0/)) + call write_yaml_from_struct_3 (trim(filename) // c_null_char, 1, k1, v1, a2, k2, v2, a3, & + & a3each, k3, v3, (/3, 0, 0, 0, 0, 0, 0, 0/)) endif !> Check yaml output against reference diff --git a/test_fms/topography/test_topography.F90 b/test_fms/topography/test_topography.F90 index 0ccbebd63e..a8f2b9b71c 100644 --- a/test_fms/topography/test_topography.F90 +++ b/test_fms/topography/test_topography.F90 @@ -144,20 +144,22 @@ program test_top end if !-------------------------------------------------------------------------------------------------------------! - call test_topog_mean ; call test_topog_stdev - call test_get_ocean_frac ; call test_get_ocean_mask - call test_get_water_frac ; call test_get_water_mask + call test_topog_mean(lat2d, lon2d, lat1d, lon1d) ; call test_topog_stdev(lat2d, lon2d, lat1d, lon1d) + call test_get_ocean_frac(lat2d, lon2d, lat1d, lon1d) ; call test_get_ocean_mask(lat2d, lon2d, lat1d, lon1d) + call test_get_water_frac(lat2d, lon2d, lat1d, lon1d) ; call test_get_water_mask(lat2d, lon2d, lat1d, lon1d) call fms_end contains - subroutine test_topog_mean() + subroutine test_topog_mean(lat2d, lon2d, lat1d, lon1d) !! The naming convention of zmean2d/1d in this routine does not relate to their !! dimensions but correlates with what dimensions of lat and lon they are being !! tested with. In this case, the sizes of both zmean2d and zmean1d are both the !! same size but have to be these specific dimensions per the topography_mod code implicit none + real(kind=TEST_TOP_KIND_), dimension(2,2), intent(in) :: lat2d, lon2d + real(kind=TEST_TOP_KIND_), dimension(2), intent(in) :: lat1d, lon1d real(kind=TEST_TOP_KIND_), dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: zmean2d real(kind=TEST_TOP_KIND_), dimension(size(lon1d)-1,size(lat1d)-1) :: zmean1d logical :: get_mean_answer @@ -182,13 +184,15 @@ subroutine test_topog_mean() end subroutine test_topog_mean - subroutine test_topog_stdev + subroutine test_topog_stdev(lat2d, lon2d, lat1d, lon1d) !! The naming convention of stdev2d/1d in this routine does not relate to their !! dimensions but correlates with what dimensions of lat and lon they are being !! tested with. In this case, the sizes of both stdev2d and stdev1d are both the !! same size but have to be these specific dimensions per the topography_mod code implicit none + real(kind=TEST_TOP_KIND_), dimension(2,2), intent(in) :: lat2d, lon2d + real(kind=TEST_TOP_KIND_), dimension(2), intent(in) :: lat1d, lon1d real(kind=TEST_TOP_KIND_), dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: stdev2d real(kind=TEST_TOP_KIND_), dimension(size(lon1d)-1,size(lat1d)-1) :: stdev1d logical :: get_stdev_answer @@ -213,13 +217,15 @@ subroutine test_topog_stdev end subroutine test_topog_stdev - subroutine test_get_ocean_frac + subroutine test_get_ocean_frac(lat2d, lon2d, lat1d, lon1d) !! The naming convention of ocean_frac2d/1d in this routine does not relate to their !! dimensions but correlates with what dimensions of lat and lon they are being !! tested with. In this case, the sizes of both ocean_frac2d and ocean_frac1d are both the !! same size but have to be these specific dimensions per the topography_mod code implicit none + real(kind=TEST_TOP_KIND_), dimension(2,2), intent(in) :: lat2d, lon2d + real(kind=TEST_TOP_KIND_), dimension(2), intent(in) :: lat1d, lon1d real(kind=TEST_TOP_KIND_), dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: ocean_frac2d real(kind=TEST_TOP_KIND_), dimension(size(lon1d)-1,size(lat1d)-1) :: ocean_frac1d logical :: get_ocean_frac_answer @@ -243,16 +249,18 @@ subroutine test_get_ocean_frac ! with a larger ocean_frac1d array size end subroutine test_get_ocean_frac - subroutine test_get_ocean_mask + subroutine test_get_ocean_mask(lat2d, lon2d, lat1d, lon1d) !! The naming convention of ocean_mask2d/1d in this routine does not relate to their !! dimensions but correlates with what dimensions of lat and lon they are being !! tested with. In this case, the sizes of both ocean_mask2d and ocean_mask1d are both the !! same size but have to be these specific dimensions per the topography_mod code implicit none - logical, dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: ocean_mask2d - logical, dimension(size(lon1d)-1,size(lat1d)-1) :: ocean_mask1d - logical :: get_ocean_mask_answer + real(kind=TEST_TOP_KIND_), dimension(2,2), intent(in) :: lat2d, lon2d + real(kind=TEST_TOP_KIND_), dimension(2), intent(in) :: lat1d, lon1d + logical, dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: ocean_mask2d + logical, dimension(size(lon1d)-1,size(lat1d)-1) :: ocean_mask1d + logical :: get_ocean_mask_answer !---------------------------------------- test get_ocean_mask 2d ---------------------------------------------! @@ -275,12 +283,14 @@ subroutine test_get_ocean_mask end subroutine test_get_ocean_mask - subroutine test_get_water_frac + subroutine test_get_water_frac(lat2d, lon2d, lat1d, lon1d) !! The naming convention of water_frac2d/1d in this routine does not relate to their !! dimensions but correlates with what dimensions of lat and lon they are being !! tested with. In this case, the sizes of both water_frac2d and water_frac1d are both the !! same size but have to be these specific dimensions per the topography_mod code implicit none + real(kind=TEST_TOP_KIND_), dimension(2,2), intent(in) :: lat2d, lon2d + real(kind=TEST_TOP_KIND_), dimension(2), intent(in) :: lat1d, lon1d real(kind=TEST_TOP_KIND_), dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: water_frac2d real(kind=TEST_TOP_KIND_), dimension(size(lon1d)-1,size(lat1d)-1) :: water_frac1d logical :: get_water_frac_answer @@ -305,16 +315,18 @@ subroutine test_get_water_frac end subroutine test_get_water_frac - subroutine test_get_water_mask + subroutine test_get_water_mask(lat2d, lon2d, lat1d, lon1d) !! The naming convention of water_mask2d/1d in this routine does not relate to their !! dimensions but correlates with what dimensions of lat and lon they are being !! tested with. In this case, the sizes of both water_mask2d and water_mask1d are both the !! same size but have to be these specific dimensions per the topography_mod code implicit none - logical, dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: water_mask2d - logical, dimension(size(lon1d)-1,size(lat1d)-1) :: water_mask1d - logical :: get_water_mask_answer + real(kind=TEST_TOP_KIND_), dimension(2,2), intent(in) :: lat2d, lon2d + real(kind=TEST_TOP_KIND_), dimension(2), intent(in) :: lat1d, lon1d + logical, dimension(size(lon2d,1)-1,size(lat2d,2)-1) :: water_mask2d + logical, dimension(size(lon1d)-1,size(lat1d)-1) :: water_mask1d + logical :: get_water_mask_answer !---------------------------------------- test get_water_mask 2d ---------------------------------------------! @@ -352,4 +364,4 @@ end subroutine check_answers -end program test_top \ No newline at end of file +end program test_top diff --git a/test_fms/tracer_manager/test_tracer_manager.F90 b/test_fms/tracer_manager/test_tracer_manager.F90 index dbab8a5e2e..f8697f7c04 100644 --- a/test_fms/tracer_manager/test_tracer_manager.F90 +++ b/test_fms/tracer_manager/test_tracer_manager.F90 @@ -45,7 +45,8 @@ subroutine test_set_tracer_profile integer, parameter :: numlevels=10 integer, parameter :: npoints=5 - integer :: tracer_index, success, i, j, k + integer :: tracer_index, i, j, k + logical :: success real(TEST_TM_KIND_) :: top_value, bottom_value, surf_value, multiplier real(TEST_TM_KIND_) :: tracer_out1(1,1,1), tracer_out2(npoints,npoints,numlevels) real(TEST_TM_KIND_) :: answer1(1,1,1), answer2(npoints,npoints,numlevels)